commit f50e82ce9d642fe364b50a0531e0f592c0c066b4
parent 14063471f9749f858fd60267fca8fcc1f8aa8226
Author: Ellenor Malik <ellenor@umbrellix.net>
Date: Wed, 9 Oct 2019 16:50:35 -0700
General housecleaning
* explained modules/ disaster
* rename 'eggcom' to 'convenience', reflecting its function
both historically and in the modern era of TclServ
* change 2003-ts6.tcl to use the (currently unimplemented/stubbed)
binds based logging interface
* add to putcmdlog that it will always call the dash binds as well
as the current context log binds. this is intended for if a module
wants to send the log entries to other networks, or to files.
dash binds need to accept 4 arguments for that.
Diffstat:
7 files changed, 980 insertions(+), 829 deletions(-)
diff --git a/core/0000-callbacks.tcl b/core/0000-callbacks.tcl
@@ -74,7 +74,11 @@ proc firellmbind {sock type client comd args} {
}
proc putloglev {lev ch msg} {
# punt
- firellmbind [curctx sock] log - [format "%s %s" $ch $lev] $lev $ch $msg
- firellbind [curctx sock] logall - - $lev $ch $msg
+ foreach level [split $lev {}] {
+ firellmbind [curctx sock] log - [format "%s %s" $ch $level] $level $ch $msg
+ firellbind [curctx sock] logall - - $level $ch $msg
+ firellmbind - log - [format "%s %s" $ch $level] [curctx net] $level $ch $msg
+ firellbind - logall - - [curctx net] $level $ch $msg
+ }
}
proc putlog {msg} {putloglev o * $msg}
diff --git a/core/0999-conn.tcl b/core/0999-conn.tcl
@@ -1,6 +1,7 @@
package require tls
# just to have sanity here. don't want a {} dict or a bum array
+# this is for the logging algorithm to work once implemented, too, among other important things
set ::netname(-) -
proc connect {addr port script} {
diff --git a/core/2003-ts6.tcl b/core/2003-ts6.tcl
@@ -3,7 +3,7 @@
namespace eval ts6 {
-proc putcmdlog {args} {}
+#proc putcmdlog {args} {}
proc ::ts6::b64e {numb} {
set b64 [split "ABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789" {}]
@@ -115,7 +115,7 @@ append sid [::ts6::b64e $::sid($sck)]
proc ::ts6::metadata {sck targ direction type {msg ""}} {
set sid [string repeat "0" [expr {3-[string length [::ts6::b64e $::sid($sck)]]}]]
append sid [::ts6::b64e $::sid($sck)]
- if {[string toupper $direction] != "ADD" && [string toupper $direction] != "DELETE"} {putcmdlog "failed METADATA attempt (invalid arguments)";return} ;#no that didn't work
+ if {[string toupper $direction] != "ADD" && [string toupper $direction] != "DELETE"} {putloglev d * "failed METADATA attempt (invalid arguments)";return} ;#no that didn't work
if {[string toupper $direction] == "ADD"} {
tnda set "metadata/$::netname($sck)/$targ/[ndaenc $type]" $msg
putl $sck [format ":%s ENCAP * METADATA %s %s %s :%s" $sid [string toupper $direction] $targ [string toupper $type] $msg]
@@ -302,7 +302,7 @@ proc ::ts6::irc-main {sck} {
firellbind $sck raw - [lindex $comd $one] $sourceof [lindex $comd $one] [join [lrange $comd $two end] " "]
set erreno [catch {
switch -nocase -- [lindex $comd $one] {
- "479" {putcmdlog $payload}
+ "479" {putloglev d * $payload}
"PASS" {
# putquick "PRIVMSG #services :$line"
puts stdout "we have a winner! $one"
@@ -337,7 +337,7 @@ proc ::ts6::irc-main {sck} {
# is it us?
if {$failedserver == $ssid} {
#yes, it's us.
- putcmdlog "We're dead, folks."
+ putloglev d * "We're dead, folks."
firellbind $sck evnt "-" "ts6.dead" $::netname($sck)
firellbind $sck evnt "-" "dead" $::netname($sck)
firellbind - evnt "-" "dead" $sck $::netname($sck)
@@ -586,7 +586,7 @@ proc ::ts6::irc-main {sck} {
# if {"un"==$state} {append un $c}
# if {"uo"==$state} {append uo $c}
# }
- putcmdlog [format "JOIN %s by nicknumber %s (nick %s, modes %s)" [ndadec $chan] $nick [tnda get "nick/$::netname($sck)/$un"] $uo]
+ putloglev j [ndadec $chan] [format "JOIN %s by nicknumber %s (nick %s, modes %s)" [ndadec $chan] $nick [tnda get "nick/$::netname($sck)/$un"] $uo]
# firellbind $sck join "-" "-" [lindex $comd 3] $un $::netname($sck)
firellmbind $sck join - [format "%s %s!%s@%s" [lindex $comd 3] [% uid2nick $un] [% uid2ident $un] [% uid2host $un]] $un [lindex $comd 3]
tnda set "userchan/$::netname($sck)/$un/$chan" 1
@@ -699,7 +699,7 @@ proc ::ts6::irc-main {sck} {
set ocomd [lrange $comd 1 end]
set on [lindex $comd 0]
set comd [list [::ts6::nick2uid $::netname($sck) $on] {*}$ocomd]
- putcmdlog [format "Uh-oh, netsplit! %s -> %s has split" $on [::ts6::nick2uid $::netname($sck) $on]]
+ putloglev k * [format "Uh-oh, netsplit! %s -> %s has split" $on [::ts6::nick2uid $::netname($sck) $on]]
}
foreach {chan _} [tnda get "userchan/$::netname($sck)/[lindex $comd 0]"] {
firellbind $sck part "-" "-" [ndadec $chan] [lindex $comd 0] $::netname($sck)
@@ -739,7 +739,7 @@ proc ::ts6::irc-main {sck} {
}
"ERROR" {
- putcmdlog "Recv'd an ERROR $payload from $::netname($sck)"
+ putloglev s * "Recv'd an ERROR $payload from $::netname($sck)"
}
"WHOIS" {
@@ -873,7 +873,7 @@ proc ::ts6::checkop {f t m p} {
set mc [string index $m 1]
puts stdout [format ":%s MODE %s %s %s" $f $t $m $p]
if {[tnda get "netinfo/$n/pfxchar/$mc"]==""} {::ts6::handlemode $f $t $m $p;return}
-putcmdlog "up $mc $f $t $p $n"
+putloglev d * "up $mc $f $t $p $n"
set chan [string map {/ [} [::base64::encode [string tolower $t]]]
tnda set "channels/$n/$chan/status/$p" [format {%s%s} [string map [list $mc ""] [tnda get "channels/$n/$chan/status/$p"]] $mc]
}
@@ -883,7 +883,7 @@ proc ::ts6::checkdeop {f t m p} {
set mc [string index $m 1]
puts stdout [format ":%s MODE %s %s %s" $f $t $m $p]
if {[tnda get "netinfo/$n/pfxchar/$mc"]==""} {::ts6::handlemode $f $t $m $p;return}
-putcmdlog "down $mc $f $t $p $n"
+putloglev d * "down $mc $f $t $p $n"
set chan [string map {/ [} [::base64::encode [string tolower $t]]]
tnda set "channels/$n/$chan/status/$p" [string map [list $mc ""] [tnda get "channels/$n/$chan/status/$p"]]
}
diff --git a/core/4000-convenience.tcl b/core/4000-convenience.tcl
@@ -0,0 +1,821 @@
+#source chanserv.conf
+
+#more thanks to fireegl
+# XXX THIS PORTION BLOCKS NONGPL RELEASE
+
+proc SetUdefDefaults {{name {*}}} {
+ global UdefDefaults
+ foreach udef [array names UdefDefaults $name] {
+ #dict for {key value} $::database(channels) {
+ # if {![dict exists $value $udef]} {
+ # dbase set eggcompat [curctx net] channels $key $value $udef $UdefDefaults($udef)
+ # }
+ #}
+ foreach channel [channels] {
+ if {[catch { channel get $channel $udef }]} {
+ # channel set $channel $udef $UdefDefaults($udef)
+ dbase set eggcompat [curctx net] channels [string toupper $channel] $udef $UdefDefaults($udef)
+ }
+ }
+ }
+}
+
+# Defines a new udef:
+proc setudef {type name {default {}}} {
+ # Store the default for this udef:
+ global UdefDefaults
+ set name [string tolower $name]
+ switch -- $type {
+ {flag} { set UdefDefaults($name) [string is true -strict $default] }
+ {int} { if {$default != {}} { set UdefDefaults($name) $default } else { set UdefDefaults($name) 0 } }
+ {str} - {list} { set UdefDefaults($name) $default }
+ {default} { return -code error "[mc {Invalid udef type: %s} $type]" }
+ }
+ # Store the udef itself:
+ global Udefs
+ set Udefs($name) $type
+ # "UDEF: $name (${type}) defined. Default: $UdefDefaults($name)"
+ # Apply the default to all channels that don't already have it set:
+ 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 getudefs {{type {}}} {
+ # Note/FixMe: Eggdrop probably errors if $type is invalid.
+ # This is not a compatibility problem though
+ global 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
+# Module: channels
+proc renudef {type oldname newname} {
+ global Udefs
+ if {[info exists Udefs($newname)]} {return -1}
+ if {[info exists Udefs($oldname)] && [string equal -nocase $Udefs($oldname) $type]} {
+ dict for {key value} $::database(channels) {
+ if {[dict exists $value $oldname]} {
+ dbase set eggcompat [curctx net] channels $key $newname [dbase get eggcompat [curctx net] channels $key $oldname]
+ dbase unset eggcompat [curctx net] channels $key $oldname
+ }
+ }
+ set Udefs($newname) $Udefs($oldname)
+ unset Udefs($oldname)
+ global UdefDefaults
+ set UdefDefaults($newname) $UdefDefaults($oldname)
+ unset Udefs($oldname)
+ return 1
+ }
+ return 0
+}
+
+# deludef <flag/int> <name>
+# Description: deletes a user defined channel flag or integer setting.
+# Returns: nothing
+# Module: channels
+# Proc written by Papillon@EFNet.
+# FixMe: This proc is untested and unmodified from what he sent me. Looks broken. =P
+proc deludef {type name} {
+ global Udefs
+ if {[info exists Udefs($oldname)] && [string equal -nocase $Udefs($oldname) $type]} {
+ dict for {key value} $::database(channels) { if {[dict exists $value $oldname]} { dbase unset eggcompat [curctx net] channels $key $oldname } }
+ unset Udefs($oldname)
+ global UdefDefaults
+ unset Udefs($oldname)
+ return 1
+ }
+ return 0
+}
+
+# Returns 1 if it's a valid (existing) name for a udef, or 0 if it's not:
+proc validudef {name} {
+ global Udefs
+ info exists Udefs($name)
+}
+
+
+proc protectopcheck {mc f t p} {
+ if {"o"==$mc && ![channel get $t protectop]} {return}
+ if {"h"==$mc && ![channel get $t protecthalfop]} {return}
+ if {"v"==$mc && ![channel get $t protectvoice]} {return}
+ switch -- $mc {
+ "o" {
+ if {[matchattr [tnda get "login/[curctx net]/$p"] omn|omn $t]} {
+ [curctx proto] putmode [curctx sock] 77 $t +$mc "$p" [tnda get "channels/[curctx net]/[ndaenc $t]/ts"]
+ }
+ }
+ "h" {
+ if {[matchattr [tnda get "login/[curctx net]/$p"] l|l $t]} {
+ [curctx proto] putmode [curctx sock] 77 $t +$mc "$p" [tnda get "channels/[curctx net]/[ndaenc $t]/ts"]
+ }
+ }
+ "v" {
+ if {[matchattr [tnda get "login/[curctx net]/$p"] v|v $t]} {
+ [curctx proto] putmode [curctx sock] 77 $t +$mc "$p" [tnda get "channels/[curctx net]/[ndaenc $t]/ts"]
+ }
+ }
+ }
+}
+
+proc finduserbyid {n} {
+ tnda get "login/[curctx net]/$f"
+}
+
+# XXX obsolete; safe to remove?
+proc autoopcheck {c f} {
+ set globe 0
+ if {[channel get $c operit]} {set globe 1}
+ if {[channel get $c autoop]} {set auto nmo} {set auto ""}
+ if {[channel get $c autohalfop]} {append auto l}
+ if {[channel get $c autovoice]} {append auto v}
+ tcs:opcheck $c $f $globe $auto
+}
+
+proc unixtime {} {
+ return [clock format [clock seconds] -format %s]
+}
+
+# XXX obsolete; safe to remove?
+proc tcs:opcheck {c f {globe 0} {auto nmolv}} {
+# puts stdout "$c $f"
+ if {[matchattr [tnda get "login/[curctx net]/$f"] |k $c]} {
+ # obviously optimised for charybdis... ???
+ [curctx proto] putmode [curctx sock] 77 $c +b "*![tnda get "ident/[curctx net]/$f"]@[tnda get "vhost/[curctx net]/$f"]" [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
+ [curctx proto] kick [curctx sock] 77 $c $f "Autokicked (+k attribute)"
+ return
+ }
+ if {[matchattr [tnda get "login/[curctx net]/$f"] n|] && $globe} {
+ [curctx proto] putmode [curctx sock] 77 $c +[tnda get "pfx/owner"] $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
+ return
+ }
+ if {[matchattr [tnda get "login/[curctx net]/$f"] |n $c] && ([string first "o" $auto] != -1)} {
+ [curctx proto] putmode [curctx sock] 77 $c +[tnda get "pfx/owner"] $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
+ return
+ }
+
+ if {[matchattr [tnda get "login/[curctx net]/$f"] m|] && $globe} {
+ [curctx proto] putmode [curctx sock] 77 $c +[tnda get "pfx/protect"] $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
+ return
+ }
+ if {[matchattr [tnda get "login/[curctx net]/$f"] |m $c] && ([string first "o" $auto] != -1)} {
+ [curctx proto] putmode [curctx sock] 77 $c +[tnda get "pfx/protect"] $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
+ return
+ }
+
+ if {[matchattr [tnda get "login/[curctx net]/$f"] a|]} {
+ [curctx proto] putmode [curctx sock] 77 $c +o $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
+ return
+ }
+ if {[matchattr [tnda get "login/[curctx net]/$f"] o|] && $globe} {
+ [curctx proto] putmode [curctx sock] 77 $c +o $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
+ return
+ }
+ if {[matchattr [tnda get "login/[curctx net]/$f"] |o $c] && ([string first "o" $auto] != -1)} {
+ [curctx proto] putmode [curctx sock] 77 $c +o $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
+ return
+ }
+ if {[matchattr [tnda get "login/[curctx net]/$f"] l|] && $globe} {
+ [curctx proto] putmode [curctx sock] 77 $c +[tnda get "pfx/halfop"] $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
+ return
+ }
+ if {[matchattr [tnda get "login/[curctx net]/$f"] |l $c] && ([string first "h" $auto] != -1)} {
+ [curctx proto] putmode [curctx sock] 77 $c +[tnda get "pfx/halfop"] $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
+ return
+ }
+ if {[matchattr [tnda get "login/[curctx net]/$f"] v|] && $globe} {
+ [curctx proto] putmode [curctx sock] 77 $c +v $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
+ return
+ }
+ if {[matchattr [tnda get "login/[curctx net]/$f"] |v $c] && ([string first "v" $auto] != -1)} {
+ [curctx proto] putmode [curctx sock] 77 $c +v $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
+ return
+ }
+}
+
+# XXX nobody calls me anymore; obsolete. safe to remove?
+proc bitchopcheck {mc ftp} {
+ set f [lindex $ftp 0]
+ set t [lindex $ftp 1]
+ set p [lindex $ftp 2]
+ puts stdout "$ftp"
+ if {[tnda get "pfx/owner"]==$mc && ![channel get $t bitch]} {return} {if {[tnda get "pfx/owner"] != q} {set mc q}}
+ if {[tnda get "pfx/protect"]==$mc && ![channel get $t bitch]} {return} {if {[tnda get "pfx/protect"] != a} {set mc a}}
+ if {"o"==$mc && ![channel get $t bitch]} {return}
+ if {"h"==$mc && ![channel get $t halfbitch]} {return}
+ if {"v"==$mc && ![channel get $t voicebitch]} {return}
+ switch -glob -- $mc {
+ "q" {
+ if {![matchattr [tnda get "login/[curctx net]/$p"] n|n $t]} {
+ puts stdout "M $t -$mc $p [nda get "regchan/[ndaenc $t]/ts"]"
+ [curctx proto] putmode [curctx sock] 77 $t "-$mc" "$p" [nda get "regchan/[ndaenc $t]/ts"]
+ }
+ }
+ "a" {
+ if {![matchattr [tnda get "login/[curctx net]/$p"] mn|mn $t]} {
+ puts stdout "M $t -$mc $p [nda get "regchan/[ndaenc $t]/ts"]"
+ [curctx proto] putmode [curctx sock] 77 $t "-$mc" "$p" [nda get "regchan/[ndaenc $t]/ts"]
+ }
+ }
+ "o" {
+ if {![matchattr [tnda get "login/[curctx net]/$p"] aomn|omn $t]} {
+ puts stdout "M $t -$mc $p [nda get "regchan/[ndaenc $t]/ts"]"
+ [curctx proto] putmode [curctx sock] 77 $t "-$mc" "$p" [nda get "regchan/[ndaenc $t]/ts"]
+ }
+ }
+ "h" {
+ if {![matchattr [tnda get "login/[curctx net]/$p"] l|l $t]} {
+ puts stdout "M $t -$mc $p [nda get "regchan/[ndaenc $t]/ts"]"
+ [curctx proto] putmode [curctx sock] 77 $t "-$mc" "$p" [nda get "regchan/[ndaenc $t]/ts"]
+ }
+ }
+ "v" {
+ if {![matchattr [tnda get "login/[curctx net]/$p"] v|v $t]} {
+ puts stdout "M $t -$mc $p [nda get "regchan/[ndaenc $t]/ts"]"
+ [curctx proto] putmode [curctx sock] 77 $t "-$mc" "$p" [nda get "regchan/[ndaenc $t]/ts"]
+ }
+ }
+ }
+}
+
+#proc every {milliseconds script} {$script; after $milliseconds [every $milliseconds $script]}
+#every 1000 [list firellmbind - time [clock format [clock seconds] -format "%M %H %d %m %Y"]]
+proc utimer {seconds tcl-command} {after [expr $seconds * 1000] ${tcl-command}}
+proc timer {minutes tcl-command} {after [expr $minutes * 60 * 1000] ${tcl-command}}
+proc utimers {} {set t {}; foreach a [after info] {lappend t "0 [lindex [after info $a] 0] $a"}; return $t}
+proc timers {} {set t {}; foreach a [after info] {lappend t "0 [lindex [after info $a] 0] $a"}; return $t}
+proc killtimer id {return [after cancel $id]}
+proc killutimer id {return [after cancel $id]}
+
+proc isbotnick {n} {return [expr {$n == $::globuctx}]}
+
+proc setctx {ctx} {
+ global globctx
+ if {[catch [list set ::sock($ctx)] erre] > 0} {return} ; # silently crap out
+ set globctx $ctx
+}
+
+proc setuctx {ctx} {
+ global globuctx
+ if {[% nick2uid $ctx] == "" && !($ctx == "")} {return} ; # silently crap out
+ if {$ctx == ""} {
+ set globuctx ""
+ } {
+ set globuctx [% uid2intclient [% nick2uid $ctx]]
+ }
+}
+
+proc % {c args} {
+ set ul [list [curctx proto] $c [curctx sock]]
+ foreach {a} $args {lappend ul $a}
+ uplevel 1 $ul
+}
+
+proc @@ {c args} {
+ set ul [list [curctx proto] $c [curctx sock] [curctx unum]]
+ foreach {a} $args {lappend ul $a}
+ uplevel 1 $ul
+}
+
+proc getctx {{type net}} {curctx $type}
+
+proc curctx {{type net}} {
+ if {$::globctx == ""} {return ""}
+ switch -exact -- [format ".%s" [string tolower $type]] {
+ .sock {
+ return $::sock($::globctx)
+ }
+ .net {
+ return $::globctx
+ }
+ .unum {
+ return $::globuctx
+ }
+ .uid {
+ return [% intclient2uid $::globuctx]
+ }
+ .user {
+ return [% uid2nick [% intclient2uid $::globuctx]]
+ }
+ .proto {
+ return $::nettype($::globctx)
+ }
+ }
+}
+
+set globctx ""
+set globuctx ""
+
+foreach {pname} [list putserv puthelp putquick putnow] {
+ proc $pname {msg} {
+ if {[curctx unum] != ""} {
+ % putnow [curctx unum] $msg
+ } {
+ % putnow "" $msg
+ }
+ }
+}
+
+proc pushmode {mode args} {
+ @@ putmode $mode [join $args " "]
+}
+
+proc matchattr {handle attr {chan "*"}} {
+ set handle [string tolower $handle]
+ if {-1!=[string first "&" $attr]} {set and 1} {set and 0}
+ set gattr [lindex [split $attr "&|"] 0]
+ set cattr [lindex [split $attr "&|"] 1]
+ if {$handle == "" || $handle == "*"} {return [expr {(($gattr==$cattr||$cattr=="") && $gattr=="-")?1:0}]};# dump
+ set isattrg 0
+ foreach {c} [split [nda get "eggcompat/[curctx net]/attrs/global/$handle"] {}] {
+ foreach {k} [split $gattr {}] {
+ if {$c == $k} {set isattrg 1}
+ }
+ }
+ set isattrc 0
+ if {"*"!=$chan} {
+ foreach {c} [split [nda get "eggcompat/[curctx net]/attrs/[ndaenc $chan]/$handle"] {}] {
+ foreach {k} [split $cattr {}] {
+ if {$c == $k} {set isattrc 1}
+ }
+ }
+ }
+ if {$and && ($isattrg == $isattrc) && ($isattrc == 1)} {return 1}
+ if {!$and && ($isattrg || $isattrc)} {return 1}
+ return 0
+}
+
+proc chattr {handle attr {chan "*"}} {
+ set handle [string tolower $handle]
+ if {$chan == "*"} {
+ set del [list]
+ set app ""
+ set state app
+ foreach {c} [split $attr {}] {
+ if {"+"==$c} {set state app;continue}
+ if {"-"==$c} {set state del;continue}
+ if {$state=="del"} {
+ lappend del $c ""
+ }
+ if {$state=="app"} {
+ lappend del $c ""
+ append app $c
+ }
+ }
+ nda set "eggcompat/[curctx net]/attrs/global/$handle" [join [concat [string map $del [nda get "eggcompat/[curctx net]/attrs/global/$handle"]] $app] ""]
+ } {
+ set del [list]
+ set app ""
+ set state app
+ foreach {c} [split $attr {}] {
+ if {"+"==$c} {set state app;continue}
+ if {"-"==$c} {set state del;continue}
+ if {$state=="del"} {
+ lappend del $c ""
+ }
+ if {$state=="app"} {
+ lappend del $c ""
+ append app $c
+ }
+ }
+ puts stdout [ndaenc $chan]
+ nda set "eggcompat/[curctx net]/attrs/[ndaenc $chan]/$handle" [join [concat [string map $del [nda get "eggcompat/[curctx net]/attrs/[ndaenc $chan]/$handle"]] $app] ""]
+ }
+}
+
+proc channels {} {
+ set ret [list]
+ foreach {chan _} [nda get "eggcompat/[curctx net]/channels"] {
+ lappend ret $chan
+ }
+ return $ret
+}
+
+proc mc {form args} {
+ format $form {*}$args
+}
+
+#TODO: make this a namespace ensemble
+
+# hey, thanks fireegl
+proc 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
+ # We should probably not follow the RFC in this instance and instead use the correct case for those two characters.
+ # []\^ (uppers) == {}|~ (lowers)
+ set upperchannel [string toupper $channel]
+ global database
+ switch -- [set command [string tolower $command]] {
+ {add} {
+ set args [lassign [callchannel $command $channel {*}$args] command channel]
+ # Add the channel to the database:
+ dbase set eggcompat [curctx net] channels $upperchannel name $channel
+ SetUdefDefaults
+ # Call ourself again to set the options:
+ if {[llength $args]} { channel set $channel {*}$args }
+ return {}
+ }
+ {set} {
+ if {![dict exists [dbase get eggcompat [curctx net] channels] $upperchannel]} { return -code error "[mc {Invalid Channel: %s} $channel]" }
+ # In the case of "set", $args is already in the form we can use.
+ set setnext 0
+ foreach o $args {
+ if {$setnext} {
+ set setnext 0
+ switch -- $type {
+ {int} - {integer} {
+ # Note, settings such as flood-chan are treated as int's. Hence the need for using split here:
+ lassign [callchannel $command $channel $type $name [split $o {:{ }}]] command channel type name o
+ dbase set eggcompat [curctx net] channels $upperchannel $name $o
+ }
+ {str} - {string} {
+ lassign [callchannel $command $channel $type $name $o] command channel type name o
+ dbase set eggcompat [curctx net] channels $upperchannel $name $o
+ }
+ {list} - {lappend} {
+ lassign [callchannel $command $channel $type $name $o] command channel type name o
+ database channels lappend $upperchannel $name $o
+ }
+ {flag} {
+ # This is so we can support flags being set like:
+ # [channel set #channel bitch +]
+ # or: [channel set #channel revenge 1]
+ # The old way is still supported though. (see below)
+ switch -- $o {
+ {+} { set o 1 }
+ {-} { set o 0 }
+ {default} { set o [string is true -strict $o] }
+ }
+ lassign [callchannel $command $channel $type $name $o] command channel type name o
+ dbase set eggcompat [curctx net] channels $upperchannel $name $o
+ }
+ {unknown} - {default} {
+ return -code error "[mc {Invalid channel option: %s} $name]"
+ }
+ }
+ } elseif {$o != {}} {
+ switch -- [set type [UdefType [set name [string trimleft $o {+-}]]]] {
+ {flag} {
+ switch -- [string index $o 0] {
+ {+} {
+ lassign [callchannel $command $channel $type $name 1] command channel type name o
+ dbase set eggcompat [curctx net] channels $upperchannel $name $o
+ }
+ {-} {
+ lassign [callchannel $command $channel $type $name 0] command channel type name o
+ dbase set eggcompat [curctx net] channels $upperchannel $name $o
+ }
+ {default} {
+ # They must want to set it using a second arg...
+ set setnext 1
+ }
+ }
+ }
+ {int} - {str} - {list} - {integer} - {string} { set setnext 1 }
+ {unknown} - {default} { return -code error "[mc {Illegal channel option: %s} $name]" }
+ }
+ }
+ }
+ }
+ {info} {
+ # COMPATIBILITY WARNING: Because Eggdrop doesn't return the info in any documented or understandable order,
+ # Tcldrop will return a list of each channel setting and it's value. This way makes the info MUCH easier to use by Tcl scripters.
+ if {[dict exists [dbase get eggcompat [curctx net] channels] $upperchannel]} {
+ dict get [dbase get eggcompat [curctx net] channels] $upperchannel
+ } else {
+ return -code error "[mc {No such channel record: %s} $channel]"
+ }
+ }
+ {get} {
+ if {[dict exists [dbase get eggcompat [curctx net] channels] $upperchannel]} {
+ if {[dict exists [dbase get eggcompat [curctx net] channels] $upperchannel {*}$args]} {
+ dict get [dbase get eggcompat [curctx net] channels] $upperchannel {*}$args
+ } else {
+ return -code error "[mc {Unknown channel setting: %s} $args]"
+ }
+ } else {
+ return -code error "[mc {No such channel record: %s} $channel]"
+ }
+ }
+ {list} {
+ set list [list]
+ dict for {key value} [dbase get eggcompat [curctx net] channels] { lappend list [dict get $value name] }
+ return $list
+ }
+ {count} { dict size [dbase get eggcompat [curctx net] channels] }
+ {remove} - {rem} - {delete} - {del} {
+ if {[dict exists [dbase get eggcompat [curctx net] channels] $upperchannel]} {
+ set args [lassign [callchannel $command $channel {*}$args] $command $channel]
+ dbase unset eggcompat [curctx net] channels $upperchannel
+ } else {
+ return -code error "[mc {No such channel record: %s} $channel]"
+ }
+ }
+ {exists} - {exist} {
+ if {[dict exists [dbase get eggcompat [curctx net] channels] $upperchannel]} {
+ return 1
+ } else {
+ return 0
+ }
+ }
+ {default} { return -code error "[mc {Unknown channel sub-command "%s".} $command]" }
+ }
+}
+
+# er, no ellenor, that's not how you do that
+#namespace eval channel {
+# proc ::channel::get {chan flag} {
+# if {[::set enda [nda get "eggcompat/[curctx net]/chansets/[ndaenc $chan]/[ndaenc [string map {+ ""} $flag]]"]]!=""} {return $enda} {return 0}
+# }
+# proc ::channel::set {chan flags} {
+# if {[llength $flags] != 1} {
+# foreach {flag} $flags {
+# ::set bit [string index $flag 0]
+# if {$bit=="+"} {::set bitt 1} {::set bitt 0}
+# ::set flag [string range $flag 1 end]
+# nda set "eggcompat/[curctx net]/chansets/[ndaenc $chan]/[ndaenc [string map {+ ""} $flag]]" $bitt
+# }
+# } {
+# ::set bit [string index $flags 0]
+# if {$bit=="+"} {::set bitt 1} {::set bitt 0}
+# ::set flag [string range $flags 1 end]
+# nda set "eggcompat/[curctx net]/chansets/[ndaenc $chan]/[ndaenc [string map {+ ""} $flags]]" $bitt
+# }
+# }
+# namespace export *
+# namespace ensemble create
+#}
+
+proc validuser {n} {
+ if {""==[dbase get usernames [curctx net] $n]} {return 0} {return 1}
+}
+
+proc userlist {} {
+ set r [list]
+ foreach {u _} [dbase get usernames [curctx net]] {
+ lappend r $u
+ }
+ return $r
+}
+
+proc deluser {username} {
+ if {![validuser $username]} {return 0}
+ dbase unset usernames [curctx net] $username
+}
+
+proc adduser {username {hostmask ""}} {
+ if {[validuser $username]} {return 0}
+ if {$hostmask != ""} {set moretodo 1} {set moretodo 0}
+ while {0!=$moretodo} {
+ set bindnum [rand 1 10000000]
+ if {[dbase get usernames [curctx net] $username]!=""} {} {set moretodo 0}
+ }
+ if {$hostmask != ""} {dbase set usernames [curctx net] $username hostmasks $bindnum $hostmask}
+ dbase set usernames [curctx net] $username reg 1
+ return 1
+}
+
+#llbind [curctx sock] msg 77 "chanset" msgchanset
+#llbind [curctx sock] msg 77 "chattr" msgchattr
+#llbind [curctx sock] msg 77 "setxtra" msgxtra
+#set botnick $cs(nick)
+#chattr $cs(admin) +mnolv
+
+proc msgchanset {from msg} {
+ set ndacname [ndaenc [lindex $msg 0 0]]
+ set chanset [lindex $msg 0 1]
+ if {300>[nda get "regchan/$ndacname/levels/[string tolower [tnda get "login/$from"]]"] && ![matchattr [tnda get "login/[curctx net]/$from"] m|m [lindex $msg 0 0]]} {
+ [curctx proto] notice [curctx sock] 77 $from "Only channel super-operators (300) and above and network masters may use eggdrop-compatible chansets."
+ return
+ }
+ channel set [lindex $msg 0 0] $chanset
+ [curctx proto] notice [curctx sock] 77 $from "Eggdrop compatible chanset $chanset set on [lindex $msg 0 0]."
+}
+
+proc msgchattr {from msg} {
+ set ndacname [ndaenc [lindex $msg 0 2]]
+ set handle [lindex $msg 0 0]
+ set hand [lindex $msg 0 0]
+ set attrs [lindex $msg 0 1]
+ set chan [lindex $msg 0 2]
+ set ch [lindex $msg 0 2]
+ foreach {c} [split $attrs {}] {
+ if {$c == "+"} {continue}
+ if {$c == "-"} {continue}
+ if {$c == "k"} {set c "mn|mnol"}
+ if {$c == "v"} {set c "mn|lmno"}
+ if {$c == "l"} {set c "mn|mno"}
+ if {$c == "o"} {set c "mn|omn"}
+ if {$c == "m"} {set c "mn|mn"}
+ if {$c == "n"} {set c "n|n"}
+ if {$c == "a"} {set c "mn|"}
+ if {![matchattr [tnda get "login/[curctx net]/$from"] $c $chan]} {
+ [curctx proto] notice [curctx sock] 77 $from "You may only give flags you already possess (Any of flags $c required to set $attrs)."
+ return
+ }
+ }
+ if {""==$chan} {chattr $hand $attrs} {chattr $hand $attrs $chan}
+ [curctx proto] notice [curctx sock] 77 $from "Global flags for $hand are now [nda get "eggcompat/[curctx net]/attrs/global/[string tolower $handle]"]"
+ if {""==[nda get "regchan/$ndacname/levels/[string tolower $hand]"]} {nda set "regchan/$ndacname/levels/[string tolower $hand]" 1}
+ if {$ch != ""} {[curctx proto] notice [curctx sock] 77 $from "Flags on $chan for $hand are now [nda get "eggcompat/[curctx net]/attrs/$ndacname/[string tolower $handle]"]"}
+}
+
+proc nick2hand {nick} {
+ foreach {uid nic} [tnda get "nick/[curctx net]"] {
+ if {[string tolower $nick] == [string tolower $nic]} {return [tnda get "login/[curctx net]/$uid"]}
+ }
+}
+
+proc uid2hand {uid} {
+ return [tnda get "login/[curctx net]/$uid"]
+}
+
+proc getuser {nick datafield {dataval "body"}} {
+ return [dbase get usernames [curctx net] $nick setuser [ndaenc $datafield] [ndaenc $dataval]]
+}
+
+proc setuser {nick datafield {dataval "body"} {val {}}} {
+ puts stdout "$nick $datafield $dataval $val"
+ if {[string tolower $datafield] == "pass"} {usetpass $nick $dataval}
+ if {[string tolower $datafield] == "hosts"} {addhost $nick $dataval}
+ if {$val == {} && [string tolower $datafield] != "xtra"} {
+ return [dbase set usernames [curctx net] $nick setuser [ndaenc $datafield] $dataval]
+ } {
+ return [dbase set usernames [curctx net] $nick setuser [ndaenc $datafield] [ndaenc $dataval] $val]
+ }
+}
+
+proc msgxtra {from msg} {
+ if {[set log [tnda get "login/[curctx net]/$from"]]==""} {
+ [curctx proto] notice [curctx sock] 77 $from "Until you've registered with the bot, you have no business setting XTRA values."
+ return
+ }
+ set subfield [lindex $msg 0 0]
+ set value [join [lrange [lindex $msg 0] 1 end] " "]
+ setuser $log "XTRA" $subfield $value
+ [curctx proto] notice [curctx sock] 77 $from "Set your user record XTRA $subfield to $value."
+}
+
+proc chandname2name {channame} {return $channame}
+proc channame2dname {channame} {return $channame}
+
+proc islinked {bot} {return 0}
+
+proc operHasPrivilege {n i p} {
+ # this bit requires irca.
+ set metadatum [tnda get "metadata/$n/$i/[ndcenc PRIVS]"]
+ set md [split $metadatum " "]
+ set pl [split $p " ,"]
+ foreach {pv} $pl {
+ if {[lsearch $md $pv] != -1} {return 1}
+ }
+ return 0
+}
+
+proc operHasAllPrivileges {n i p} {
+ # this bit requires irca.
+ set metadatum [tnda get "metadata/$n/$i/[ndcenc PRIVS]"]
+ set md [split $metadatum " "]
+ set pl [split $p " ,"]
+ foreach {pv} $pl {
+ if {[lsearch $md $pv] == -1} {return 0}
+ }
+ return 1
+}
+
+foreach {pn} [list botisop botisvoice botishalfop] {
+ proc $pn {args} {return 1}
+}
+
+proc isop {chan id} {
+ return [ismode $chan $id o]
+}
+
+proc isvoice {chan id} {
+ return [ismode $chan $id v]
+}
+
+proc ishalf {chan id} {
+ return [ismode $chan $id h]
+}
+
+proc ishalfop {chan id} {
+ return [ismode $chan $id h]
+}
+
+proc ismode {chan id mode} {
+ if {[string first $mode [[curctx proto] getupfx [curctx sock] $chan $id]] != -1} {return 1} {return 0}
+}
+
+proc ismodebutnot {chan id mode} {
+ if {[string length [[curctx proto] getupfx [curctx sock] $chan $id]] > 0 && [string first $mode [[curctx proto] getupfx [curctx sock] $chan $id]] == -1} {return 1} {return 0}
+}
+
+# rules are odd. you should store the bind return in a variable to unbind it.
+# flags aren't part of the bind define.
+set nonusertypes [list conn create encap evnt join login mark mode part pub notc quit topic pubm nick ctcp ctcr]
+set lowertypes [list notc ctcp ctcr pub msg]
+proc ibind {type flag text script} {
+ set ctxsock [curctx sock]
+ set ctxuser [curctx unum]
+ if {[lsearch -exact $::nonusertypes [string tolower $type]] != -1} {set binduser "-"} {set binduser $ctxuser}
+ if {[lsearch -exact $::lowertypes [string tolower $type]] != -1} {set text [string tolower $text]}
+ return [llbind $ctxsock $type $binduser $text [list setupthenrun [list [curctx net] $ctxsock $type $ctxuser $flag $text] $script]]
+}
+
+proc bind {type flag text script} {
+ set ctxsock [curctx sock]
+ set ctxuser [curctx unum]
+ if {[lsearch -exact $::nonusertypes [string tolower $type]] != -1} {set binduser "-"} {set binduser $ctxuser}
+ if {[lsearch -exact $::lowertypes [string tolower $type]] != -1} {set text [string tolower $text]}
+ puts stdout [list llbind $ctxsock $type $binduser $text [list isetupthenrun [list [curctx net] $ctxsock $type $ctxuser $flag $text] $script]]
+ return [llbind $ctxsock $type $binduser $text [list isetupthenrun [list [curctx net] $ctxsock $type $ctxuser $flag $text] $script]]
+}
+
+proc unbind {type flag text {scrip ""}} {
+ set ctxsock [curctx sock]
+ set ctxuser [curctx unum]
+ if {[lsearch -exact $::nonusertypes [string tolower $type]] != -1} {set binduser "-"} {set binduser $ctxuser}
+ if {[lsearch -exact $::lowertypes [string tolower $type]] != -1} {set text [string tolower $text]}
+ set binds [tnda get "llbinds/[curctx net]/$type/$binduser/[ndcenc $text]"]
+ set killids [list]
+ foreach {id script} $binds {
+ if {[lindex $script 0] == "isetupthenrun" || [lindex $script 0] == "setupthenrun"} {
+ set opts [lindex $script 1]
+ lassign $opts netctx sockctx otype userctx flags otext
+ if {$userctx == $ctxuser && $otype == $type && $text == $otext && ($scrip == "" || $scrip == $script)} {lappend killids $id}
+ }
+ }
+ foreach {id} $killids {
+ unllbind $ctxsock $type $binduser $text $id
+ }
+}
+
+proc setupthenrun {opts script args} {
+ lassign $opts netctx sockctx type userctx flags text
+ setctx $netctx
+ setuctx [% uid2nick $userctx]
+ foreach {a} $args {
+ lappend script $a
+ }
+ eval $script
+}
+
+proc isetupthenrun {opts script args} {
+ lassign $opts netctx sockctx type userctx flags text
+ global globuctx
+ if {-1!=[lsearch -exact [list] $type]} {set chan [lindex $args 1]} {set chan "*"}
+ setctx $netctx
+ set globuctx $userctx
+ # "nick uhost hand"
+ lappend script [% uid2nick [lindex $args 0]]
+ lappend script [format "%s@%s" [% uid2ident [lindex $args 0]] [% uid2host [lindex $args 0]]]
+ lappend script [uid2hand [lindex $args 0]]
+ if {![set output [matchattr [uid2hand [lindex $args 0]] $flags $chan]]} {puts stdout "execution denied of $script - matchattr is $output";return}
+ foreach {a} [lrange $args 1 end] {
+ lappend script $a
+ }
+ puts stdout "$script"
+ eval $script
+}
+
+foreach {def} {
+protectop protecthalfop protectvoice operit autoop autohalfop autovoice bitch halfbitch voicebitch inactive
+} {
+setudef flag $def
+}
+
+proc onchan {nick chan} {
+ set uid [% nick2uid $nick]
+ set ndacname [ndaenc $chan]
+ if {[tnda get "userchan/[curctx net]/$uid/$ndacname"] == "1"} {return 1} {return 0}
+}
+
+proc alg {{ha ""}} {
+ if {$ha == ""} {return "SSHA256"} {return $ha}
+}
+
+proc passwdok {n p} {
+ set isp [dbase get usernames [curctx net] $n pass]
+ set chkp [pwhash.[alg [lindex [split $isp "/"] 0]] $p]
+ if {$isp==""} {return 1}
+ if {$chkp == $isp} {return 1}
+ return 0
+}
+
+proc usetpass {n p} {
+ set chkp [pwhash.SSHA256 $p]
+ dbase get usernames [curctx net] $n pass $chkp
+}
diff --git a/core/4000-eggcom.tcl b/core/4000-eggcom.tcl
@@ -1,818 +0,0 @@
-#source chanserv.conf
-
-#more thanks to fireegl
-# XXX THIS PORTION BLOCKS NONGPL RELEASE
-
-proc SetUdefDefaults {{name {*}}} {
- global UdefDefaults
- foreach udef [array names UdefDefaults $name] {
- #dict for {key value} $::database(channels) {
- # if {![dict exists $value $udef]} {
- # dbase set eggcompat [curctx net] channels $key $value $udef $UdefDefaults($udef)
- # }
- #}
- foreach channel [channels] {
- if {[catch { channel get $channel $udef }]} {
- # channel set $channel $udef $UdefDefaults($udef)
- dbase set eggcompat [curctx net] channels [string toupper $channel] $udef $UdefDefaults($udef)
- }
- }
- }
-}
-
-# Defines a new udef:
-proc setudef {type name {default {}}} {
- # Store the default for this udef:
- global UdefDefaults
- set name [string tolower $name]
- switch -- $type {
- {flag} { set UdefDefaults($name) [string is true -strict $default] }
- {int} { if {$default != {}} { set UdefDefaults($name) $default } else { set UdefDefaults($name) 0 } }
- {str} - {list} { set UdefDefaults($name) $default }
- {default} { return -code error "[mc {Invalid udef type: %s} $type]" }
- }
- # Store the udef itself:
- global Udefs
- set Udefs($name) $type
- # "UDEF: $name (${type}) defined. Default: $UdefDefaults($name)"
- # Apply the default to all channels that don't already have it set:
- 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 getudefs {{type {}}} {
- # Note/FixMe: Eggdrop probably errors if $type is invalid.
- # This is not a compatibility problem though
- global 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
-# Module: channels
-proc renudef {type oldname newname} {
- global Udefs
- if {[info exists Udefs($newname)]} {return -1}
- if {[info exists Udefs($oldname)] && [string equal -nocase $Udefs($oldname) $type]} {
- dict for {key value} $::database(channels) {
- if {[dict exists $value $oldname]} {
- dbase set eggcompat [curctx net] channels $key $newname [dbase get eggcompat [curctx net] channels $key $oldname]
- dbase unset eggcompat [curctx net] channels $key $oldname
- }
- }
- set Udefs($newname) $Udefs($oldname)
- unset Udefs($oldname)
- global UdefDefaults
- set UdefDefaults($newname) $UdefDefaults($oldname)
- unset Udefs($oldname)
- return 1
- }
- return 0
-}
-
-# deludef <flag/int> <name>
-# Description: deletes a user defined channel flag or integer setting.
-# Returns: nothing
-# Module: channels
-# Proc written by Papillon@EFNet.
-# FixMe: This proc is untested and unmodified from what he sent me. Looks broken. =P
-proc deludef {type name} {
- global Udefs
- if {[info exists Udefs($oldname)] && [string equal -nocase $Udefs($oldname) $type]} {
- dict for {key value} $::database(channels) { if {[dict exists $value $oldname]} { dbase unset eggcompat [curctx net] channels $key $oldname } }
- unset Udefs($oldname)
- global UdefDefaults
- unset Udefs($oldname)
- return 1
- }
- return 0
-}
-
-# Returns 1 if it's a valid (existing) name for a udef, or 0 if it's not:
-proc validudef {name} {
- global Udefs
- info exists Udefs($name)
-}
-
-
-proc protectopcheck {mc f t p} {
- if {"o"==$mc && ![channel get $t protectop]} {return}
- if {"h"==$mc && ![channel get $t protecthalfop]} {return}
- if {"v"==$mc && ![channel get $t protectvoice]} {return}
- switch -- $mc {
- "o" {
- if {[matchattr [tnda get "login/[curctx net]/$p"] omn|omn $t]} {
- [curctx proto] putmode [curctx sock] 77 $t +$mc "$p" [tnda get "channels/[curctx net]/[ndaenc $t]/ts"]
- }
- }
- "h" {
- if {[matchattr [tnda get "login/[curctx net]/$p"] l|l $t]} {
- [curctx proto] putmode [curctx sock] 77 $t +$mc "$p" [tnda get "channels/[curctx net]/[ndaenc $t]/ts"]
- }
- }
- "v" {
- if {[matchattr [tnda get "login/[curctx net]/$p"] v|v $t]} {
- [curctx proto] putmode [curctx sock] 77 $t +$mc "$p" [tnda get "channels/[curctx net]/[ndaenc $t]/ts"]
- }
- }
- }
-}
-
-proc finduserbyid {n} {
- tnda get "login/[curctx net]/$f"
-}
-
-proc autoopcheck {c f} {
- set globe 0
- if {[channel get $c operit]} {set globe 1}
- if {[channel get $c autoop]} {set auto nmo} {set auto ""}
- if {[channel get $c autohalfop]} {append auto l}
- if {[channel get $c autovoice]} {append auto v}
- tcs:opcheck $c $f $globe $auto
-}
-
-proc unixtime {} {
- return [clock format [clock seconds] -format %s]
-}
-
-proc tcs:opcheck {c f {globe 0} {auto nmolv}} {
-# puts stdout "$c $f"
- if {[matchattr [tnda get "login/[curctx net]/$f"] |k $c]} {
- # obviously optimised for charybdis... ???
- [curctx proto] putmode [curctx sock] 77 $c +b "*![tnda get "ident/[curctx net]/$f"]@[tnda get "vhost/[curctx net]/$f"]" [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
- [curctx proto] kick [curctx sock] 77 $c $f "Autokicked (+k attribute)"
- return
- }
- if {[matchattr [tnda get "login/[curctx net]/$f"] n|] && $globe} {
- [curctx proto] putmode [curctx sock] 77 $c +[tnda get "pfx/owner"] $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
- return
- }
- if {[matchattr [tnda get "login/[curctx net]/$f"] |n $c] && ([string first "o" $auto] != -1)} {
- [curctx proto] putmode [curctx sock] 77 $c +[tnda get "pfx/owner"] $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
- return
- }
-
- if {[matchattr [tnda get "login/[curctx net]/$f"] m|] && $globe} {
- [curctx proto] putmode [curctx sock] 77 $c +[tnda get "pfx/protect"] $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
- return
- }
- if {[matchattr [tnda get "login/[curctx net]/$f"] |m $c] && ([string first "o" $auto] != -1)} {
- [curctx proto] putmode [curctx sock] 77 $c +[tnda get "pfx/protect"] $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
- return
- }
-
- if {[matchattr [tnda get "login/[curctx net]/$f"] a|]} {
- [curctx proto] putmode [curctx sock] 77 $c +o $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
- return
- }
- if {[matchattr [tnda get "login/[curctx net]/$f"] o|] && $globe} {
- [curctx proto] putmode [curctx sock] 77 $c +o $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
- return
- }
- if {[matchattr [tnda get "login/[curctx net]/$f"] |o $c] && ([string first "o" $auto] != -1)} {
- [curctx proto] putmode [curctx sock] 77 $c +o $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
- return
- }
- if {[matchattr [tnda get "login/[curctx net]/$f"] l|] && $globe} {
- [curctx proto] putmode [curctx sock] 77 $c +[tnda get "pfx/halfop"] $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
- return
- }
- if {[matchattr [tnda get "login/[curctx net]/$f"] |l $c] && ([string first "h" $auto] != -1)} {
- [curctx proto] putmode [curctx sock] 77 $c +[tnda get "pfx/halfop"] $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
- return
- }
- if {[matchattr [tnda get "login/[curctx net]/$f"] v|] && $globe} {
- [curctx proto] putmode [curctx sock] 77 $c +v $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
- return
- }
- if {[matchattr [tnda get "login/[curctx net]/$f"] |v $c] && ([string first "v" $auto] != -1)} {
- [curctx proto] putmode [curctx sock] 77 $c +v $f [tnda get "channels/[curctx net]/[ndaenc $c]/ts"]
- return
- }
-}
-
-proc bitchopcheck {mc ftp} {
- set f [lindex $ftp 0]
- set t [lindex $ftp 1]
- set p [lindex $ftp 2]
- puts stdout "$ftp"
- if {[tnda get "pfx/owner"]==$mc && ![channel get $t bitch]} {return} {if {[tnda get "pfx/owner"] != q} {set mc q}}
- if {[tnda get "pfx/protect"]==$mc && ![channel get $t bitch]} {return} {if {[tnda get "pfx/protect"] != a} {set mc a}}
- if {"o"==$mc && ![channel get $t bitch]} {return}
- if {"h"==$mc && ![channel get $t halfbitch]} {return}
- if {"v"==$mc && ![channel get $t voicebitch]} {return}
- switch -glob -- $mc {
- "q" {
- if {![matchattr [tnda get "login/[curctx net]/$p"] n|n $t]} {
- puts stdout "M $t -$mc $p [nda get "regchan/[ndaenc $t]/ts"]"
- [curctx proto] putmode [curctx sock] 77 $t "-$mc" "$p" [nda get "regchan/[ndaenc $t]/ts"]
- }
- }
- "a" {
- if {![matchattr [tnda get "login/[curctx net]/$p"] mn|mn $t]} {
- puts stdout "M $t -$mc $p [nda get "regchan/[ndaenc $t]/ts"]"
- [curctx proto] putmode [curctx sock] 77 $t "-$mc" "$p" [nda get "regchan/[ndaenc $t]/ts"]
- }
- }
- "o" {
- if {![matchattr [tnda get "login/[curctx net]/$p"] aomn|omn $t]} {
- puts stdout "M $t -$mc $p [nda get "regchan/[ndaenc $t]/ts"]"
- [curctx proto] putmode [curctx sock] 77 $t "-$mc" "$p" [nda get "regchan/[ndaenc $t]/ts"]
- }
- }
- "h" {
- if {![matchattr [tnda get "login/[curctx net]/$p"] l|l $t]} {
- puts stdout "M $t -$mc $p [nda get "regchan/[ndaenc $t]/ts"]"
- [curctx proto] putmode [curctx sock] 77 $t "-$mc" "$p" [nda get "regchan/[ndaenc $t]/ts"]
- }
- }
- "v" {
- if {![matchattr [tnda get "login/[curctx net]/$p"] v|v $t]} {
- puts stdout "M $t -$mc $p [nda get "regchan/[ndaenc $t]/ts"]"
- [curctx proto] putmode [curctx sock] 77 $t "-$mc" "$p" [nda get "regchan/[ndaenc $t]/ts"]
- }
- }
- }
-}
-
-#proc every {milliseconds script} {$script; after $milliseconds [every $milliseconds $script]}
-#every 1000 [list firellmbind - time [clock format [clock seconds] -format "%M %H %d %m %Y"]]
-proc utimer {seconds tcl-command} {after [expr $seconds * 1000] ${tcl-command}}
-proc timer {minutes tcl-command} {after [expr $minutes * 60 * 1000] ${tcl-command}}
-proc utimers {} {set t {}; foreach a [after info] {lappend t "0 [lindex [after info $a] 0] $a"}; return $t}
-proc timers {} {set t {}; foreach a [after info] {lappend t "0 [lindex [after info $a] 0] $a"}; return $t}
-proc killtimer id {return [after cancel $id]}
-proc killutimer id {return [after cancel $id]}
-
-proc isbotnick {n} {return [expr {$n == $::globuctx}]}
-
-proc setctx {ctx} {
- global globctx
- if {[catch [list set ::sock($ctx)] erre] > 0} {return} ; # silently crap out
- set globctx $ctx
-}
-
-proc setuctx {ctx} {
- global globuctx
- if {[% nick2uid $ctx] == "" && !($ctx == "")} {return} ; # silently crap out
- if {$ctx == ""} {
- set globuctx ""
- } {
- set globuctx [% uid2intclient [% nick2uid $ctx]]
- }
-}
-
-proc % {c args} {
- set ul [list [curctx proto] $c [curctx sock]]
- foreach {a} $args {lappend ul $a}
- uplevel 1 $ul
-}
-
-proc @@ {c args} {
- set ul [list [curctx proto] $c [curctx sock] [curctx unum]]
- foreach {a} $args {lappend ul $a}
- uplevel 1 $ul
-}
-
-proc getctx {{type net}} {curctx $type}
-
-proc curctx {{type net}} {
- if {$::globctx == ""} {return ""}
- switch -exact -- [format ".%s" [string tolower $type]] {
- .sock {
- return $::sock($::globctx)
- }
- .net {
- return $::globctx
- }
- .unum {
- return $::globuctx
- }
- .uid {
- return [% intclient2uid $::globuctx]
- }
- .user {
- return [% uid2nick [% intclient2uid $::globuctx]]
- }
- .proto {
- return $::nettype($::globctx)
- }
- }
-}
-
-set globctx ""
-set globuctx ""
-
-foreach {pname} [list putserv puthelp putquick putnow] {
- proc $pname {msg} {
- if {[curctx unum] != ""} {
- % putnow [curctx unum] $msg
- } {
- % putnow "" $msg
- }
- }
-}
-
-proc pushmode {mode args} {
- @@ putmode $mode [join $args " "]
-}
-
-proc matchattr {handle attr {chan "*"}} {
- set handle [string tolower $handle]
- if {-1!=[string first "&" $attr]} {set and 1} {set and 0}
- set gattr [lindex [split $attr "&|"] 0]
- set cattr [lindex [split $attr "&|"] 1]
- if {$handle == "" || $handle == "*"} {return [expr {(($gattr==$cattr||$cattr=="") && $gattr=="-")?1:0}]};# dump
- set isattrg 0
- foreach {c} [split [nda get "eggcompat/[curctx net]/attrs/global/$handle"] {}] {
- foreach {k} [split $gattr {}] {
- if {$c == $k} {set isattrg 1}
- }
- }
- set isattrc 0
- if {"*"!=$chan} {
- foreach {c} [split [nda get "eggcompat/[curctx net]/attrs/[ndaenc $chan]/$handle"] {}] {
- foreach {k} [split $cattr {}] {
- if {$c == $k} {set isattrc 1}
- }
- }
- }
- if {$and && ($isattrg == $isattrc) && ($isattrc == 1)} {return 1}
- if {!$and && ($isattrg || $isattrc)} {return 1}
- return 0
-}
-
-proc chattr {handle attr {chan "*"}} {
- set handle [string tolower $handle]
- if {$chan == "*"} {
- set del [list]
- set app ""
- set state app
- foreach {c} [split $attr {}] {
- if {"+"==$c} {set state app;continue}
- if {"-"==$c} {set state del;continue}
- if {$state=="del"} {
- lappend del $c ""
- }
- if {$state=="app"} {
- lappend del $c ""
- append app $c
- }
- }
- nda set "eggcompat/[curctx net]/attrs/global/$handle" [join [concat [string map $del [nda get "eggcompat/[curctx net]/attrs/global/$handle"]] $app] ""]
- } {
- set del [list]
- set app ""
- set state app
- foreach {c} [split $attr {}] {
- if {"+"==$c} {set state app;continue}
- if {"-"==$c} {set state del;continue}
- if {$state=="del"} {
- lappend del $c ""
- }
- if {$state=="app"} {
- lappend del $c ""
- append app $c
- }
- }
- puts stdout [ndaenc $chan]
- nda set "eggcompat/[curctx net]/attrs/[ndaenc $chan]/$handle" [join [concat [string map $del [nda get "eggcompat/[curctx net]/attrs/[ndaenc $chan]/$handle"]] $app] ""]
- }
-}
-
-proc channels {} {
- set ret [list]
- foreach {chan _} [nda get "eggcompat/[curctx net]/channels"] {
- lappend ret $chan
- }
- return $ret
-}
-
-proc mc {form args} {
- format $form {*}$args
-}
-
-#TODO: make this a namespace ensemble
-
-# hey, thanks fireegl
-proc 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
- # We should probably not follow the RFC in this instance and instead use the correct case for those two characters.
- # []\^ (uppers) == {}|~ (lowers)
- set upperchannel [string toupper $channel]
- global database
- switch -- [set command [string tolower $command]] {
- {add} {
- set args [lassign [callchannel $command $channel {*}$args] command channel]
- # Add the channel to the database:
- dbase set eggcompat [curctx net] channels $upperchannel name $channel
- SetUdefDefaults
- # Call ourself again to set the options:
- if {[llength $args]} { channel set $channel {*}$args }
- return {}
- }
- {set} {
- if {![dict exists [dbase get eggcompat [curctx net] channels] $upperchannel]} { return -code error "[mc {Invalid Channel: %s} $channel]" }
- # In the case of "set", $args is already in the form we can use.
- set setnext 0
- foreach o $args {
- if {$setnext} {
- set setnext 0
- switch -- $type {
- {int} - {integer} {
- # Note, settings such as flood-chan are treated as int's. Hence the need for using split here:
- lassign [callchannel $command $channel $type $name [split $o {:{ }}]] command channel type name o
- dbase set eggcompat [curctx net] channels $upperchannel $name $o
- }
- {str} - {string} {
- lassign [callchannel $command $channel $type $name $o] command channel type name o
- dbase set eggcompat [curctx net] channels $upperchannel $name $o
- }
- {list} - {lappend} {
- lassign [callchannel $command $channel $type $name $o] command channel type name o
- database channels lappend $upperchannel $name $o
- }
- {flag} {
- # This is so we can support flags being set like:
- # [channel set #channel bitch +]
- # or: [channel set #channel revenge 1]
- # The old way is still supported though. (see below)
- switch -- $o {
- {+} { set o 1 }
- {-} { set o 0 }
- {default} { set o [string is true -strict $o] }
- }
- lassign [callchannel $command $channel $type $name $o] command channel type name o
- dbase set eggcompat [curctx net] channels $upperchannel $name $o
- }
- {unknown} - {default} {
- return -code error "[mc {Invalid channel option: %s} $name]"
- }
- }
- } elseif {$o != {}} {
- switch -- [set type [UdefType [set name [string trimleft $o {+-}]]]] {
- {flag} {
- switch -- [string index $o 0] {
- {+} {
- lassign [callchannel $command $channel $type $name 1] command channel type name o
- dbase set eggcompat [curctx net] channels $upperchannel $name $o
- }
- {-} {
- lassign [callchannel $command $channel $type $name 0] command channel type name o
- dbase set eggcompat [curctx net] channels $upperchannel $name $o
- }
- {default} {
- # They must want to set it using a second arg...
- set setnext 1
- }
- }
- }
- {int} - {str} - {list} - {integer} - {string} { set setnext 1 }
- {unknown} - {default} { return -code error "[mc {Illegal channel option: %s} $name]" }
- }
- }
- }
- }
- {info} {
- # COMPATIBILITY WARNING: Because Eggdrop doesn't return the info in any documented or understandable order,
- # Tcldrop will return a list of each channel setting and it's value. This way makes the info MUCH easier to use by Tcl scripters.
- if {[dict exists [dbase get eggcompat [curctx net] channels] $upperchannel]} {
- dict get [dbase get eggcompat [curctx net] channels] $upperchannel
- } else {
- return -code error "[mc {No such channel record: %s} $channel]"
- }
- }
- {get} {
- if {[dict exists [dbase get eggcompat [curctx net] channels] $upperchannel]} {
- if {[dict exists [dbase get eggcompat [curctx net] channels] $upperchannel {*}$args]} {
- dict get [dbase get eggcompat [curctx net] channels] $upperchannel {*}$args
- } else {
- return -code error "[mc {Unknown channel setting: %s} $args]"
- }
- } else {
- return -code error "[mc {No such channel record: %s} $channel]"
- }
- }
- {list} {
- set list [list]
- dict for {key value} [dbase get eggcompat [curctx net] channels] { lappend list [dict get $value name] }
- return $list
- }
- {count} { dict size [dbase get eggcompat [curctx net] channels] }
- {remove} - {rem} - {delete} - {del} {
- if {[dict exists [dbase get eggcompat [curctx net] channels] $upperchannel]} {
- set args [lassign [callchannel $command $channel {*}$args] $command $channel]
- dbase unset eggcompat [curctx net] channels $upperchannel
- } else {
- return -code error "[mc {No such channel record: %s} $channel]"
- }
- }
- {exists} - {exist} {
- if {[dict exists [dbase get eggcompat [curctx net] channels] $upperchannel]} {
- return 1
- } else {
- return 0
- }
- }
- {default} { return -code error "[mc {Unknown channel sub-command "%s".} $command]" }
- }
-}
-
-# er, no ellenor, that's not how you do that
-#namespace eval channel {
-# proc ::channel::get {chan flag} {
-# if {[::set enda [nda get "eggcompat/[curctx net]/chansets/[ndaenc $chan]/[ndaenc [string map {+ ""} $flag]]"]]!=""} {return $enda} {return 0}
-# }
-# proc ::channel::set {chan flags} {
-# if {[llength $flags] != 1} {
-# foreach {flag} $flags {
-# ::set bit [string index $flag 0]
-# if {$bit=="+"} {::set bitt 1} {::set bitt 0}
-# ::set flag [string range $flag 1 end]
-# nda set "eggcompat/[curctx net]/chansets/[ndaenc $chan]/[ndaenc [string map {+ ""} $flag]]" $bitt
-# }
-# } {
-# ::set bit [string index $flags 0]
-# if {$bit=="+"} {::set bitt 1} {::set bitt 0}
-# ::set flag [string range $flags 1 end]
-# nda set "eggcompat/[curctx net]/chansets/[ndaenc $chan]/[ndaenc [string map {+ ""} $flags]]" $bitt
-# }
-# }
-# namespace export *
-# namespace ensemble create
-#}
-
-proc validuser {n} {
- if {""==[dbase get usernames [curctx net] $n]} {return 0} {return 1}
-}
-
-proc userlist {} {
- set r [list]
- foreach {u _} [dbase get usernames [curctx net]] {
- lappend r $u
- }
- return $r
-}
-
-proc deluser {username} {
- if {![validuser $username]} {return 0}
- dbase unset usernames [curctx net] $username
-}
-
-proc adduser {username {hostmask ""}} {
- if {[validuser $username]} {return 0}
- if {$hostmask != ""} {set moretodo 1} {set moretodo 0}
- while {0!=$moretodo} {
- set bindnum [rand 1 10000000]
- if {[dbase get usernames [curctx net] $username]!=""} {} {set moretodo 0}
- }
- if {$hostmask != ""} {dbase set usernames [curctx net] $username hostmasks $bindnum $hostmask}
- dbase set usernames [curctx net] $username reg 1
- return 1
-}
-
-#llbind [curctx sock] msg 77 "chanset" msgchanset
-#llbind [curctx sock] msg 77 "chattr" msgchattr
-#llbind [curctx sock] msg 77 "setxtra" msgxtra
-#set botnick $cs(nick)
-#chattr $cs(admin) +mnolv
-
-proc msgchanset {from msg} {
- set ndacname [ndaenc [lindex $msg 0 0]]
- set chanset [lindex $msg 0 1]
- if {300>[nda get "regchan/$ndacname/levels/[string tolower [tnda get "login/$from"]]"] && ![matchattr [tnda get "login/[curctx net]/$from"] m|m [lindex $msg 0 0]]} {
- [curctx proto] notice [curctx sock] 77 $from "Only channel super-operators (300) and above and network masters may use eggdrop-compatible chansets."
- return
- }
- channel set [lindex $msg 0 0] $chanset
- [curctx proto] notice [curctx sock] 77 $from "Eggdrop compatible chanset $chanset set on [lindex $msg 0 0]."
-}
-
-proc msgchattr {from msg} {
- set ndacname [ndaenc [lindex $msg 0 2]]
- set handle [lindex $msg 0 0]
- set hand [lindex $msg 0 0]
- set attrs [lindex $msg 0 1]
- set chan [lindex $msg 0 2]
- set ch [lindex $msg 0 2]
- foreach {c} [split $attrs {}] {
- if {$c == "+"} {continue}
- if {$c == "-"} {continue}
- if {$c == "k"} {set c "mn|mnol"}
- if {$c == "v"} {set c "mn|lmno"}
- if {$c == "l"} {set c "mn|mno"}
- if {$c == "o"} {set c "mn|omn"}
- if {$c == "m"} {set c "mn|mn"}
- if {$c == "n"} {set c "n|n"}
- if {$c == "a"} {set c "mn|"}
- if {![matchattr [tnda get "login/[curctx net]/$from"] $c $chan]} {
- [curctx proto] notice [curctx sock] 77 $from "You may only give flags you already possess (Any of flags $c required to set $attrs)."
- return
- }
- }
- if {""==$chan} {chattr $hand $attrs} {chattr $hand $attrs $chan}
- [curctx proto] notice [curctx sock] 77 $from "Global flags for $hand are now [nda get "eggcompat/[curctx net]/attrs/global/[string tolower $handle]"]"
- if {""==[nda get "regchan/$ndacname/levels/[string tolower $hand]"]} {nda set "regchan/$ndacname/levels/[string tolower $hand]" 1}
- if {$ch != ""} {[curctx proto] notice [curctx sock] 77 $from "Flags on $chan for $hand are now [nda get "eggcompat/[curctx net]/attrs/$ndacname/[string tolower $handle]"]"}
-}
-
-proc nick2hand {nick} {
- foreach {uid nic} [tnda get "nick/[curctx net]"] {
- if {[string tolower $nick] == [string tolower $nic]} {return [tnda get "login/[curctx net]/$uid"]}
- }
-}
-
-proc uid2hand {uid} {
- return [tnda get "login/[curctx net]/$uid"]
-}
-
-proc getuser {nick datafield {dataval "body"}} {
- return [dbase get usernames [curctx net] $nick setuser [ndaenc $datafield] [ndaenc $dataval]]
-}
-
-proc setuser {nick datafield {dataval "body"} {val {}}} {
- puts stdout "$nick $datafield $dataval $val"
- if {[string tolower $datafield] == "pass"} {usetpass $nick $dataval}
- if {[string tolower $datafield] == "hosts"} {addhost $nick $dataval}
- if {$val == {} && [string tolower $datafield] != "xtra"} {
- return [dbase set usernames [curctx net] $nick setuser [ndaenc $datafield] $dataval]
- } {
- return [dbase set usernames [curctx net] $nick setuser [ndaenc $datafield] [ndaenc $dataval] $val]
- }
-}
-
-proc msgxtra {from msg} {
- if {[set log [tnda get "login/[curctx net]/$from"]]==""} {
- [curctx proto] notice [curctx sock] 77 $from "Until you've registered with the bot, you have no business setting XTRA values."
- return
- }
- set subfield [lindex $msg 0 0]
- set value [join [lrange [lindex $msg 0] 1 end] " "]
- setuser $log "XTRA" $subfield $value
- [curctx proto] notice [curctx sock] 77 $from "Set your user record XTRA $subfield to $value."
-}
-
-proc chandname2name {channame} {return $channame}
-proc channame2dname {channame} {return $channame}
-
-proc islinked {bot} {return 0}
-
-proc operHasPrivilege {n i p} {
- # this bit requires irca.
- set metadatum [tnda get "metadata/$n/$i/[ndcenc PRIVS]"]
- set md [split $metadatum " "]
- set pl [split $p " ,"]
- foreach {pv} $pl {
- if {[lsearch $md $pv] != -1} {return 1}
- }
- return 0
-}
-
-proc operHasAllPrivileges {n i p} {
- # this bit requires irca.
- set metadatum [tnda get "metadata/$n/$i/[ndcenc PRIVS]"]
- set md [split $metadatum " "]
- set pl [split $p " ,"]
- foreach {pv} $pl {
- if {[lsearch $md $pv] == -1} {return 0}
- }
- return 1
-}
-
-foreach {pn} [list botisop botisvoice botishalfop] {
- proc $pn {args} {return 1}
-}
-
-proc isop {chan id} {
- return [ismode $chan $id o]
-}
-
-proc isvoice {chan id} {
- return [ismode $chan $id v]
-}
-
-proc ishalf {chan id} {
- return [ismode $chan $id h]
-}
-
-proc ishalfop {chan id} {
- return [ismode $chan $id h]
-}
-
-proc ismode {chan id mode} {
- if {[string first $mode [[curctx proto] getupfx [curctx sock] $chan $id]] != -1} {return 1} {return 0}
-}
-
-proc ismodebutnot {chan id mode} {
- if {[string length [[curctx proto] getupfx [curctx sock] $chan $id]] > 0 && [string first $mode [[curctx proto] getupfx [curctx sock] $chan $id]] == -1} {return 1} {return 0}
-}
-
-# rules are odd. you should store the bind return in a variable to unbind it.
-# flags aren't part of the bind define.
-set nonusertypes [list conn create encap evnt join login mark mode part pub notc quit topic pubm nick ctcp ctcr]
-set lowertypes [list notc ctcp ctcr pub msg]
-proc ibind {type flag text script} {
- set ctxsock [curctx sock]
- set ctxuser [curctx unum]
- if {[lsearch -exact $::nonusertypes [string tolower $type]] != -1} {set binduser "-"} {set binduser $ctxuser}
- if {[lsearch -exact $::lowertypes [string tolower $type]] != -1} {set text [string tolower $text]}
- return [llbind $ctxsock $type $binduser $text [list setupthenrun [list [curctx net] $ctxsock $type $ctxuser $flag $text] $script]]
-}
-
-proc bind {type flag text script} {
- set ctxsock [curctx sock]
- set ctxuser [curctx unum]
- if {[lsearch -exact $::nonusertypes [string tolower $type]] != -1} {set binduser "-"} {set binduser $ctxuser}
- if {[lsearch -exact $::lowertypes [string tolower $type]] != -1} {set text [string tolower $text]}
- puts stdout [list llbind $ctxsock $type $binduser $text [list isetupthenrun [list [curctx net] $ctxsock $type $ctxuser $flag $text] $script]]
- return [llbind $ctxsock $type $binduser $text [list isetupthenrun [list [curctx net] $ctxsock $type $ctxuser $flag $text] $script]]
-}
-
-proc unbind {type flag text {scrip ""}} {
- set ctxsock [curctx sock]
- set ctxuser [curctx unum]
- if {[lsearch -exact $::nonusertypes [string tolower $type]] != -1} {set binduser "-"} {set binduser $ctxuser}
- if {[lsearch -exact $::lowertypes [string tolower $type]] != -1} {set text [string tolower $text]}
- set binds [tnda get "llbinds/[curctx net]/$type/$binduser/[ndcenc $text]"]
- set killids [list]
- foreach {id script} $binds {
- if {[lindex $script 0] == "isetupthenrun" || [lindex $script 0] == "setupthenrun"} {
- set opts [lindex $script 1]
- lassign $opts netctx sockctx otype userctx flags otext
- if {$userctx == $ctxuser && $otype == $type && $text == $otext && ($scrip == "" || $scrip == $script)} {lappend killids $id}
- }
- }
- foreach {id} $killids {
- unllbind $ctxsock $type $binduser $text $id
- }
-}
-
-proc setupthenrun {opts script args} {
- lassign $opts netctx sockctx type userctx flags text
- setctx $netctx
- setuctx [% uid2nick $userctx]
- foreach {a} $args {
- lappend script $a
- }
- eval $script
-}
-
-proc isetupthenrun {opts script args} {
- lassign $opts netctx sockctx type userctx flags text
- global globuctx
- if {-1!=[lsearch -exact [list] $type]} {set chan [lindex $args 1]} {set chan "*"}
- setctx $netctx
- set globuctx $userctx
- # "nick uhost hand"
- lappend script [% uid2nick [lindex $args 0]]
- lappend script [format "%s@%s" [% uid2ident [lindex $args 0]] [% uid2host [lindex $args 0]]]
- lappend script [uid2hand [lindex $args 0]]
- if {![set output [matchattr [uid2hand [lindex $args 0]] $flags $chan]]} {puts stdout "execution denied of $script - matchattr is $output";return}
- foreach {a} [lrange $args 1 end] {
- lappend script $a
- }
- puts stdout "$script"
- eval $script
-}
-
-foreach {def} {
-protectop protecthalfop protectvoice operit autoop autohalfop autovoice bitch halfbitch voicebitch inactive
-} {
-setudef flag $def
-}
-
-proc onchan {nick chan} {
- set uid [% nick2uid $nick]
- set ndacname [ndaenc $chan]
- if {[tnda get "userchan/[curctx net]/$uid/$ndacname"] == "1"} {return 1} {return 0}
-}
-
-proc alg {{ha ""}} {
- if {$ha == ""} {return "SSHA256"} {return $ha}
-}
-
-proc passwdok {n p} {
- set isp [dbase get usernames [curctx net] $n pass]
- set chkp [pwhash.[alg [lindex [split $isp "/"] 0]] $p]
- if {$isp==""} {return 1}
- if {$chkp == $isp} {return 1}
- return 0
-}
-
-proc usetpass {n p} {
- set chkp [pwhash.SSHA256 $p]
- dbase get usernames [curctx net] $n pass $chkp
-}
diff --git a/discuss/2019-10m-9d-modules-disaster.txt b/discuss/2019-10m-9d-modules-disaster.txt
@@ -0,0 +1,128 @@
+Hi, I'm ellenor@umbrellix.net, and I figured I needed to explain this disaster.
+
+ [perihelion ellenor]~/src/asterIRC/tclserv/modules $ ls -lah
+ total 97
+ drwxr-xr-x 2 ellenor other 16 Oct 7 22:58 .
+ drwxr-xr-x 7 ellenor other 23 Oct 9 15:40 ..
+ -rwxr-xr-x 1 ellenor other 209 Oct 6 00:02 bmotion.disabled
+ -rwxr-xr-x 1 ellenor other 17.2K Oct 7 22:43 chanserv.disabled
+ -rw-r--r-- 1 ellenor other 2.83K Oct 7 22:58 chanserv.tcl
+ -rw-r--r-- 1 ellenor other 5.01K Oct 6 00:02 debugserv.tcl
+ -rwxr-xr-x 1 ellenor other 3.73K Oct 6 00:02 gateway.disabled
+ -rwxr-xr-x 1 ellenor other 2.87K Oct 6 00:02 limitserv.disabled
+ -rwxr-xr-x 1 ellenor other 13.7K Oct 6 00:02 nope.egg.nope
+ -rwxr-xr-x 1 ellenor other 4.12K Oct 6 00:02 quote.disabled
+ -rw-r--r-- 1 ellenor other 13.8K Oct 6 00:02 quoteserv.tcl
+ -rwxr-xr-x 1 ellenor other 534 Oct 6 00:02 relayserv.disabled
+ -rwxr-xr-x 1 ellenor other 2.06K Oct 6 00:02 thcserv.disabled
+ -rwxr-xr-x 1 ellenor other 3.54K Oct 6 00:02 trigserv.disabled
+ -rwxr-xr-x 1 ellenor other 12.9K Oct 6 00:02 weather.disabled
+ -rw-r--r-- 1 ellenor other 16.6K Oct 6 00:02 weather.tcl
+
+ Figure 1. $PROJECT_ROOT/modules/
+
+In figure 1, you can see that there are 10 disabled modules (one of which has
+a comical name owing to that it's an ancestor of, I believe,
+core/*-eggcom.tcl). Many of these are services for the old API, which used
+a different structure of boilerplate code which you can see in
+modules/chanserv.disabled. That was also a multi-network API, but it was not
+actually working for TclServ anymore, so it has been migrated to the version
+2 API which you can see in all of the modules whose extension is .tcl.
+
+ proc confighandler {servicename defdbname headline block} {
+ set net [lindex $headline 0]
+ set nsock $::sock($net)
+ dictassign $block nick nick ident ident host host realname realname
+ if {[llength [tnda get "service/$net/$servicename/config"]] != 0} {
+ return -code error "<$servicename> O damn, I'm already loaded for $net!
+ }
+ tnda set "service/$net/$servicename/config" $block
+ if {[tnda get "service/$net/$servicename/config/dbname"] == ""} {
+ tnda set "service/$net/$servicename/dbname" $defdbname
+ }
+ setctx $net
+ if {[% intclient2uid [tnda get "service/$net/$servicename/ourid"]] == ""} {% sendUid $nick $ident $host $host [set ourid [% getfreeuid]] [expr {($realname == "") ? "* $servicename *" : $realname}] $modes; set connected "Connected"} {set connected "Already connected"}
+ set ouroid [tnda get "service/$net/$servicename/ourid"]
+ if {[info exists ourid]} {tnda set "service/$net/$servicename/ourid" $ourid} {set ourid [tnda get "service/$net/$servicename/ourid"]}
+ puts stdout [format "%s for %s: %s %s %s" $connected $net $nick $ident $host]
+ }
+
+ Figure 2. Suggested new structure of the boilerplate code for handling a
+ configuration block.
+
+The code in Figure 2, for reference, is part of the boilerplate code that is
+usually used by API level 2 modules.
+
+ $::maintype sendUid $::sock($::cs(netname)) $cs(nick) $cs(ident) $cs(host) $cs(host) 77 "Channels Server"
+ bind $::sock($::cs(netname)) msg 77 "register" regchan
+ bind $::sock($::cs(netname)) msg 77 "adduser" adduserchan
+ bind $::sock($::cs(netname)) msg 77 "users" lsuchan
+ bind $::sock($::cs(netname)) msg 77 "lsu" lsuchan
+ bind $::sock($::cs(netname)) msg 77 "convertop" convertop
+ #bind $::sock($::cs(netname)) msg 77 "deluser" deluserchan
+ bind $::sock($::cs(netname)) msg 77 "up" upchan
+ bind $::sock($::cs(netname)) pub "-" "@up" upchanfant
+ bind $::sock($::cs(netname)) pub "-" "@rand" randfant
+ bind $::sock($::cs(netname)) pub "-" "@request" requestbot
+ bind $::sock($::cs(netname)) msg 77 "down" downchan
+ bind $::sock($::cs(netname)) msg 77 "hello" regnick
+ bind $::sock($::cs(netname)) msg 77 "chpass" chpassnick
+ bind $::sock($::cs(netname)) msg 77 "login" idnick
+ bind $::sock($::cs(netname)) msg 77 "help" chanhelp
+ bind $::sock($::cs(netname)) msg 77 "topic" chantopic
+ bind $::sock($::cs(netname)) msg 77 "cookie" authin
+ bind $::sock($::cs(netname)) msg 77 "cauth" cookieauthin
+ bind $::sock($::cs(netname)) mode "-" "+" checkop
+ bind $::sock($::cs(netname)) mode "-" "-" checkdeop
+ bind $::sock($::cs(netname)) topic "-" "-" checktopic
+ bind $::sock($::cs(netname)) create "-" "-" checkcreate
+
+ Figure 3. chanserv.disabled | head -n 23.
+ Note fixed UID, leaving no room to have two of the module on the same
+ IRC server (though why would you), and fixed variable names, leaving no
+ room to have two of the module in the first place. (in either case you
+ do only load once, and the same code routines are called for every
+ instance of the module). Configuration was simply not flexible to
+ multiple instantiation (which the new boilerplate still is not, but
+ can easily be made so) and was not consolidated into one file, but 2,
+ just as in "Featherdrop" (our attempt at a lightweight Eggdrop replica
+ in Tcl; replaced by adoption of FireEgl's Tcldrop).
+
+The code in figure 3 is representative of a complex service. As a sidenote,
+in modern TclServ, 'bind' is now Eggdrop emulation. 'llbind' would be
+substituted to make that ChanServ (which we on then AsterIRC called 'Mars')
+work on modern Tclserv.
+
+ proc % {c args} {
+ set ul [list [curctx proto] $c [curctx sock]]
+ foreach {a} $args {lappend ul $a}
+ uplevel 1 $ul
+ }
+
+ proc @@ {c args} {
+ set ul [list [curctx proto] $c [curctx sock] [curctx unum]]
+ foreach {a} $args {lappend ul $a}
+ uplevel 1 $ul
+ }
+
+ Figure 4. Convenience functions in core/4000-eggcom.tcl
+
+Bizarrely, 4000-eggcom has morphed into a convenience functions module (it is
+a core module and all installations of TclServ must load it, or the bot will
+NOT function correctly) - its name suggests that it should only contain
+eggdrop-compatibility functions, and that was the original purpose of that
+file. By the time you read this file, it'll have been renamed to
+4000-convenience, reflecting its function. Many functions in 4000-convenience
+are obsolete, holdovers from the days of Mars and the old TclServ.
+
+Please see modules/chanserv.tcl to look into efforts to make a more model-
+compliant channels service module, that may eventually implement everything
+that Mars did (including cookie auth, using a different algorithm).
+
+In future, scripts that look like Eggdrop scripts but are only for TclServ
+(the aim being to make it easier to port scripts from Eggdrop to TclServ, not
+necessarily to make them run unmodified) will be in the scripts/ directory,
+as might a way to make some script modules partially work in Eggdrop (by
+translating the %/@@ commands to appropriate puthelps/putwhatevers, and
+blanking the setctx commands if not running in an sBNC (after which our
+inspiration for the context system was drawn)).
diff --git a/discuss/README b/discuss/README
@@ -0,0 +1,15 @@
+ .
+ .::::::::::::' .-. .::::.
+ ' :: :: / ::
+ :: ::/ :: .:::.
+ :: .:::. :: '::::. .:::. ':::::::::' ::: ::._
+ :: :: ' :: :: :: :: :: :: ::: ::
+ :: :: ' :: ::.::::::' :: :: ::: ::
+ :: ::' /:: :: :: :: :: :::. .:'
+ :: ..'':::' '::' ':::::' ':::::::::' ':::' ':::::'
+ (I'm not sure why I used handwriting for that. Was more effort than worth.)
+
+This directory will be used for notes-to-self by the developers, in the hope
+that should other people in future become part of the development team (which
+currently only exists de iure), they will not become totally confused by the
+development direction of the program.
