You can subscribe to this list here.
2008 |
Jan
|
Feb
|
Mar
|
Apr
|
May
|
Jun
|
Jul
|
Aug
|
Sep
|
Oct
(28) |
Nov
(30) |
Dec
(1) |
---|---|---|---|---|---|---|---|---|---|---|---|---|
2009 |
Jan
(1) |
Feb
(6) |
Mar
|
Apr
|
May
|
Jun
(61) |
Jul
(36) |
Aug
(17) |
Sep
(22) |
Oct
(57) |
Nov
(24) |
Dec
(5) |
2010 |
Jan
(32) |
Feb
(22) |
Mar
(15) |
Apr
(10) |
May
|
Jun
|
Jul
(1) |
Aug
|
Sep
(12) |
Oct
(5) |
Nov
|
Dec
|
2011 |
Jan
|
Feb
|
Mar
|
Apr
(1) |
May
|
Jun
|
Jul
(3) |
Aug
|
Sep
|
Oct
|
Nov
|
Dec
|
From: <Fi...@us...> - 2011-07-17 09:25:48
|
Revision: 416 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=416&view=rev Author: FireEgl Date: 2011-07-17 09:25:42 +0000 (Sun, 17 Jul 2011) Log Message: ----------- In pub/msg binds, if [string trim $command] eq {}, then return. Modified Paths: -------------- tcldrop/modules/tcldrop/irc-1.tm Modified: tcldrop/modules/tcldrop/irc-1.tm =================================================================== --- tcldrop/modules/tcldrop/irc-1.tm 2011-07-17 09:23:12 UTC (rev 415) +++ tcldrop/modules/tcldrop/irc-1.tm 2011-07-17 09:25:42 UTC (rev 416) @@ -161,6 +161,8 @@ # This calls all MSG binds: proc ::tcldrop::irc::callmsg {nick uhost handle command text} { set retval 0 + # $command has to be something other than whitespace, otherwise just ignore it: + if {[string trim $command] eq {}} { return $retval } set log 0 set failed 0 set matchattr -1 @@ -192,6 +194,8 @@ # This calls all PUB binds: proc ::tcldrop::irc::callpub {nick uhost handle channel command text} { set retval 0 + # $command has to be something other than whitespace, otherwise just ignore it: + if {[string trim $command] eq {}} { return $retval } set log 0 set failed 0 set matchattr -1 This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <Fi...@us...> - 2011-07-17 09:23:18
|
Revision: 415 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=415&view=rev Author: FireEgl Date: 2011-07-17 09:23:12 +0000 (Sun, 17 Jul 2011) Log Message: ----------- Minor changes. Modified Paths: -------------- tcldrop/modules/tcldrop/core-1.tm Modified: tcldrop/modules/tcldrop/core-1.tm =================================================================== --- tcldrop/modules/tcldrop/core-1.tm 2011-07-17 08:29:36 UTC (rev 414) +++ tcldrop/modules/tcldrop/core-1.tm 2011-07-17 09:23:12 UTC (rev 415) @@ -939,7 +939,8 @@ foreach b [lsort [array names binds [string tolower $typemask],*,*,*]] { dict with binds($b) { lappend matchbinds $type $flags $mask $proc } } - } else { + # [llength [info level 0]] == 3 just checks to see if $text was provided or not: + } elseif {[llength [info level 0]] == 3} { # Match type and regex: foreach b [lsort [array names binds [string tolower $typemask],*,*,*]] { if {[regexp -- [dict get $binds($b) regex] $text]} { @@ -2246,7 +2247,7 @@ } # Returns 1 if we're in the middle of a restart, 0 if we're not: -proc ::tcldrop::core::isrestart {{type {*}}} { if {[info exists ::restart] && [string match -nocase $type $::restart]} { return 1 } else { return 0 } } +proc ::tcldrop::core::isrestart {{type {*}}} { expr {[info exists ::restart] && [string match -nocase $type $::restart]} } proc ::tcldrop::core::restart {{type {restart}}} { variable StartTime This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <Fi...@us...> - 2011-07-17 08:29:42
|
Revision: 414 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=414&view=rev Author: FireEgl Date: 2011-07-17 08:29:36 +0000 (Sun, 17 Jul 2011) Log Message: ----------- In Pubm, ignore input lines that are only whitespace. Modified Paths: -------------- tcldrop/scripts/pubsafetcl-eggdrop.tcl Modified: tcldrop/scripts/pubsafetcl-eggdrop.tcl =================================================================== --- tcldrop/scripts/pubsafetcl-eggdrop.tcl 2011-04-09 03:25:32 UTC (rev 413) +++ tcldrop/scripts/pubsafetcl-eggdrop.tcl 2011-07-17 08:29:36 UTC (rev 414) @@ -285,7 +285,8 @@ proc EggdropPubm {nick host hand chan arg} { if {[channel get $chan safetcl] && [preferredbot $chan]} { set errors 0 - if {([string trim $arg ;] == {}) || [hassmiley $arg]} { + # Ignore lines with ; or nothing but whitespace or if it's just a smiley face: + if {([string trim $arg ;] eq {}) || [string trim $arg] eq {} || [hassmiley $arg]} { return 0 } elseif {[string index [set arg [string trim $arg]] 0] == {;} && [string length $arg] > 2} { set arg [string trimleft $arg {;}] This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <Fi...@us...> - 2011-04-09 03:25:39
|
Revision: 413 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=413&view=rev Author: FireEgl Date: 2011-04-09 03:25:32 +0000 (Sat, 09 Apr 2011) Log Message: ----------- Added support for +c user flag (common accounts). If I understand it right, [finduser] will only return a common account handle if a non-common isn't found. Added code to [finduser] that allows glob matching against the users hostmasks. Only * and ? are supported, [0-9] and the like gets escaped. (It only does this type search when you give [finduser] a glob pattern.) Modified Paths: -------------- tcldrop/modules/tcldrop/core/users-1.tm Modified: tcldrop/modules/tcldrop/core/users-1.tm =================================================================== --- tcldrop/modules/tcldrop/core/users-1.tm 2010-10-29 22:47:44 UTC (rev 412) +++ tcldrop/modules/tcldrop/core/users-1.tm 2011-04-09 03:25:32 UTC (rev 413) @@ -89,8 +89,32 @@ # Returns the matching handle, or "*" if none found. proc ::tcldrop::core::users::finduser {nuhost} { if {![string match {*!*} $nuhost]} { set nuhost "*!$nuhost" } - foreach u [userlist] { foreach h [getuser $u hosts] { if {[string match -nocase $h $nuhost]} { return $u } } } - return {*} + # First search where each hostmask in [getuser $u hosts] is the glob pattern: + foreach u [userlist] { + foreach h [getuser $u hosts] { + if {[string match -nocase $h $nuhost]} { + if {[matchattr $u c]} { + set common $u + } else { + return $u + } + } + } + } + # Then search where $nuhost is the glob pattern (blocking use of [0-9]): + if {[string match {*\**} $nuhost] || [string match {*\?*} $nuhost]} { + set nuhost [string map {{[} {\[} "\\" {\\}} $nuhost] + foreach u [userlist] { + if {[lsearch -nocase -glob [getuser $u hosts] $nuhost] != -1} { + if {[matchattr $u c]} { + set common $u + } else { + return $u + } + } + } + } + if {[info exists common]} { return $common } else { return {*} } } # Checks $handle for $flags, $channel is optional. This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <Fi...@us...> - 2010-10-29 22:47:50
|
Revision: 412 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=412&view=rev Author: FireEgl Date: 2010-10-29 22:47:44 +0000 (Fri, 29 Oct 2010) Log Message: ----------- Added [getudefs] and [chansettype] (as an alias to [udeftype]) Tcl commands. Modified Paths: -------------- tcldrop/modules/tcldrop/channels-1.tm Modified: tcldrop/modules/tcldrop/channels-1.tm =================================================================== --- tcldrop/modules/tcldrop/channels-1.tm 2010-10-28 01:39:34 UTC (rev 411) +++ tcldrop/modules/tcldrop/channels-1.tm 2010-10-29 22:47:44 UTC (rev 412) @@ -40,7 +40,7 @@ variable predepends {core} variable depends {core::database core} variable rcsid {$Id$} - namespace export channel channels loadchannels savechannels validchan setudef renudef deludef validudef callchannel countchannels newchanbei newbei stickbei unstickbei killchanbei killbei isbei ischanbei ispermbei isbeisticky matchbei beilist listbeis loadbeis savebeis newchanban newban stick unstick killchanban killban isban ischanban ispermban isbansticky matchban banlist listbans newchanexempt newexempt stickexempt unstickexempt killchanexempt killexempt isexempt ischanexempt ispermexempt isexemptsticky matchexempt exemptlist listexempts newchaninvite newinvite stickinvite unstickinvite killchaninvite killinvite isinvite ischaninvite isperminvite isinvitesticky matchinvite invitelist listinvites newchanignore newignore stickignore unstickignore killchanignore killignore isignore ischanignore ispermignore isignoresticky matchignore ignorelist listignores isdynamic udeftype udefs validchanname + namespace export channel channels loadchannels savechannels validchan udefs setudef renudef deludef validudef getudefs udeftype chansettype callchannel countchannels newchanbei newbei stickbei unstickbei killchanbei killbei isbei ischanbei ispermbei isbeisticky matchbei beilist listbeis loadbeis savebeis newchanban newban stick unstick killchanban killban isban ischanban ispermban isbansticky matchban banlist listbans newchanexempt newexempt stickexempt unstickexempt killchanexempt killexempt isexempt ischanexempt ispermexempt isexemptsticky matchexempt exemptlist listexempts newchaninvite newinvite stickinvite unstickinvite killchaninvite killinvite isinvite ischaninvite isperminvite isinvitesticky matchinvite invitelist listinvites newchanignore newignore stickignore unstickignore killchanignore killignore isignore ischanignore ispermignore isignoresticky matchignore ignorelist listignores isdynamic validchanname variable commands [namespace export] namespace path [list ::tcldrop] namespace unknown unknown @@ -244,7 +244,9 @@ } } -# Note, types for udef's should be: flag, int, str, and list. +# COMPATIBILITY NOTICE: udefs in Tcldrop contain both "built-in" and "user-defined" udefs. + +# Note, types for udef's should be: flag, int, pair, str, and list. # In the case of lists, the channel command should provide lappend, lreplace, and lremove commands. # This is a filter type bind for [channel add], [channel set], and [channel remove]. @@ -281,6 +283,24 @@ SetUdefDefaults $name } +# getudefs <flag/int/str> +# Returns: a list of user defined channel settings of the given type, +# or all of them if no type is given. +proc ::tcldrop::channels::getudefs {{type {}}} { + # Note/FixMe: Eggdrop probably errors if $type is invalid. + variable Udefs + set list [list] + # Note/FixMe: We could also create a new array, called UdefTypes, which looks like (for example): + # UdefTypes(flag) "autoop enforcebans ..." + # That way we don't need a foreach here, and could just return the list.. + foreach u [array names Udefs] { + if {$type eq {} || $type eq $Udefs($u)} { + lappend list $u + } + } + return $list +} + # renudef <flag/int> <oldname> <newname> # Description: renames a user defined channel flag or integer setting. # Returns: nothing @@ -352,11 +372,15 @@ } # Gives the type of the udef given in $name: -# It returns one of the following: int, flag, str, list, or unknown. +# It returns one of the following: int, flag, str, list, pair, or unknown. proc ::tcldrop::channels::udeftype {name} { variable Udefs if {[info exists Udefs($name)]} { return $Udefs($name) } else { return {unknown} } } +# Eggdrop calls it [chansettype] instead, so create an alias for it: +# Note/FixMe: Eggdrop probably errors if $name is invalid, so this could be +# a separate command (which also errors) rather than an alias.. +interp alias {} ::tcldrop::channels::chansettype {} ::tcldrop::channels::udeftype # FixMe: remove all references to this and use udeftype proc ::tcldrop::channels::UdefType {name} { This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <Fi...@us...> - 2010-10-28 01:39:40
|
Revision: 411 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=411&view=rev Author: FireEgl Date: 2010-10-28 01:39:34 +0000 (Thu, 28 Oct 2010) Log Message: ----------- export the putkick command. Modified Paths: -------------- tcldrop/modules/tcldrop/irc-1.tm Modified: tcldrop/modules/tcldrop/irc-1.tm =================================================================== --- tcldrop/modules/tcldrop/irc-1.tm 2010-10-27 16:12:46 UTC (rev 410) +++ tcldrop/modules/tcldrop/irc-1.tm 2010-10-28 01:39:34 UTC (rev 411) @@ -38,7 +38,7 @@ variable author {Tcldrop-Dev} variable description {Provides all IRC related commands.} variable rcsid {$Id$} - variable commands [list resetchan onchan dumpfile botonchan nick2hand hand2nick handonchan getchanhost getchanjoin resetchanjoin onchansplit chanlist getchanidle resetchanidle getchanmode pushmode flushmode topic ischanjuped botisop botishalfop botisvoice isop ishalfop wasop washalfop isvoice ischanban ischanexempt ischaninvite chanbans chanexempts chaninvites resetbans resetexempts resetinvites callmsgm callpubm callmsg callpub callmode callneed callflud callsign calljoin callpart callsplt callrejn calltopc callnick callkick callnotc +enforcebans callne callneop callnein callneky callnelm callbeub] + variable commands [list resetchan onchan dumpfile botonchan nick2hand hand2nick handonchan getchanhost getchanjoin resetchanjoin onchansplit chanlist getchanidle resetchanidle getchanmode pushmode flushmode putkick topic ischanjuped botisop botishalfop botisvoice isop ishalfop wasop washalfop isvoice ischanban ischanexempt ischaninvite chanbans chanexempts chaninvites resetbans resetexempts resetinvites callmsgm callpubm callmsg callpub callmode callneed callflud callsign calljoin callpart callsplt callrejn calltopc callnick callkick callnotc +enforcebans callne callneop callnein callneky callnelm callbeub] namespace path [list ::tcldrop] namespace unknown unknown # Pre-depends on these modules: This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <Fi...@us...> - 2010-10-27 16:12:52
|
Revision: 410 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=410&view=rev Author: FireEgl Date: 2010-10-27 16:12:46 +0000 (Wed, 27 Oct 2010) Log Message: ----------- Fixed a typo in the last commit. Modified Paths: -------------- tcldrop/modules/tcldrop/core-1.tm Modified: tcldrop/modules/tcldrop/core-1.tm =================================================================== --- tcldrop/modules/tcldrop/core-1.tm 2010-10-27 13:01:39 UTC (rev 409) +++ tcldrop/modules/tcldrop/core-1.tm 2010-10-27 16:12:46 UTC (rev 410) @@ -1250,7 +1250,7 @@ proc ::tcldrop::core::utimer {seconds command args} { if {[string is int -strict $args]} { # Eggdrop style repeat..err.."count".. Decrease by -1 to make it work like the -repeat option. - set repeat [incr $args -1] + set repeat [incr args -1] # Set args to something else so it'll work with [dict merge]: set args [dict create -repeat $args] } else { This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <Fi...@us...> - 2010-10-27 13:01:45
|
Revision: 409 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=409&view=rev Author: FireEgl Date: 2010-10-27 13:01:39 +0000 (Wed, 27 Oct 2010) Log Message: ----------- Add support for Eggdrop's [count] argument to utimer/timer. Tweaks to ::tcldrop::core::exit Modified Paths: -------------- tcldrop/modules/tcldrop/core-1.tm Modified: tcldrop/modules/tcldrop/core-1.tm =================================================================== --- tcldrop/modules/tcldrop/core-1.tm 2010-10-22 20:03:20 UTC (rev 408) +++ tcldrop/modules/tcldrop/core-1.tm 2010-10-27 13:01:39 UTC (rev 409) @@ -1249,8 +1249,8 @@ # If -timerid ID is specified, ID will override the default choice of the TimerID. proc ::tcldrop::core::utimer {seconds command args} { if {[string is int -strict $args]} { - # Deprecated. We should start using: -repeat -1 (or whatever we want repeat to be set to) - set repeat $args + # Eggdrop style repeat..err.."count".. Decrease by -1 to make it work like the -repeat option. + set repeat [incr $args -1] # Set args to something else so it'll work with [dict merge]: set args [dict create -repeat $args] } else { @@ -2132,13 +2132,16 @@ if {![llength [info commands ::tcldrop::core::Exit]]} { rename ::exit ::tcldrop::core::Exit proc ::tcldrop::core::exit {{code {0}} {reason {Exit}}} { - if {![info exists ::exit]} { set ::exit $code } + global exit die shutdown pidfile + if {![info exists shutdown]} { set shutdown $reason } + if {![info exists die]} { set die $reason } + if {![info exists exit]} { set exit $code } catch { callevent exit } # Save the untranslated strings to ROOT.msg: #mcsaveunknowns - catch { file delete -force -- $::pidfile } + catch { file delete -force -- $pidfile } # This is the real exit command: - catch { ::tcldrop::core::Exit $::exit } + catch { ::tcldrop::core::Exit $exit } # We shouldn't ever make it to here.. o_O But unset these variables so the bot can keep running normally (maybe..who knows): after idle [list after 999 [list unset -nocomplain ::exit ::die ::shutdown]] return $code This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pi...@us...> - 2010-10-22 20:03:26
|
Revision: 408 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=408&view=rev Author: pixelz Date: 2010-10-22 20:03:20 +0000 (Fri, 22 Oct 2010) Log Message: ----------- Fixed a bug that could make .bottree look weird in certain situations. Fix by thommey. Modified Paths: -------------- tcldrop/modules/tcldrop/bots/dcc-1.tm Modified: tcldrop/modules/tcldrop/bots/dcc-1.tm =================================================================== --- tcldrop/modules/tcldrop/bots/dcc-1.tm 2010-09-13 17:54:00 UTC (rev 407) +++ tcldrop/modules/tcldrop/bots/dcc-1.tm 2010-10-22 20:03:20 UTC (rev 408) @@ -143,7 +143,7 @@ # proc by thommey # walk the tree recursively starting with us -proc ::tcldrop::bots::dcc::printtree {idx {version 0} {childrendict {}} {root {}} {indentionlvl -1} {endlvl 0}} { +proc ::tcldrop::bots::dcc::printtree {idx {version 0} {childrendict {}} {root {}} {indentionlvl -1} {endlvls {}}} { if {$root eq {}} { set root ${::botnet-nick} } if {$childrendict eq {}} { set childrendict [getallbotschildren] } set children [dict get $childrendict [string tolower $root]] @@ -154,22 +154,22 @@ incr indentionlvl set prefix " " for {set i 0} {$i < $indentionlvl} {incr i} { - if {$i < $endlvl} { append prefix " " } else { append prefix "|" } + if {$i in $endlvls} { append prefix " " } else { append prefix "|" } append prefix " " } for {set i 0} {$i < [llength $children]} {incr i} { set child [lindex $children $i] set suffix "[dict get $::bots($child) icon][dict get $::bots($child) handle]" - if {$version} { append suffix " ([dict get $::bots($child) type] [dict get $::bots($child) numversion])" }; # FixMe: this should display version instead of numversion + if {$version} { append suffix " ([dict get $::bots($child) type] [dict get $::bots($child) numversion])" }; # FixMe: this shold display version instead of numversion # not last child? "`--", else "|--" if {$i < [llength $children]-1} { putdcc $idx "$prefix|-$suffix" } else { putdcc $idx "$prefix`-$suffix" - incr endlvl + lappend endlvls $indentionlvl } # and walk on with the recursion for this child - printtree $idx $version $childrendict $child $indentionlvl $endlvl + printtree $idx $version $childrendict $child $indentionlvl $endlvls } } This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <Fi...@us...> - 2010-09-13 17:54:07
|
Revision: 407 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=407&view=rev Author: FireEgl Date: 2010-09-13 17:54:00 +0000 (Mon, 13 Sep 2010) Log Message: ----------- Added support for several mask-type in [getbinds]: regexp-nocase, regexp, exact-nocase, exact, glob-nocase, glob, and matchstr (for matching IRC nicks). Added 1-Minute loops. (untested?) Modified Paths: -------------- tcldrop/modules/tcldrop/core-1.tm Modified: tcldrop/modules/tcldrop/core-1.tm =================================================================== --- tcldrop/modules/tcldrop/core-1.tm 2010-09-13 16:18:16 UTC (rev 406) +++ tcldrop/modules/tcldrop/core-1.tm 2010-09-13 17:54:00 UTC (rev 407) @@ -45,11 +45,11 @@ if {![llength [info commands Tcldrop]]} { proc Tcldrop {args} { namespace eval ::tcldrop $args } } if {![llength [info commands tcldrop]]} { proc tcldrop {args} { namespace eval ::tcldrop $args } } namespace export Tcldrop tcldrop PutLogLev stdout stderr - foreach {V D} [list botname {} userfile-create 0 dirname . channel-stats 0 config tcldrop.conf background-mode 0 host_env tclsh version 0 numversion 0 config-eval {} simulate-dcc 1 author {Tcldrop-Dev} name {Tcldrop} depends {Tcl} description {Tcldrop, the Eggdrop-like IRC bot written in pure-Tcl.} rcsid {} commands [list Tcldrop tcldrop PutLogLev stdout stderr] script {}] { + foreach {V D} [list botname {} userfile-create 0 dirname . channel-stats 0 config tcldrop.conf background-mode 0 hostenv unknown version 0 numversion 0 config-eval {} simulate-dcc 1 author {Tcldrop-Dev} name {Tcldrop} depends {Tcl} description {Tcldrop, the Eggdrop-like IRC bot written in pure-Tcl.} rcsid {} commands [list Tcldrop tcldrop PutLogLev stdout stderr] script {}] { if {![info exists ::tcldrop($V)]} { set ::tcldrop($V) $D } } unset V D - if {{eggdrop} in [package names]} { set ::tcldrop(host_env) {eggdrop} } + #if {{eggdrop} in [package names]} { set ::tcldrop(hostenv) {eggdrop} } namespace export {*}$::tcldrop(commands) set ::modules(tcldrop) [array get ::tcldrop] # Stub commands, in case they don't already exist: @@ -202,6 +202,8 @@ variable TimerIDCount 0 variable Flood array set Flood {} + variable Minutely_AfterID + if {![info exists Minutely_AfterID]} { variable Minutely_AfterID {} } set ::modules(core) [list name $name version $version depends $depends author $author description $description rcsid $rcsid commands $commands script $script] } @@ -859,16 +861,22 @@ # Tcldrop also allows these extra (optional) options in $args: # -priority <1-99> This defines the order of priority. (lower gets processed first) # Default is 50. Priorities <0 and >100 are reserved for Tcldrop internal use. -proc ::tcldrop::core::bind {type flags mask proc args} { +proc ::tcldrop::core::bind {type flags mask {proc {}} args} { # Note/FixMe: Eggdrop checks to make sure $type is a valid bind type before accepting it, but currently I don't see why that's such a great idea. switch -- $flags { {-} - {+} - {*} - {-|-} - {*|*} - {|} - {} - { } - { } { set flags {+|+} } {default} { if {![string match {*|*} $flags]} { set flags "$flags|-" } } } # Allow the mask to be a regex pattern (anything starting with ^ and ending with $ will be considered a regex pattern): - if {[string match {^*$} $mask] && ![catch { regexp -- $mask {} }]} { set regex $mask } else { set regex [mask2regex $mask] } + set mask-type {glob} + if {[string match {(\?*)^*$} $mask] && ![catch { regexp -- $mask {} }]} { + set regex $mask + set mask-type {regexp} + } else { + set regex [mask2regex $mask] + } # Send the bind info through callbind (triggering "BIND" binds) so they can possibly change it or return an error: - if {[catch { callbind [dict create regex $regex proc $proc count 0 flags $flags -priority 50 type $type mask $mask {*}$args] } bindinfo opt]} { + if {[catch { callbind [dict create regex $regex proc $proc count 0 flags $flags -priority 50 type $type mask $mask mask-type glob-nocase {*}$args] } bindinfo opt]} { # Return an error, causing the bind command to fail: return -code error -options $opt $bindinfo } else { @@ -949,15 +957,54 @@ set matchbinds [dict create] global binds if {$text eq {}} { - # Match type only: + # Match by type only: foreach b [lsort [array names binds [string tolower $typemask],*,*,*]] { dict set matchbinds $b $binds($b) } } else { - # Match type and regex: + # Match by type and mask: foreach b [lsort [array names binds [string tolower $typemask],*,*,*]] { - if {[regexp -- [dict get $binds($b) regex] $text]} { - dict set matchbinds $b $binds($b) + switch -- [dict get $binds($b) mask-type] { + {regexp-nocase} - {regex-nocase} { + if {[regexp -nocase -- [dict get $binds($b) regex] $text]} { + dict set matchbinds $b $binds($b) + } + } + {regexp} - {regex} { + if {[regexp -- [dict get $binds($b) regex] $text]} { + dict set matchbinds $b $binds($b) + } + } + {exact-nocase} { + if {[string equal -nocase [dict get $binds($b) mask] $text]} { + dict set matchbinds $b $binds($b) + } + } + {exact} { + if {[string equal [dict get $binds($b) mask] $text]} { + dict set matchbinds $b $binds($b) + } + } + {glob-nocase} { + if {[string match -nocase [dict get $binds($b) mask] $text]} { + dict set matchbinds $b $binds($b) + } + } + {glob} { + if {[string match [dict get $binds($b) mask] $text]} { + dict set matchbinds $b $binds($b) + } + } + {matchstr} { + if {[string match -nocase [string map {{[} {\[} "\\" {\\}} [dict get $binds($b) mask]] $text]} { + dict set matchbinds $b $binds($b) + } + } + {unknown} - {} - {default} { + if {[dict get $binds($b) mask] eq $text} { + dict set matchbinds $b $binds($b) + } + } } } } @@ -1315,38 +1362,42 @@ } } -# Note: This doesn't guaranty that time-specific binds will always be -# triggered.. For example, if the bot/process is busy for over 60 -# seconds and there was proc was supposed to be trigged during that -# minute, the proc won't be called.. We'll have skipped over that minute. -# At any rate, this proc should be as small and as fast as possible... -# So, I don't believe it should call time binds for times that have -# already past. Any script that needs to simply be repeated every so -# often should use the timer command and its -1 (repeat forever) option. -# FixMe: Add the ability to log the following: -# timer: drift (lastmin=22, now=26) -# timer: drift (lastmin=23, now=26) -# timer: drift (lastmin=24, now=26) -# timer: drift (lastmin=25, now=26) -# (!) timer drift -- spun 4 minutes -proc ::tcldrop::core::calltime {} { - lassign [set current [clock format [clock seconds] -format {%M %H %d %m %Y}]] minute hour day month year - foreach {type flags mask proc} [bindlist time] { - if {[bindmatch $mask $current]} { - if {[catch { $proc $minute $hour $day $month $year } err]} { - putlog "[mc {Error in script}]: $proc: $err" - puterrlog "$::errorInfo" - } - countbind $type $mask $proc +# 1-Minute loop, offset to +1 second into each minute. +proc ::tcldrop::core::Minutely {last} { + # Start another after timer to run this proc again at the start of the next minute + 1 second + 17ms to 126ms: + variable Minutely_AfterID [after [expr { 60000 - ([clock milliseconds] % 60000) + 1017 + int(rand() * 127) }] [namespace code [list Minutely [set now [clock seconds]]]]] + # FixMe: Add the ability to log the following: + # timer: drift (lastmin=22, now=26) + # timer: drift (lastmin=23, now=26) + # timer: drift (lastmin=24, now=26) + # timer: drift (lastmin=25, now=26) + # (!) timer drift -- spun 4 minutes + putlog "LAST: [clock format $last]" + putlog "NOW: [clock format $now]" + # For every minute that's passed since we last ran, do the TIME and CRON binds: + set drift 0 + while {[incr last 60] <= $now} { + calltime $last + callcron $last + incr drift + } + putlog "NEXT: [clock format $last]" + if {$drift > 1} { putlog "[mc {(!) timer drift -- spun %d minutes} $drift]" } +} + +proc ::tcldrop::core::calltime {seconds} { + lassign [set current [clock format $seconds -format {%M %H %d %m %Y}]] minute hour day month year + foreach {type flags mask proc} [bindlist time $current] { + if {[catch { $proc $minute $hour $day $month $year } err]} { + putlog "[mc {Error in script}]: $proc: $err" + puterrlog "$::errorInfo" } - # time binds aren't really time critical, so trigger any other events that are waiting: - update idletasks + countbind $type $mask $proc } - callcron } -proc ::tcldrop::core::callcron {} { - lassign [clock format [clock seconds] -format {%M %k %e %N %w}] minute hour day month dayofweek +proc ::tcldrop::core::callcron {seconds} { + lassign [clock format $seconds -format {%M %k %e %N %w}] minute hour day month dayofweek # Remove the zero-padding from the minutes: set minute [scan $minute {%d}] dict for {id info} [getbinds cron] { @@ -2300,7 +2351,10 @@ proc ::tcldrop::core::DailyUpdates {minute hour day month year} { callevent daily-updates } bind time - "* ${::daily-updates} * * *" ::tcldrop::core::DailyUpdates # Start the one-minute loop needed by scripts that use "bind time": - afteridle timer 1 [list {::tcldrop::core::calltime}] -1 + #afteridle timer 1 [list {::tcldrop::core::calltime}] -1 + variable Minutely_AfterID + after cancel $Minutely_AfterID + Minutely [clock seconds] } # Don't allow the core module to be unloaded: proc ::tcldrop::core::UNLD {module} { return 1 } This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <Fi...@us...> - 2010-09-13 16:18:22
|
Revision: 406 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=406&view=rev Author: FireEgl Date: 2010-09-13 16:18:16 +0000 (Mon, 13 Sep 2010) Log Message: ----------- Added a FixMe. Increase the default max-queue-msg to 999 (was 99). Modified Paths: -------------- tcldrop/modules/tcldrop/server-1.tm Modified: tcldrop/modules/tcldrop/server-1.tm =================================================================== --- tcldrop/modules/tcldrop/server-1.tm 2010-09-13 16:16:07 UTC (rev 405) +++ tcldrop/modules/tcldrop/server-1.tm 2010-09-13 16:18:16 UTC (rev 406) @@ -211,6 +211,7 @@ # Proxychain style: address:port or http://127.0.0.1:8080/address:port # Option type style: -address <address> -port <port> # Eggdrop style: address port + # FixMe: Add support for: 2001:db8:618:5c0:263::,6669:password switch -glob -- [lindex $args 0] { {*:*} { # Proxychain style. @@ -635,7 +636,7 @@ setdefault server-cycle-wait {93} setdefault servererror-quit {1} setdefault check-stoned {1} - setdefault max-queue-msg {99} + setdefault max-queue-msg {999} setdefault network {Unknown} setdefault modes-per-line {3} -protect 1 setdefault max-bans {12} This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <Fi...@us...> - 2010-09-13 16:16:13
|
Revision: 405 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=405&view=rev Author: FireEgl Date: 2010-09-13 16:16:07 +0000 (Mon, 13 Sep 2010) Log Message: ----------- Only create a randstring proc if it doesn't already exist. Modified Paths: -------------- tcldrop/scripts/alltools.tcl Modified: tcldrop/scripts/alltools.tcl =================================================================== --- tcldrop/scripts/alltools.tcl 2010-09-13 16:14:35 UTC (rev 404) +++ tcldrop/scripts/alltools.tcl 2010-09-13 16:16:07 UTC (rev 405) @@ -240,6 +240,7 @@ islinked $bot } +if {![llength [info commands randstring]]} { proc randstring {length {chars abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789}} { if {([string compare "" $length]) && \ (![regexp \[^0-9\] $length])} then { @@ -256,6 +257,7 @@ } return $result } +} proc putdccall {text} { foreach i [dcclist CHAT] { This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <Fi...@us...> - 2010-09-13 16:14:41
|
Revision: 404 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=404&view=rev Author: FireEgl Date: 2010-09-13 16:14:35 +0000 (Mon, 13 Sep 2010) Log Message: ----------- Minor change to -myaddr handling. (no longer treat 0.0.0.0 or :: the same as "") Modified Paths: -------------- tcldrop/lib/proxy/proxy.tcl Modified: tcldrop/lib/proxy/proxy.tcl =================================================================== --- tcldrop/lib/proxy/proxy.tcl 2010-09-13 16:08:43 UTC (rev 403) +++ tcldrop/lib/proxy/proxy.tcl 2010-09-13 16:14:35 UTC (rev 404) @@ -61,10 +61,7 @@ array set info [list -command {} -readable {} -writable {} -errors {} socket {} -buffering line -encoding [encoding system] -blocking 0 -myaddr {} -async 1 -ssl 0 -timeout 99999 -socket-command [list socket]] array set info $args if {$info(-async)} { set async [list {-async}] } else { set async [list] } - switch -- $info(-myaddr) { - {0.0.0.0} - {::} - {} { set myaddr [list] } - {default} { set myaddr [list {-myaddr} $info(-myaddr)] } - } + if {$info(-myaddr) ne {}} { set myaddr [list {-myaddr} $info(-myaddr)] } else { set myaddr [list] } array set info [splitchain $chain] array set firstinfo $info(1) variable [set info(socket) [eval $info(-socket-command) $async $myaddr [list $firstinfo(address) $firstinfo(port)]]] This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <Fi...@us...> - 2010-09-13 16:08:51
|
Revision: 403 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=403&view=rev Author: FireEgl Date: 2010-09-13 16:08:43 +0000 (Mon, 13 Sep 2010) Log Message: ----------- Uncommited changes. Modified Paths: -------------- tcldrop/modules/tcldrop/channels-1.tm Modified: tcldrop/modules/tcldrop/channels-1.tm =================================================================== --- tcldrop/modules/tcldrop/channels-1.tm 2010-09-12 14:13:35 UTC (rev 402) +++ tcldrop/modules/tcldrop/channels-1.tm 2010-09-13 16:08:43 UTC (rev 403) @@ -250,17 +250,16 @@ # This is a filter type bind for [channel add], [channel set], and [channel remove]. # Whatever's given to the binds can be returned, changed, or raise an error. proc ::tcldrop::channels::callchannel {command channel args} { - foreach {type flags mask proc} [bindlist channel] { - if {[bindmatch $mask "$command $channel [join $args]"]} { - countbind $type $mask $proc - if {[catch { set args [lassign [$proc $command $channel {*}$args] command channel] } err]} { - putlog "[mc {Error in %s} $proc]: $err" - puterrlog "$::errorInfo" - return -code error $err - } + foreach {id info} [getbinds channel "$command $channel [join $args]"] { + countbind $id + if {[catch { set args [lassign [[dict get $info proc] $command $channel {*}$args] command channel] } err opt]} { + # FixMe: If these putlogs result in duplicate putlogs, remove them: + putlog "[mc {Error in %s} [dict get $info proc]]: $err" + puterrlog "$::errorInfo" + return -code error -level 2 -options $opt $err } } - list $command $channel {*}$args + return [list $command $channel {*}$args] } # Defines a new udef: This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <joh...@us...> - 2010-09-12 14:13:42
|
Revision: 402 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=402&view=rev Author: johannes-kuhn Date: 2010-09-12 14:13:35 +0000 (Sun, 12 Sep 2010) Log Message: ----------- Adding channels should not rise an error anymore. Modified Paths: -------------- tcldrop/modules/tcldrop/channels-1.tm Modified: tcldrop/modules/tcldrop/channels-1.tm =================================================================== --- tcldrop/modules/tcldrop/channels-1.tm 2010-09-12 13:02:33 UTC (rev 401) +++ tcldrop/modules/tcldrop/channels-1.tm 2010-09-12 14:13:35 UTC (rev 402) @@ -192,6 +192,7 @@ # Just like in Eggdrop, returns the list of channels. # FixMe: Make [channels] a namespace ensemble if/when they fix it so the -unknown option works properly. +# The unknown option works (for me) you have to return the command that should be called (a list). :P proc ::tcldrop::channels::channels {args} { if {$args eq {*} || [llength $args] == 0 || [validchan [lindex $args 0]]} { set list [list] @@ -344,7 +345,8 @@ #} foreach channel [channels] { if {[catch { channel get $channel $udef }]} { - channel set $channel $udef $UdefDefaults($udef) + # channel set $channel $udef $UdefDefaults($udef) + database channels set [irctoupper $channel] $udef $UdefDefaults($udef) } } } This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <joh...@us...> - 2010-09-12 13:02:39
|
Revision: 401 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=401&view=rev Author: johannes-kuhn Date: 2010-09-12 13:02:33 +0000 (Sun, 12 Sep 2010) Log Message: ----------- Fixed a bug where ispermban/ispermexempt/isperminvite returns an error. Returns now 0 (like eggdrop). Did this also with sticky bans/exempts/invites. Modified Paths: -------------- tcldrop/modules/tcldrop/channels-1.tm Modified: tcldrop/modules/tcldrop/channels-1.tm =================================================================== --- tcldrop/modules/tcldrop/channels-1.tm 2010-09-09 14:37:58 UTC (rev 400) +++ tcldrop/modules/tcldrop/channels-1.tm 2010-09-12 13:02:33 UTC (rev 401) @@ -50,6 +50,8 @@ # Note: - is used in place of a channel name when it applies globally. +#TODO: make this a namespace ensemble +#TODO: make this a namespace ensemble proc ::tcldrop::channels::channel {command {channel {}} args} { # Note: Follow RFC 2812 regarding "2.2 Character codes", http://tools.ietf.org/html/rfc2812 # Note that RFC 2812 gets the case of ^ and ~ backwards. ^ = uppercase ~ = lowercase @@ -447,7 +449,7 @@ return 0 } } else { - return -code error "[mc {No such %1$s %2$s %3$s} ${bei} $channel $mask]" + return 0 } } @@ -455,7 +457,7 @@ if {[dict exists $::database(${bei}s) [irctoupper $channel] [string tolower $mask] sticky]} { dict get $::database(${bei}s) [irctoupper $channel] [string tolower $mask] sticky } else { - return -code error "[mc {No such %1$s %2$s %3$s} ${bei} $channel $mask]" + return 0 } } This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <joh...@us...> - 2010-09-09 14:38:04
|
Revision: 400 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=400&view=rev Author: johannes-kuhn Date: 2010-09-09 14:37:58 +0000 (Thu, 09 Sep 2010) Log Message: ----------- Some minor fixes on pubsafetclclient.tcl. The extra command feature of pubsafetcl-eggdrop.tcl is only used for the harmless tcldrop/eggdrop commands by default. TODO: Write a warning about the security risks by enabling extraCommands for specific flags. Modified Paths: -------------- tcldrop/lib/pubsafetclclient.tcl tcldrop/scripts/pubsafetcl-eggdrop.tcl Modified: tcldrop/lib/pubsafetclclient.tcl =================================================================== --- tcldrop/lib/pubsafetclclient.tcl 2010-09-09 02:10:29 UTC (rev 399) +++ tcldrop/lib/pubsafetclclient.tcl 2010-09-09 14:37:58 UTC (rev 400) @@ -174,7 +174,7 @@ } proc Reset {{interp safetcl}} { - Reset2 0 + Reset2 $interp 0 create $interp } } \ No newline at end of file Modified: tcldrop/scripts/pubsafetcl-eggdrop.tcl =================================================================== --- tcldrop/scripts/pubsafetcl-eggdrop.tcl 2010-09-09 02:10:29 UTC (rev 399) +++ tcldrop/scripts/pubsafetcl-eggdrop.tcl 2010-09-09 14:37:58 UTC (rev 400) @@ -226,7 +226,7 @@ return 0 } elseif {[preferredbot $chan]} { variable extraCommands - set commands {} + set commands $extraCommands(-) foreach f [array names extraCommands] { if {[matchattr $hand $f|$f $chan]} { set commands [lsort -unique [concat $extraCommands($f) $commands]] } } safetcl setting extraCommands $commands array set evalinfo [list puts {} putloglev {}] This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <Fi...@us...> - 2010-09-09 02:10:36
|
Revision: 399 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=399&view=rev Author: FireEgl Date: 2010-09-09 02:10:29 +0000 (Thu, 09 Sep 2010) Log Message: ----------- Lots of previously uncommitted changes.. Not sure what they do. =\ Also fixed bugs with the SIGN and KICK raw binds. Modified Paths: -------------- tcldrop/modules/tcldrop/irc-1.tm Modified: tcldrop/modules/tcldrop/irc-1.tm =================================================================== --- tcldrop/modules/tcldrop/irc-1.tm 2010-09-09 00:52:12 UTC (rev 398) +++ tcldrop/modules/tcldrop/irc-1.tm 2010-09-09 02:10:29 UTC (rev 399) @@ -118,8 +118,8 @@ proc ::tcldrop::irc::callmsgm {nick uhost handle text} { set retval 0 set nolog 0 - foreach {type flags mask proc} [bindlist msgm] { - if {[bindmatch $mask $text] && [matchattr $handle $flags]} { + foreach {type flags mask proc} [bindlist msgm $text] { + if {[matchattr $handle $flags]} { countbind $type $mask $proc if {[catch { $proc $nick $uhost $handle $text } err]} { putlog "[mc {Error in script}]: $proc: $err" @@ -140,8 +140,8 @@ proc ::tcldrop::irc::callpubm {nick uhost handle channel text} { set retval 0 set nolog 0 - foreach {type flags mask proc} [bindlist pubm] { - if {[bindmatch $mask "$channel $text"] && [matchattr $handle $flags $channel]} { + foreach {type flags mask proc} [bindlist pubm "$channel $text"] { + if {[matchattr $handle $flags $channel]} { countbind $type $mask $proc if {[catch { $proc $nick $uhost $handle $channel $text } err]} { putlog "[mc {Error in script}]: $proc: $err" @@ -164,8 +164,8 @@ set log 0 set failed 0 set matchattr -1 - foreach {type flags mask proc} [bindlist msg] { - if {[bindmatch $mask $command] && [set matchattr [matchattr $handle $flags]]} { + foreach {type flags mask proc} [bindlist msg $command] { + if {[set matchattr [matchattr $handle $flags]]} { countbind $type $mask $proc if {[catch { $proc $nick $uhost $handle $text } err]} { putlog "[mc {Error in script}]: $proc: $err" @@ -195,8 +195,8 @@ set log 0 set failed 0 set matchattr -1 - foreach {type flags mask proc} [bindlist pub] { - if {[bindmatch $mask $command] && [set matchattr [matchattr $handle $flags $channel]]} { + foreach {type flags mask proc} [bindlist pub $command] { + if {[set matchattr [matchattr $handle $flags $channel]]} { countbind $type $mask $proc if {[catch { $proc $nick $uhost $handle $channel $text } err]} { putlog "[mc {Error in script}]: $proc: $err" @@ -220,8 +220,8 @@ } proc ::tcldrop::irc::callpart {nick uhost handle channel {msg {}}} { - foreach {type flags mask proc} [bindlist part] { - if {[bindmatch $mask "$channel $uhost"] && [matchattr $handle $flags $channel]} { + foreach {type flags mask proc} [bindlist part "$channel $uhost"] { + if {[matchattr $handle $flags $channel]} { if {[catch { $proc $nick $uhost $handle $channel $msg } err]} { putlog "[mc {Error in script}]: $proc: $err" puterrlog "$::errorInfo" @@ -236,26 +236,26 @@ } proc ::tcldrop::irc::callkick {nick uhost handle channel target {reason {}}} { - foreach {type flags mask proc} [bindlist kick] { - if {[bindmatch $mask "$channel $target"]} { - if {[catch { $proc $nick $uhost $handle $channel $target $reason } err]} { - putlog "[mc {Error in script}]: $proc: $err" - puterrlog "$::errorInfo" - } - countbind $type $mask $proc + foreach {type flags mask proc} [bindlist kick "$channel $target"] { + # FixMe: Whose flags do we match against here, if any? + if {[catch { $proc $nick $uhost $handle $channel $target $reason } err]} { + putlog "[mc {Error in script}]: $proc: $err" + puterrlog "$::errorInfo" } + countbind $type $mask $proc } - array unset ::channelnicks [irctoupper "$channel,$nick"] - if {![llength [array names ::channelnicks *,[irctoupper $nick]]]} { + array unset ::channelnicks [irctoupper "$channel,$target"] + if {![llength [array names ::channelnicks "*,[irctoupper $target]"]]} { + # Unset any non-channel info we know about target as well if they're not on any other channels: array unset ::nicks [irctoupper $target] } } proc ::tcldrop::irc::callsign {nick uhost {handle {*}} {chanmask {*}} {msg {Quit}}} { # Call all the sign binds: - foreach {type flags mask proc} [bindlist sign] { + foreach {type flags mask proc} [bindlist sign "$chanmask $nick!$uhost"] { foreach channel [channels $chanmask] { - if {[bindmatch $mask "$channel $nick!$uhost"] && [matchattr $handle $flags $channel]} { + if {[matchattr $handle $flags $channel]} { if {[catch { $proc $nick $uhost $handle $channel $msg } err]} { putlog "[mc {Error in script}]: $proc: $err" puterrlog "$::errorInfo" @@ -317,8 +317,8 @@ channickinfo $channel $nick idletime [clock seconds] jointime [clock seconds] nick $nick uhost $uhost handle $handle channel $channel op 0 voice 0 halfop 0 wasop 0 washalfop 0 wasvoice 0 split 0 #set ::channelnicks([irctoupper $channel,$nick]) [list nick $nick uhost $uhost handle $handle channel $channel op 0 voice 0 halfop 0 wasop 0 washalfop 0 wasvoice 0 split 0] # Call all of the join binds: - foreach {type flags mask proc} [bindlist join] { - if {[bindmatch $mask "$channel $nick!$uhost"] && [matchattr $handle $flags $channel]} { + foreach {type flags mask proc} [bindlist join "$channel $nick!$uhost"] { + if {[matchattr $handle $flags $channel]} { if {[catch { $proc $nick $uhost $handle $channel } err]} { putlog "[mc {Error in script}]: $proc: $err" puterrlog "$::errorInfo" @@ -329,14 +329,13 @@ } proc ::tcldrop::irc::callmode {nick uhost handle channel mode {victim {}}} { - foreach {type flags mask proc} [bindlist mode] { - if {[bindmatch $mask "$channel $mode"]} { - if {[catch { $proc $nick $uhost $handle $channel $mode $victim } err]} { - putlog "[mc {Error in script}]: $proc: $err" - puterrlog "$::errorInfo" - } - countbind $type $mask $proc + foreach {type flags mask proc} [bindlist mode "$channel $mode"] { + # FixMe: Whose flags do we match again here, if any? + if {[catch { $proc $nick $uhost $handle $channel $mode $victim } err]} { + putlog "[mc {Error in script}]: $proc: $err" + puterrlog "$::errorInfo" } + countbind $type $mask $proc } } @@ -347,14 +346,13 @@ } else { set ::channels($element) $chaninfo } - foreach {type flags mask proc} [bindlist topc] { - if {[bindmatch $mask "$channel $topic"]} { - if {[catch { $proc $nick $uhost $handle $channel $topic } err]} { - putlog "[mc {Error in script}]: $proc: $err" - puterrlog "$::errorInfo" - } - countbind $type $mask $proc + foreach {type flags mask proc} [bindlist topc "$channel $topic"] { + # FixMe: Do we match flags? + if {[catch { $proc $nick $uhost $handle $channel $topic } err]} { + putlog "[mc {Error in script}]: $proc: $err" + puterrlog "$::errorInfo" } + countbind $type $mask $proc } } @@ -375,14 +373,12 @@ # Note: Eggdrop supports the following need types: op, unban, invite, limit, and key. proc ::tcldrop::irc::callneed {channel {need {join}}} { # Do the Eggdrop NEED binds: - foreach {type flags mask proc} [bindlist need] { - if {[bindmatch $mask "$channel $need"]} { - if {[catch { $proc $channel $need } err]} { - putlog "[mc {Error in script}]: $proc: $err" - puterrlog "$::errorInfo" - } - countbind $type $mask $proc + foreach {type flags mask proc} [bindlist need "$channel $need"] { + if {[catch { $proc $channel $need } err]} { + putlog "[mc {Error in script}]: $proc: $err" + puterrlog "$::errorInfo" } + countbind $type $mask $proc } # Do the old-style Eggdrop needs: if {[set script [channel get $channel "need-$need"]] != {}} { @@ -400,14 +396,12 @@ # Taken from: http://www.racbot.org/docs/tclbinds/irc_channel_event_bindings.html proc ::tcldrop::irc::callne {type channel {botnick {}}} { if {$botnick == {}} { set botnick $::botnick } - foreach {type flags mask proc} [bindlist "ne$type"] { - if {[bindmatch $mask $channel]} { - if {[catch { $proc $channel $botnick } err]} { - putlog "[mc {Error in script}]: $proc: $err" - puterrlog "$::errorInfo" - } - countbind $type $mask $proc + foreach {type flags mask proc} [bindlist "ne$type" $channel] { + if {[catch { $proc $channel $botnick } err]} { + putlog "[mc {Error in script}]: $proc: $err" + puterrlog "$::errorInfo" } + countbind $type $mask $proc } } @@ -489,8 +483,8 @@ proc ::tcldrop::irc::callnotc {nick uhost handle text dest} { - foreach {type flags mask proc} [bindlist notc] { - if {[bindmatch $mask $text] && [matchattr $handle $flags]} { + foreach {type flags mask proc} [bindlist notc $text] { + if {[matchattr $handle $flags]} { if {[catch { $proc $nick $uhost $handle $text $dest } err]} { putlog "[mc {Error in script}]: $proc: $err" puterrlog "$::errorInfo" @@ -512,15 +506,13 @@ # "*" for the bind); flags are ignored. # Module: server proc ::tcldrop::irc::callflud {nick uhost handle type {channel {}}} { - foreach {type flags mask proc} [bindlist flud] { - if {[bindmatch $mask $type]} { - countbind $type $mask $proc - if {[catch { $proc $nick $uhost $handle $type $channel } err]} { - putlog "[mc {Error in script}]: $proc: $err" - puterrlog "$::errorInfo" - } elseif {[string equal {1} $err]} { - return 1 - } + foreach {type flags mask proc} [bindlist flud $type] { + countbind $type $mask $proc + if {[catch { $proc $nick $uhost $handle $type $channel } err]} { + putlog "[mc {Error in script}]: $proc: $err" + puterrlog "$::errorInfo" + } elseif {[string equal {1} $err]} { + return 1 } } return 0 This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <joh...@us...> - 2010-09-09 00:52:19
|
Revision: 398 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=398&view=rev Author: johannes-kuhn Date: 2010-09-09 00:52:12 +0000 (Thu, 09 Sep 2010) Log Message: ----------- Finally it works. Tested. Some changes in pubsafetcl-eggdrop.tcl to make harmless eggdrop commands available in the pubsafe interp. Need some help with ulimit. Modified Paths: -------------- tcldrop/lib/pubsafetclclient.tcl tcldrop/lib/pubsafetclhost.tcl tcldrop/scripts/pubsafetcl-eggdrop.tcl Modified: tcldrop/lib/pubsafetclclient.tcl =================================================================== --- tcldrop/lib/pubsafetclclient.tcl 2010-09-08 22:25:20 UTC (rev 397) +++ tcldrop/lib/pubsafetclclient.tcl 2010-09-09 00:52:12 UTC (rev 398) @@ -42,7 +42,7 @@ proc create {{interp safetcl} args} { if {[namespace exist [namespace current]::$interp]} { - Reset $interp + Reset2 $interp } namespace eval [namespace current]::$interp [list variable interp $interp] namespace eval [namespace current]::$interp [list variable args $args] @@ -77,9 +77,10 @@ proc pubsafetcl {args} { variable interp variable remoteport - comm send $remoteport $interp {*}$args + comm send $remoteport $interp $args } - namespace eval [namespace current]::${interp} [list namespace ensemble create -command [namespace current]::${interp}::$interp -map {alias {pubsafetcl alias} aliases {pubsafetcl aliases} bgerror {pubsafetcl bgerror} eval PubsafetclEval expose {pubsafetcl expose} hide {pubsafetcl hide} hidden {pubsafetcl hidden} issafe {pubsafetcl issafe} invokehidden {pubsafetcl invokehidden} limit {pubsafetcl limit} marktrusted {pubsafetcl marktrusted} recursionlimit {pubsafetcl recursionlimit} set PubsafetclSet variable PubsafetclSet option PubsafetclSet configure PubsafetclSet fancyeval PubsafetclFancyeval} -prefixes 1] + namespace ensemble create -command [namespace current]::$interp -map {alias {pubsafetcl alias} aliases {pubsafetcl aliases} bgerror {pubsafetcl bgerror} eval PubsafetclEval expose {pubsafetcl expose} hide {pubsafetcl hide} hidden {pubsafetcl hidden} issafe {pubsafetcl issafe} invokehidden {pubsafetcl invokehidden} limit {pubsafetcl limit} marktrusted {pubsafetcl marktrusted} recursionlimit {pubsafetcl recursionlimit} setting PubsafetclSet variable PubsafetclSet option PubsafetclSet configure PubsafetclSet fancyeval PubsafetclFancyeval} -prefixes 1 + namespace export $interp proc PubsafetclSet {name {value {}}} { if {$name eq "extraCommands"} { @@ -90,20 +91,32 @@ } } + proc PubsafetclFancyeval {args} { + variable interp + variable remoteport + set timer [after 3000 [list [namespace parent]::Reset $interp]] + set res [comm send $remoteport [list $interp fancyeval {*}$args]] + after cancel $timer + return $res + } - namespace ensemble create -command [namespace current]::extraCommands -map {add ExtraCommmandsAdd remove ExtraCommandsRemove} + + namespace ensemble create -command [namespace current]::extraCommands -map {add ExtraCommandsAdd remove ExtraCommandsRemove} proc ExtraCommandsAdd {{extraCommands {}}} { variable targetinterp variable extraCommands_current + variable remoteport + variable interp foreach c $extraCommands { # add this command to the interp interp alias $targetinterp $c {} $c } - comm send $remoteport [list ::pubsafetcl::${$interp}::extraCommands add $extraCommands] + comm send $remoteport [list ::pubsafetcl::${interp}::extraCommands add $extraCommands] set extraCommands_current [lsort -unique [concat $extraCommands $extraCommands_current]] } proc ExtraCommandsRemove {{extraCommands {}}} { variable remoteport + variable interp variable extraCommands_current if {$extraCommands == {}} { variable extraCommands_current @@ -111,8 +124,9 @@ } variable targetinterp foreach c $extraCommands { + if {$c ni $extraCommands_current} continue interp invokehidden $targetinterp rename $c {} - set extraCommands_current [lsearch -exact -not $extraCommands_current $c] + set extraCommands_current [lsearch -all -inline -exact -not $extraCommands_current $c] } comm send $remoteport [list ::pubsafetcl::${interp}::extraCommands remove $extraCommands] } @@ -125,20 +139,20 @@ } } - # TODO: think again.. - proc Reset {{interp safetcl} {mode 0}} { + proc Reset2 {{interp safetcl} {mode 0}} { catch { namespace eval [namespace current]::$interp [list variable mode $mode] namespace eval [namespace current]::$interp { if {$mode == 0} { # force the destroy of host process in 3 sec - set timer [after 3000 [list [namespace parent]::Reset $interp 1]] + set timer [after 3000 [list [namespace parent]::Reset2 $interp 1]] # This is a blocking call. If it returns, I think it has succeed - comm send $remoteport exit + # Note: this _always_ returns an error + catch {comm send $remoteport exit} catch {after cancel $timer} - if {$force} { - # the timer has cleaned up - return + if {$mode} { + # the timer has cleaned up the rest, nothing to do now + return 1 } } else { # this is usually the timer @@ -155,6 +169,12 @@ # comm destroy destroys the interp too comm destroy } + namespace delete [namespace current]::$interp } } + + proc Reset {{interp safetcl}} { + Reset2 0 + create $interp + } } \ No newline at end of file Modified: tcldrop/lib/pubsafetclhost.tcl =================================================================== --- tcldrop/lib/pubsafetclhost.tcl 2010-09-08 22:25:20 UTC (rev 397) +++ tcldrop/lib/pubsafetclhost.tcl 2010-09-09 00:52:12 UTC (rev 398) @@ -14,10 +14,10 @@ # # Client access the host who executes the commands... - +source [file join [file dirname [info script]] pubsafetcl.tcl] namespace eval pubsafetclhost { - source [file join [file dirname [info script]] pubsafetcl.tcl] + variable port 12140 @@ -76,7 +76,9 @@ set ids($interp) [comm remoteid] ::pubsafetcl::create $interp {*}$args variable extraCommands_current - set extraCommands($interp) {} + set extraCommands_current($interp) {} + variable extraCommands_info + set extraCommands_info($interp) {} interp alias $comminterp $interp {} ::$interp interp alias $comminterp ::pubsafetcl::${interp}::extraCommands {} [namespace current]::ExtraCommands $interp interp alias $comminterp ::pubsafetcl::${interp}::${interp} {} ::pubsafetcl::${interp}::${interp} @@ -86,16 +88,13 @@ # We have to provide our own Reset. Some people may use that to create an interp proc Reset {{interp safetcl}} { - variable ids - set ids($interp) [comm remoteid] - set res [::pubsafetcl::Reset $interp] - variable extraCommands_current - set extraCommands($interp) {} - interp alias $comminterp $interp {} ::$interp - interp alias $comminterp ::pubsaftcl::${interp}::extraCommands {} [namespace current]::ExtraCommands $interp - set $res + Create $interp } - interp alias $comminterp ::pubsafetcl::Reset + interp alias $comminterp ::pubsafetcl::Reset {} [namespace current]::Reset + ###################################################### + ### DEBUG LINE -- REMOVE IN PRODUCTION ENVIRONMENT ### + ###################################################### + # interp alias $comminterp unknown {} ::eval # I whish I could use a 8.6 feature. But I must not do that: namespace ensemble -parameters @@ -106,12 +105,12 @@ variable ids variable extraCommands_info variable extraCommands_current - switch $command -- { + switch -- $command { add { foreach c $extraCommands { - if {$c in $extraCommands_current($interp)} continue; + if {$c in $extraCommands_current($interp)} {continue} set info [list] - # Avoid the glob style info commands + # Avoid the glob style [info commands] if {[interp invokehidden $interp namespace which $c] ne ""} { lappend info rename interp invokehidden $interp rename $c ::tcl::${c}_orig @@ -127,31 +126,34 @@ lappend info client } dict set extraCommands_info($interp) $c $info + lappend extraCommands_current($interp) $c } - set extraCommands_current($interp) [lsort -unique [concat $extraCommands $extraCommands_current($interp)]] } remove { if {$extraCommands eq ""} { set extraCommands extraCommands_current($interp) } foreach c $extraCommands { - set extraCommands_current($interp) [lsearch -exact -not $extraCommands_current($interp) $c] + if {$c ni $extraCommands_current($interp)} {continue} + set extraCommands_current($interp) [lsearch -all -inline -exact -not $extraCommands_current($interp) $c] set rename 0 - foreach action [dict get $extraCommanfs_info($interp) $c] { + foreach action [dict get $extraCommands_info($interp) $c] { switch -- $action { rename {set rename 1} - hidden {interp hide $interp $c} + hidden {catch {interp hide $interp $c}} current - - client {interp invokehidden $interp rename ::${c} {}} + client {catch {interp invokehidden $interp rename ::${c} {}}} } - if {$rename} { - interp invokehidden $interp rename ::tcl::${c}_orig ::${c} - } } + if {$rename} { + interp invokehidden $interp rename ::tcl::${c}_orig ::${c} + } dict unset extraCommands_info($interp) $c - interp invokehidden $interp rename $c {} } } + default { + return -code error "Args: [list $interp $command $extraCommands]" + } } } } Modified: tcldrop/scripts/pubsafetcl-eggdrop.tcl =================================================================== --- tcldrop/scripts/pubsafetcl-eggdrop.tcl 2010-09-08 22:25:20 UTC (rev 397) +++ tcldrop/scripts/pubsafetcl-eggdrop.tcl 2010-09-09 00:52:12 UTC (rev 398) @@ -71,7 +71,7 @@ ### Begin Script: catch { package forget pubsafetcl::eggdrop } -catch { package forget pubsafetcl } +#catch { package forget pubsafetcl } if {[catch { package require pubsafetcl }] && (![file readable [file join scripts pubsafetcl.tcl]] || [catch { source [file join scripts pubsafetcl.tcl] }]) && (![file readable [file join [file dirname [info script]] pubsafetcl.tcl]] || [catch { source [file join [file dirname [info script]] pubsafetcl.tcl] }]) && (![file readable [file join lib pubsafetcl.tcl]] || [catch { source [file join lib pubsafetcl.tcl] }])} { putlog {ERROR: pubsafetcl-eggdrop.tcl won't load without the pubsafetcl.tcl package.} } namespace eval pubsafetcl::eggdrop { ### Options: @@ -102,15 +102,19 @@ variable UsePubm 1 variable extraCommands - # FEATURE DISABLED. These are extra commands that will be available for people with certain flags.. + # FEATURE ENABLED. These are extra commands that will be available for people with certain flags.. + #array set extraCommands { + # n {time encoding fconfigure pid glob pwd loadmodule loadhelp reloadhelp dellang binds addlangsection checkmodule language addlang relang dellangsection putdcc putact putmsg putnotc rehash} + # mn {dcclist putcmdlog iscompressed utimers timers ignorelist backup savechannels save addchanrec getchan} + # tmn {matchbotattr link getaddr} + # jmn {getdccdir getuploads getfilesendtime} + # omn {gethosts getchanmode getchaninfo memory} + # fomn {handonanychan ispermowner chanlist findnick userlist matchchanattr matchattr chanbans ishalfop banlist exemptlist botisop chanexempts chaninvites invitelist botishalfop channels} + # ptmn {whom botlist bots getdccidle getdccaway} + # + #} array set extraCommands { - n {time encoding fconfigure pid glob pwd loadmodule loadhelp reloadhelp dellang binds addlangsection checkmodule language addlang relang dellangsection putdcc putact putmsg putnotc rehash} - mn {dcclist putcmdlog iscompressed utimers timers ignorelist backup savechannels save addchanrec getchan} - tmn {matchbotattr link getaddr} - jmn {getdccdir getuploads getfilesendtime} - omn {gethosts getchanmode getchaninfo memory} - fomn {handonanychan ispermowner chanlist findnick userlist matchchanattr matchattr chanbans ishalfop banlist exemptlist botisop chanexempts chaninvites invitelist botishalfop channels} - ptmn {whom botlist bots getdccidle getdccaway} + - {duration ctime strftime encrypt decrypt encpass unames md5 sha1 getchanlaston dccused getchanidle myip flushmode queuesize traffic inchain haschanrec wasop getting-users botisvoice modules islinked countusers validchan validuser finduser ischanjuped isban ispermban isexempt ispermexempt isinvite isperminvite isbansticky isexemptsticky isinvitesticky matchban matchexempt matchinvite isignore channame2dname chandname2name isbotnick botonchan isop isvoice onchan nick2hand hand2nick handonchan ischanban ischanexempt ischaninvite getchanjoin onchansplit valididx idx2hand maskhost hand2idx washalfop topic getchanhost isdynamic isbotnetnick getinfo realtime stripcodes matchstr} } # Initialize/reset the safe interpreter: @@ -223,7 +227,7 @@ } elseif {[preferredbot $chan]} { variable extraCommands set commands {} - if {[isop $nick $chan]} { foreach f [array names extraCommands] { if {[matchattr $hand $f|$f $chan]} { set commands [lsort -unique [concat $extraCommands($f) $commands]] } } } + foreach f [array names extraCommands] { if {[matchattr $hand $f|$f $chan]} { set commands [lsort -unique [concat $extraCommands($f) $commands]] } } safetcl setting extraCommands $commands array set evalinfo [list puts {} putloglev {}] array set evalinfo [safetcl fancyeval $arg] This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <joh...@us...> - 2010-09-08 22:25:27
|
Revision: 397 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=397&view=rev Author: johannes-kuhn Date: 2010-09-08 22:25:20 +0000 (Wed, 08 Sep 2010) Log Message: ----------- pubsafetcl.tcl: Fix for a bug I made with the last commit pubsafetclclient.tcl & pubsafetclhost.tcl finally working. Todo: abort pubsafetclhost.tcl after a (short) time if it does not respond. Modified Paths: -------------- tcldrop/lib/pubsafetcl.tcl tcldrop/lib/pubsafetclclient.tcl tcldrop/lib/pubsafetclhost.tcl Modified: tcldrop/lib/pubsafetcl.tcl =================================================================== --- tcldrop/lib/pubsafetcl.tcl 2010-09-08 19:24:04 UTC (rev 396) +++ tcldrop/lib/pubsafetcl.tcl 2010-09-08 22:25:20 UTC (rev 397) @@ -581,7 +581,7 @@ catch { rename ::$interp [namespace current]::${interp}::pubsafetcl } - namespace eval [namespace current]::${interp} [list namespace ensemble create -command [namespace current]::${interp}::$interp -map {alias {pubsafetcl alias} aliases {pubsafetcl aliases} bgerror {pubsafetcl bgerror} eval PubsafetclEval expose {pubsafetcl expose} hide {pubsafetcl hide} hidden {pubsafetcl hidden} issafe {pubsafetcl issafe} invokehidden {pubsafetcl invokehidden} limit {pubsafetcl limit} marktrusted {pubsafetcl marktrusted} recursionlimit {pubsafetcl recursionlimit} set PubsafetclSet variable PubsafetclSet option PubsafetclSet configure PubsafetclSet fancyeval PubsafetclFancyeval} -prefixes 1] + namespace eval [namespace current]::${interp} [list namespace ensemble create -command [namespace current]::${interp}::$interp -map {alias {pubsafetcl alias} aliases {pubsafetcl aliases} bgerror {pubsafetcl bgerror} eval PubsafetclEval expose {pubsafetcl expose} hide {pubsafetcl hide} hidden {pubsafetcl hidden} issafe {pubsafetcl issafe} invokehidden {pubsafetcl invokehidden} limit {pubsafetcl limit} marktrusted {pubsafetcl marktrusted} recursionlimit {pubsafetcl recursionlimit} setting PubsafetclSet variable PubsafetclSet option PubsafetclSet configure PubsafetclSet fancyeval PubsafetclFancyeval} -prefixes 1] proc [namespace current]::${interp}::PubsafetclSet {var {value {}}} { variable $var $value Modified: tcldrop/lib/pubsafetclclient.tcl =================================================================== --- tcldrop/lib/pubsafetclclient.tcl 2010-09-08 19:24:04 UTC (rev 396) +++ tcldrop/lib/pubsafetclclient.tcl 2010-09-08 22:25:20 UTC (rev 397) @@ -48,12 +48,11 @@ namespace eval [namespace current]::$interp [list variable args $args] namespace eval [namespace current]::$interp { namespace path [list [namespace parent]] - # Because we use namespace path, the variables from the parent namespace are used. After that, they are created. variable remoteport [set [namespace parent]::remoteport] variable exec [set [namespace parent]::exec] variable extraCommands_current {} variable tclsh [set [namespace parent]::tclsh] - # we create an interp + # we create an interp for the extra commands variable targetinterp [interp create] # remove all commands interp eval $targetinterp { @@ -75,23 +74,37 @@ # Add aliases ::comm::comm new [namespace current]::comm -listen 1 -interp $targetinterp -local 1 namespace export $interp - proc $interp {args} { + proc pubsafetcl {args} { variable interp variable remoteport - comm send $remoteport $interp $args + comm send $remoteport $interp {*}$args } + namespace eval [namespace current]::${interp} [list namespace ensemble create -command [namespace current]::${interp}::$interp -map {alias {pubsafetcl alias} aliases {pubsafetcl aliases} bgerror {pubsafetcl bgerror} eval PubsafetclEval expose {pubsafetcl expose} hide {pubsafetcl hide} hidden {pubsafetcl hidden} issafe {pubsafetcl issafe} invokehidden {pubsafetcl invokehidden} limit {pubsafetcl limit} marktrusted {pubsafetcl marktrusted} recursionlimit {pubsafetcl recursionlimit} set PubsafetclSet variable PubsafetclSet option PubsafetclSet configure PubsafetclSet fancyeval PubsafetclFancyeval} -prefixes 1] + + proc PubsafetclSet {name {value {}}} { + if {$name eq "extraCommands"} { + extraCommands remove + extraCommands add $value + } else { + variable $name $value + } + } + + namespace ensemble create -command [namespace current]::extraCommands -map {add ExtraCommmandsAdd remove ExtraCommandsRemove} proc ExtraCommandsAdd {{extraCommands {}}} { variable targetinterp + variable extraCommands_current foreach c $extraCommands { # add this command to the interp interp alias $targetinterp $c {} $c } comm send $remoteport [list ::pubsafetcl::${$interp}::extraCommands add $extraCommands] - variable extraCommands_current $extraCommands + set extraCommands_current [lsort -unique [concat $extraCommands $extraCommands_current]] } proc ExtraCommandsRemove {{extraCommands {}}} { variable remoteport + variable extraCommands_current if {$extraCommands == {}} { variable extraCommands_current set extraCommands $extraCommands_current @@ -99,6 +112,7 @@ variable targetinterp foreach c $extraCommands { interp invokehidden $targetinterp rename $c {} + set extraCommands_current [lsearch -exact -not $extraCommands_current $c] } comm send $remoteport [list ::pubsafetcl::${interp}::extraCommands remove $extraCommands] } @@ -106,7 +120,7 @@ # We have now to create the host in background - yeah, a litte bit confusing variable pid [exec $tclsh [file nativename [file join [file dirname [set [namespace parent]::script]] pubsafetclhost.tcl]] &] # Create the interp remote - comm send $remoteport ::pubsafetcl::create $interp $args + comm send $remoteport ::pubsafetcl::create $interp {*}$args return $interp } } @@ -119,8 +133,9 @@ if {$mode == 0} { # force the destroy of host process in 3 sec set timer [after 3000 [list [namespace parent]::Reset $interp 1]] + # This is a blocking call. If it returns, I think it has succeed comm send $remoteport exit - catch {after calcel $timer} + catch {after cancel $timer} if {$force} { # the timer has cleaned up return Modified: tcldrop/lib/pubsafetclhost.tcl =================================================================== --- tcldrop/lib/pubsafetclhost.tcl 2010-09-08 19:24:04 UTC (rev 396) +++ tcldrop/lib/pubsafetclhost.tcl 2010-09-08 22:25:20 UTC (rev 397) @@ -35,7 +35,14 @@ # create an empty interp, used for the public interface (see comm package) variable comminterp [interp create] variable ids + # key: interp, value: the id used by comm for the client array set ids {} + variable extraCommands_current + array set extraCommands_current {} + variable extraCommands_info + # Used to restore the original command + # key: interp, value: dict (key: command, value: (hidden|client|current)) + array set extraCommands_info {} # delete all commands now. note: I don't clear vars, so be careful that no variable substitution is done interp eval $comminterp { @@ -92,25 +99,57 @@ # I whish I could use a 8.6 feature. But I must not do that: namespace ensemble -parameters - # calling this proc with empty extraCommands removes all extra commands + # calling this proc with empty extraCommands and command remove removes all extra commands + # Todo: check if the command already exist or hidden or target interp... + # This replaces pubsafetcls extraCommands proc ExtraCommands {interp command {extraCommands {}}} { - variable ips + variable ids + variable extraCommands_info + variable extraCommands_current switch $command -- { add { foreach c $extraCommands { - interp $interp alias $c {} [namespace current]::comm send $ips($interp) $c + if {$c in $extraCommands_current($interp)} continue; + set info [list] + # Avoid the glob style info commands + if {[interp invokehidden $interp namespace which $c] ne ""} { + lappend info rename + interp invokehidden $interp rename $c ::tcl::${c}_orig + } + if {$c in [interp hidden $interp]} { + interp expose $interp $c + lappend info hidden + } elseif {[namespace which $c] ne ""} { + interp alias $interp $c {} $c + lappend info current + } else { + interp alias $interp $c {} [namespace current]::comm send $ids($interp) $c + lappend info client + } + dict set extraCommands_info($interp) $c $info } - variable extraCommands_current set extraCommands_current($interp) [lsort -unique [concat $extraCommands $extraCommands_current($interp)]] } remove { - variable extraCommands_current if {$extraCommands eq ""} { set extraCommands extraCommands_current($interp) } foreach c $extraCommands { - set extraCommands_current($interp) [lsearch -exact -not $extraCommands_current $c] - interp $interp invokehidden rename $c {} + set extraCommands_current($interp) [lsearch -exact -not $extraCommands_current($interp) $c] + set rename 0 + foreach action [dict get $extraCommanfs_info($interp) $c] { + switch -- $action { + rename {set rename 1} + hidden {interp hide $interp $c} + current - + client {interp invokehidden $interp rename ::${c} {}} + } + if {$rename} { + interp invokehidden $interp rename ::tcl::${c}_orig ::${c} + } + } + dict unset extraCommands_info($interp) $c + interp invokehidden $interp rename $c {} } } } This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <joh...@us...> - 2010-09-08 19:24:10
|
Revision: 396 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=396&view=rev Author: johannes-kuhn Date: 2010-09-08 19:24:04 +0000 (Wed, 08 Sep 2010) Log Message: ----------- Small changes on pubsafetcl.tcl pubsafetclhost.tcl should be finished. Modified Paths: -------------- tcldrop/lib/pubsafetcl.tcl tcldrop/lib/pubsafetclhost.tcl Modified: tcldrop/lib/pubsafetcl.tcl =================================================================== --- tcldrop/lib/pubsafetcl.tcl 2010-07-25 14:24:41 UTC (rev 395) +++ tcldrop/lib/pubsafetcl.tcl 2010-09-08 19:24:04 UTC (rev 396) @@ -31,7 +31,7 @@ # Note: this interp have to be a direct slave, that means not nested. # TODO: we should move the procs out of this proc, so they are not redefined if a new interp is created. Maybe we should create a namespace for that, and hide/alias in a foreach, warning: do not hide file (catch, this throws an error) # TODO: We should discuss if we allow tm. We hide glob... - # TODO: We should protect ::tcl::*, proc ::tcl::info::cmdcount {return 1000000000} makes our command limit useless. + # TODO: We should protect ::tcl::* proc create {{interp {safetcl}} args} { variable script if {[llength $interp] > 1} { @@ -164,7 +164,7 @@ set socket {stdout} } {default} { - set newline {} + set newline "\n" set socket [lindex $args 0] } } @@ -243,6 +243,7 @@ #interp alias $interp lsearch {} [namespace current]::Lsearch $interp # Interp is safe, even in a safe interp. This means invokehidden and marktrusted etc. are not allowed. Also to change the resource limits + # but they can create a new interp with all the hidden commands that we don't want. interp hide $interp interp proc Interp {interp cmd args} { switch -glob -- [string tolower $cmd] { @@ -299,6 +300,9 @@ return -code error "You can't have that many arguments! (Needed: $size Allowed: 400)" } elseif {[set size [string length $body]] > 2048} { return -code error "You can't have a body that large! (Needed: $size Allowed: 2048)" + } elseif {[string match *tcl::* $name]}{ + # TODO: This check is not perfect, as it allows namespace ::tcl {proc foo ...} + return -code error "You can't define a command the ::tcl namespace" } else { interp invokehidden $interp proc $name $arguments "update idletasks ; $body" } @@ -312,7 +316,7 @@ {d*} { foreach ns $args { switch -- [string trim $ns {: }] { - {} { + {} - {tcl} { after idle [list after 0 [list [namespace current]::create $interp]] return "Resetting $interp ..." } @@ -577,7 +581,7 @@ catch { rename ::$interp [namespace current]::${interp}::pubsafetcl } - namespace eval [namespace current]::${interp} [list namespace ensemble create -command [namespace current]::${interp}::$interp -map {alias {pubsafetcl alias} aliases {pubsafetcl aliases} bgerror {pubsafetcl bgerror} eval PubsafetclEval expose {pubsafetcl expose} hide {pubsafetcl hide} hidden {pubsafetcl hidden} issafe {pubsafetcl issafe} invokehidden {pubsafetcl invokehidden} limit {pubsafetcl limit} marktrusted {pubsafetcl marktrusted} recursionlimit {pubsafetcl recursionlimit} setting PubsafetclSet variable PubsafetclSet option PubsafetclSet configure PubsafetclSet fancyeval PubsafetclFancyeval} -prefixes 1] + namespace eval [namespace current]::${interp} [list namespace ensemble create -command [namespace current]::${interp}::$interp -map {alias {pubsafetcl alias} aliases {pubsafetcl aliases} bgerror {pubsafetcl bgerror} eval PubsafetclEval expose {pubsafetcl expose} hide {pubsafetcl hide} hidden {pubsafetcl hidden} issafe {pubsafetcl issafe} invokehidden {pubsafetcl invokehidden} limit {pubsafetcl limit} marktrusted {pubsafetcl marktrusted} recursionlimit {pubsafetcl recursionlimit} set PubsafetclSet variable PubsafetclSet option PubsafetclSet configure PubsafetclSet fancyeval PubsafetclFancyeval} -prefixes 1] proc [namespace current]::${interp}::PubsafetclSet {var {value {}}} { variable $var $value @@ -614,6 +618,7 @@ set out [{*}[pubsafetcl alias reset]] set errlev 0 } + # TODO: rewite map if {$errlev == 1} { set results [string map [list ${namespace}::Proc {proc} ${namespace}::Rename {rename} ${namespace}::While {while} ${namespace}::File {file} ${namespace}::For {for} ${namespace}::Lsearch {lsearch} ${namespace}::Interp {interp} ${namespace}::Info {info} ${namespace}::Timeout {timeout} {::safe::AliasLoad} {load}] $out] } else { set results $out } #extraCommands remove $extraCommands variable Count @@ -632,13 +637,14 @@ if {$errlev == 1} { return -code error [string map [list ${namespace}::Proc {proc} ${namespace}::Rename {rename} ${namespace}::While {while} ${namespace}::File {file} ${namespace}::For {for} ${namespace}::Lsearch {lsearch} ${namespace}::Interp {interp} ${namespace}::Info {info} ${namespace}::Timeout {timeout} {::safe::AliasLoad} {load}] $out] } else { return $out } } - # I guess ResourceReset should remove all the resource limits from the bot. + # I guess ResourceReset should remove all the resource limits from the interp. proc [namespace current]::${interp}::ResourceLimit {} { # 1000 should be high enogh, my master interp has this value pubsafetcl recursionlimit 1000 pubsafetcl limit commands -value {} pubsafetcl limit time -seconds {} } + interp alias {} [namespace current]::${interp}::ResourceReset {} [namespace current]::${interp}::ResourceLimit # Add traces for each initial command that deny rename and deletion of them proc [namespace current]::${interp}::AddTraces args { Modified: tcldrop/lib/pubsafetclhost.tcl =================================================================== --- tcldrop/lib/pubsafetclhost.tcl 2010-07-25 14:24:41 UTC (rev 395) +++ tcldrop/lib/pubsafetclhost.tcl 2010-09-08 19:24:04 UTC (rev 396) @@ -13,7 +13,8 @@ # this is the entry point for the pubsafetcl process. It is used by pubsafetclclient.tcl # -# TODO: Add support for extraCommands +# Client access the host who executes the commands... + namespace eval pubsafetclhost { source [file join [file dirname [info script]] pubsafetcl.tcl] @@ -31,10 +32,12 @@ package provide pubsafetclhost $version variable rcsid {$Id$} + # create an empty interp, used for the public interface (see comm package) variable comminterp [interp create] variable ids array set ids {} + # delete all commands now. note: I don't clear vars, so be careful that no variable substitution is done interp eval $comminterp { foreach ns [namespace children] { # we don't delete ::tcl here, there are some internal commands that might be required @@ -43,26 +46,37 @@ foreach cmd [info commands] { if {$cmd ni {namespace rename if}} {rename $cmd {}} } - namespace forget ::tcl + namespace delete ::tcl rename namespace {} rename if {} # we don't delete rename, this is required later } interp hide $comminterp rename + # We only allow local connections ::comm::comm new [namespace current]::comm -local 1 -port $port -listen 1 -silent 1 -interp $comminterp + + proc Exit args { comm destroy + set forever 1 exit 0 } interp alias $comminterp exit {} [namespace current]::Exit + proc Create {{interp safetcl} args} { variable ids + variable comminterp set ids($interp) [comm remoteid] - ::pubsafetcl::create $interp $args + ::pubsafetcl::create $interp {*}$args + variable extraCommands_current + set extraCommands($interp) {} interp alias $comminterp $interp {} ::$interp + interp alias $comminterp ::pubsafetcl::${interp}::extraCommands {} [namespace current]::ExtraCommands $interp + interp alias $comminterp ::pubsafetcl::${interp}::${interp} {} ::pubsafetcl::${interp}::${interp} return $interp } interp alias $comminterp ::pubsafetcl::create {} [namespace current]::Create + # We have to provide our own Reset. Some people may use that to create an interp proc Reset {{interp safetcl}} { variable ids @@ -75,7 +89,10 @@ set $res } interp alias $comminterp ::pubsafetcl::Reset + # I whish I could use a 8.6 feature. But I must not do that: namespace ensemble -parameters + + # calling this proc with empty extraCommands removes all extra commands proc ExtraCommands {interp command {extraCommands {}}} { variable ips switch $command -- { @@ -92,9 +109,12 @@ set extraCommands extraCommands_current($interp) } foreach c $extraCommands { - + set extraCommands_current($interp) [lsearch -exact -not $extraCommands_current $c] + interp $interp invokehidden rename $c {} } } } } -} \ No newline at end of file +} + +vwait forever \ No newline at end of file This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pi...@us...> - 2010-07-25 14:24:48
|
Revision: 395 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=395&view=rev Author: pixelz Date: 2010-07-25 14:24:41 +0000 (Sun, 25 Jul 2010) Log Message: ----------- Move annoying dcc::irc debug messages to the level 1 log instead of the standard debug log. Modified Paths: -------------- tcldrop/modules/tcldrop/dcc/irc-1.tm Modified: tcldrop/modules/tcldrop/dcc/irc-1.tm =================================================================== --- tcldrop/modules/tcldrop/dcc/irc-1.tm 2010-04-25 13:46:29 UTC (rev 394) +++ tcldrop/modules/tcldrop/dcc/irc-1.tm 2010-07-25 14:24:41 UTC (rev 395) @@ -76,7 +76,7 @@ {CHAT} { if {![callircparty $idx [set command [string toupper [lindex [set sline [split [string trim $line]]] 0]]] [join [lrange $sline 1 end]]]} { PutRAW $idx "421 [getircparty user $idx nick] $command :Unknown command" - putdebuglog "$idx: $line" + putloglev 1 * "$idx: $line" } return 0 } @@ -86,7 +86,7 @@ # ^ These are the only commands available until they send the PASS/NICK/USER commands. ^ if {![callircparty $idx $command [join [lrange $sline 1 end]]]} { PutRAW $idx "421 [getircparty user $idx nick] $command :Unknown command" - putdebuglog "$idx: $line" + putloglev 1 * "$idx: $line" return 1 } elseif {[ircparty registered $idx]} { idxinfo $idx state CHAT other {chat} timestamp [clock seconds] @@ -96,7 +96,7 @@ } {default} { PutRAW $idx "451 [getircparty user $idx nick] :You have not registered" - putdebuglog "$idx: $line" + putloglev 1 * "$idx: $line" return 0 } } @@ -299,11 +299,11 @@ proc ::tcldrop::dcc::irc::putircparty {args} { array set putinfo [list -excludeidx {} -chan {} -text [lindex $args end] -flags {}] array set putinfo [lrange $args 0 end-1] - #putdebuglog "::tcldrop::dcc::irc::putircparty putinfo [array get putinfo]" + #putloglev 1 * "::tcldrop::dcc::irc::putircparty putinfo [array get putinfo]" if {$putinfo(-chan) != {}} { foreach i [ircparty chanlist $putinfo(-chan)] { if {$i != $putinfo(-excludeidx) && [valididx $i] && [matchattr [idx2hand $i] $putinfo(-flags) $putinfo(-chan)]} { - putdebuglog "Putidx: $i $putinfo(-text)" + putloglev 1 * "Putidx: $i $putinfo(-text)" Putidx $i $putinfo(-text) } } @@ -373,7 +373,7 @@ } proc ::tcldrop::dcc::irc::ircparty_NICK {idx command arg} { - putdebuglog "IN ::tcldrop::dcc::irc::NICK $idx $command $arg" + putloglev 1 * "IN ::tcldrop::dcc::irc::NICK $idx $command $arg" set nick [string trimleft $arg {: }] if {[set handle [idx2hand $idx]] == {*}} { set handle "${nick}" } setircparty user $idx nick $nick nickname [set nickname "${handle}@${::botnet-nick}:$idx"] @@ -382,7 +382,7 @@ } proc ::tcldrop::dcc::irc::ircparty_USER {idx command arg} { - putdebuglog "IN ::tcldrop::dcc::irc::USER $idx $command $arg" + putloglev 1 * "IN ::tcldrop::dcc::irc::USER $idx $command $arg" if {[set username [string trim [lindex [set sarg [split $arg]] 0]]] == {}} { return 0 } else { @@ -432,7 +432,7 @@ #\xA0:irc.choopa.net\xA0324\xA0Tcldrop\xA0#Test\xA0+tnl\xA02147483647 # :irc.choopa.net\xA0329\xA0Tcldrop\xA0#Test\xA0985416044 proc ::tcldrop::dcc::irc::ircparty_MODE {idx command arg} { - putdebuglog "in ::tcldrop::dcc::irc::ircparty_MODE $idx $command $arg" + putloglev 1 * "in ::tcldrop::dcc::irc::ircparty_MODE $idx $command $arg" if {[llength [set sarg [split $arg]]] == 1 && [validchan $arg]} { puthelp "$command $arg" RAWCapture {324 329} $idx @@ -444,7 +444,7 @@ # :irc.choopa.net\xA0302\xA0Tcldrop\xA0:Tcldrop=+Tcldrop@2001:5c0:84dc:7:: proc ::tcldrop::dcc::irc::ircparty_USERHOST {idx command arg} { - putdebuglog "in ::tcldrop::dcc::irc::ircparty_USERHOST $idx $command $arg" + putloglev 1 * "in ::tcldrop::dcc::irc::ircparty_USERHOST $idx $command $arg" array set userinfo [getircparty user $idx] switch -- $arg { $userinfo(nickname) { @@ -461,12 +461,12 @@ } proc ::tcldrop::dcc::irc::ircparty_VERSION {idx command arg} { - putdebuglog "in ::tcldrop::dcc::irc::ircparty_VERSION $idx $command $arg" + putloglev 1 * "in ::tcldrop::dcc::irc::ircparty_VERSION $idx $command $arg" return 1 } proc ::tcldrop::dcc::irc::ircparty_ISON {idx command arg} { - #putdebuglog "in ::tcldrop::dcc::irc::ircparty_ISON $idx $command $arg" + #putloglev 1 * "in ::tcldrop::dcc::irc::ircparty_ISON $idx $command $arg" return 1 } @@ -474,7 +474,7 @@ # Allow anybody to join any partyline channel. # Only allow +vofmn to join already valid channels on irc. # Only allow global +mn to join invalid channels. (they'll be [channel add]'d on JOIN) - putdebuglog "ircparty_JOIN $idx $command $arg" + putloglev 1 * "ircparty_JOIN $idx $command $arg" array set userinfo [getircparty user $idx] array set idxinfo [idxinfo $idx] foreach chankey [split $arg ,] { @@ -516,7 +516,7 @@ # FixMe: Split this into multiple 353's if when the line gets too long: PutRAW $idx "353 $userinfo(nickname) $chanflag $chan :[join $nicklist]" } - putdebuglog "ircparty names: [join [ircparty chanlist $chan nickname]]" + putloglev 1 * "ircparty names: [join [ircparty chanlist $chan nickname]]" PutRAW $idx "353 $userinfo(nickname) = $chan :[join [ircparty chanlist $chan nickname]]" PutRAW $idx "366 $userinfo(nickname) $chan :End of /NAMES list." } This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pi...@us...> - 2010-04-25 13:46:35
|
Revision: 394 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=394&view=rev Author: pixelz Date: 2010-04-25 13:46:29 +0000 (Sun, 25 Apr 2010) Log Message: ----------- Fixed some minor problems with the Sysuptime proc. It won't try to read file mdate of /proc unless the system is Linux. This should prevent false information being reported on *bsd systems with a /proc dir. Modified Paths: -------------- tcldrop/modules/tcldrop/core-1.tm Modified: tcldrop/modules/tcldrop/core-1.tm =================================================================== --- tcldrop/modules/tcldrop/core-1.tm 2010-04-22 19:34:54 UTC (rev 393) +++ tcldrop/modules/tcldrop/core-1.tm 2010-04-25 13:46:29 UTC (rev 394) @@ -1931,7 +1931,7 @@ # Detects if critcl is present and creates Sysup procs for different systems proc ::tcldrop::core::CreateSysupProc {} { - if {![info exists ::tcl_platform(os)] || ![catch { package require critcl }]} { return 0 } + if {![info exists ::tcl_platform(os)] || [catch { package require critcl }]} { return 0 } switch -- $::tcl_platform(os) { {Linux} { ::critcl::ccode { @@ -2017,9 +2017,9 @@ return [Sysup] # Read file modified time of /proc. This will likely be the system uptime on all/most Linux systems. # Fails on cygwin for whatever reason. /proc/uptime should work fine on Cygwin though. - } elseif {[file exists /proc] && ![catch {file mtime /proc} sysup]} { + } elseif {[info exists ::tcl_platform(os)] && $::tcl_platform(os) eq {Linux} && [file exists /proc] && ![catch {file mtime /proc} sysup]} { return $sysup - # Exec the uptime command and parse it. This is not very reliable and shoud be used as the last option. + # Exec the uptime command and parse it. This is not very reliable and should be used as the last option. } elseif {![catch {exec uptime} Sysup]} { # FixMe: find out what the output is if uptime < 1 min # Linux: 23:30:24 up 132 days, 3:28, 2 users, load average: 0.00, 0.00, 0.00 This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pi...@us...> - 2010-04-22 19:35:01
|
Revision: 393 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=393&view=rev Author: pixelz Date: 2010-04-22 19:34:54 +0000 (Thu, 22 Apr 2010) Log Message: ----------- Set id & executable props Property Changed: ---------------- tcldrop/scripts/generate-msgcat.tcl Property changes on: tcldrop/scripts/generate-msgcat.tcl ___________________________________________________________________ Added: svn:executable + * Added: svn:keywords + Id This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |
From: <pi...@us...> - 2010-04-22 19:33:19
|
Revision: 392 http://tcldrop.svn.sourceforge.net/tcldrop/?rev=392&view=rev Author: pixelz Date: 2010-04-22 19:33:13 +0000 (Thu, 22 Apr 2010) Log Message: ----------- First draft of a script that extracts message catalog strings from the source. Added Paths: ----------- tcldrop/scripts/generate-msgcat.tcl Added: tcldrop/scripts/generate-msgcat.tcl =================================================================== --- tcldrop/scripts/generate-msgcat.tcl (rev 0) +++ tcldrop/scripts/generate-msgcat.tcl 2010-04-22 19:33:13 UTC (rev 392) @@ -0,0 +1,124 @@ +#!/usr/bin/env tclsh + +package require Tcl 8.5 + +encoding system {utf-8} + +# Extracts message from a source file. +# Returns an array where the element name is the message string +# and the value is a list of line numbers where the string appears +proc GetMsgStrings {file} { + if {![file exists $file]} { + return -code error "No such file: $file" + } else { + set lineNum 0 + array set messages {} + + set fd [open $file r] + # iterate through the file and grab message strings + while {[gets $fd line] >= 0} { + incr lineNum + if {[set result [regexp -all -inline -- {\[mc(?:\_handle)?(?: \$\S+)? \{([^\}]+)} $line]] ne {}} { + foreach {- MsgString} $result { + lappend messages($MsgString) $lineNum + } + } + } + close $fd + } + return [array get messages] +} + +# Slightly modified recursive glob proc from http://wiki.tcl.tk/1474 +# FixMe: this kind of turned into a mess.. +proc globRec {{includeDirs {modules lib}} {baseDir .} {filespec {*.tcl *.tm}} {types {b c f l p s}} {iteration 0}} { + incr iteration + foreach dir $includeDirs { + if {[string match "./$dir*" $baseDir] || $iteration == 1} { set continue 1 } + } + if {![info exists continue]} { return } + set files [glob -nocomplain -types $types -dir $baseDir -- {*}$filespec] + foreach item [glob -nocomplain -types {d} -dir $baseDir -- *] { + set files [concat $files [globRec $includeDirs $item $filespec $types $iteration]] + } + set filelist {} + foreach x $files { + while {[string range $x 0 1]=="./"} { + regsub ./ $x "" x + } + lappend filelist "./${x}" + } + return $filelist +} + +# FixMe: write this +# take a file a an argument +# return the name of the module that the file belongs in +# Examples: +# ./modules/tcldrop/console/dcc-1.tm == console +# ./modules/tcldrop/server-1.tm == server +# ./modules/tcldrop/core/conn-1.tm == core +proc FileToModuleName {file} { + +} + +# generate .msg files for the Tcldrop source +# FixMe: don't just generate one big file +proc GenerateMsgCatalog {} { + set pwd [pwd] + cd .. + set fd [open "./language/test.msg" w] + fconfigure $fd -translation lf -encoding {utf-8} + puts $fd "# test.msg - automatically generated by generate-msgcat.tcl on [clock format [clock seconds] -timezone UTC]\n" + foreach file [globRec] { + array set messages [GetMsgStrings $file] + foreach msg [array names messages] { + foreach lineNum $messages($msg) { + puts $fd "#: $file:$lineNum" + } + puts $fd "msgid \{${msg}\}" + puts $fd "msgstr \{${msg}\}\n" + + } + } + close $fd + cd $pwd +} + + +proc chef {args} { + set subs [list {a([nu])} {u\1}\ + {A([nu])} {U\1}\ + {a\Y} e\ + {A\Y} E\ + {en\y} ee\ + {\Yew} oo\ + {\Ye\y} e-a\ + {\ye} i\ + {\yE} I\ + {\Yf} ff\ + {\Yir} ur\ + {(\w+?)i(\w+?)$} {\1ee\2}\ + {\Yow} oo\ + {\yo} oo\ + {\yO} Oo\ + {^the$} zee\ + {^The$} Zee\ + {th\y} t\ + {\Ytion} shun\ + {\Yu} {oo}\ + {\YU} {Oo}\ + v f\ + V F\ + w w\ + W W\ + {([a-z])[.]} {\1. Bork Bork Bork!}] + foreach word $args { + foreach {exp subSpec} $subs { + set word [regsub -all -- $exp $word $subSpec] +# puts "$exp || $subSpec -> $word" + } + lappend retval $word + } + return [join $retval] +} This was sent by the SourceForge.net collaborative development platform, the world's largest Open Source development site. |