commit dbe35341ac023444891561911b59f1bf83d52cf5
parent 72e47f33380dbfe945a98ce73a006031b76ab45d
Author: Ellenor Malik <ellenor@umbrellix.net>
Date: Thu, 11 Feb 2021 04:50:09 -0800
pre-merge commit
Diffstat:
22 files changed, 1893 insertions(+), 534 deletions(-)
diff --git a/.gitignore b/.gitignore
@@ -6,3 +6,4 @@ scripts/
maintest.tcl
services.db.bk*
*.bak
+tcldrop-files
diff --git a/README.md b/README.md
@@ -1,3 +1,4 @@
-read the code, i'm too lazy to document this shite.
+TclServ
+====
-you need php. no questions. you need php. you also need tcl, obviously. but you need php.
+yes, we're working on it
diff --git a/boilerplate.tcl b/boilerplate.tcl
@@ -0,0 +1,20 @@
+
+
+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]
+}
+
diff --git a/chanserv.conf.example b/chanserv.conf.example
@@ -1,7 +1 @@
-set cs(nick) "Mars"
-set cs(ident) "services"
-set cs(host) "pandersticks.com"
-set cs(admin) "Ellenor"
-# REPLACE THIS! ^^ This user gets +mno set on them every bootup.
-set cs(netname) yournet
-::ts6::login $::sock($cs(netname)) $::numeric $::password $cs(netname)
+# you basically put source lines here ad libitum
diff --git a/core/0000-callbacks.tcl b/core/0000-callbacks.tcl
@@ -1,3 +1,5 @@
+# This portion, of course, is available under the MIT license if not bundled with the rest of TclServ.
+
proc llbind {sock type client comd script} {
set moretodo 1
while {0!=$moretodo} {
@@ -20,21 +22,67 @@ proc firellbind {sock type client comd args} {
# puts stdout "$sock $type $client $comd $args"
global globuctx globctx
set globctx $::netname($sock)
- set globuctx $client
+ set oldglobuctx $globuctx
+ if {$client == "-"} {set globuctx ""} {set globuctx $client}
if {""!=[tnda get "llbinds/$::netname($sock)/$type/$client/[ndcenc $comd]"]} {
foreach {id script} [tnda get "llbinds/$::netname($sock)/$type/$client/[ndcenc $comd]"] {
if {$script != ""} {
- set scr $script
+ set scr [string range $script 0 120]
# lappend $scr $sock
foreach {a} $args {
lappend scr $a
}
if {[set errcode [catch {eval $scr} erre]] > 0} {
- puts stdout [format "in script %s:\n\nerror code %s, %s\ncontact script developer for assistance\n" $scr $errcode $erre]
+ foreach logline [split [format "in script %s:\n\nerror code %s, %s\ncontact script developer for assistance\n" $scr $errcode $erre] "\n"] {
+ putloglev o * $logline
+ }
firellbind $sock evnt - error $erre {*}$scr
}
}
};return
+ } {
+# puts stdout "didn't find one"
}
+ set globuctx $oldglobuctx
#if {""!=[tnda get "llbinds/$type/-/[ndcenc $comd]"]} {foreach {id script} [tnda get "llbinds/$type/-/[ndcenc $comd]"] {$script [lindex $args 0] [lrange $args 1 end]};return}
}
+
+proc firellmbind {sock type client comd args} {
+# puts stdout "$sock $type $client [ndcenc $comd] $args"
+ global globuctx globctx
+ set globctx $::netname($sock)
+ set oldglobuctx $globuctx
+ if {$client == "-"} {set globuctx ""} {set globuctx $client}
+ foreach {comde scripts} [tnda get "llbinds/$::netname($sock)/$type/$client"] {
+ set text [ndadec $comde]
+ if {[string match $text $comd]} {
+ foreach {id script} $scripts {
+ if {$script != ""} {
+ set scr $script
+# lappend $scr $sock
+ foreach {a} $args {
+ lappend scr $a
+ }
+ if {[set errcode [catch {eval $scr} erre]] > 0} {
+ foreach logline [split [format "in script (#%s) %s:\n\nerror code %s, %s\ncontact script developer for assistance\n" $id $scr $errcode $erre] "\n"] {
+ putloglev o * $logline
+ }
+ firellbind $sock evnt - error $erre {*}$scr
+ }
+ }
+ }
+ }
+ }
+ set globuctx $oldglobuctx
+ #if {""!=[tnda get "llbinds/$type/-/[ndcenc $comd]"]} {foreach {id script} [tnda get "llbinds/$type/-/[ndcenc $comd]"] {$script [lindex $args 0] [lrange $args 1 end]};return}
+}
+proc putloglev {lev ch msg} {
+ # punt
+ 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/0002-statemachine.tcl b/core/0002-statemachine.tcl
@@ -1,60 +1,76 @@
-proc nick2uid {sck nick} {
+proc nick2uid {nick} {
+ set sck [curctx sock]
foreach {u n} [tnda get "nick/$::netname($sck)"] {
if {[string tolower $n] == [string tolower $nick]} {return $u}
}
return ""
}
-proc intclient2uid {sck nick} {
+proc intclient2uid {nick} {
+ set sck [curctx sock]
foreach {u n} [tnda get "intclient/$::netname($sck)"] {
if {[string tolower $n] == [string tolower $nick]} {return $u}
}
return ""
}
-proc uid2nick {sck u} {
+proc uid2nick {u} {
+ set sck [curctx sock]
return [tnda get "nick/$::netname($sck)/$u"]
}
-proc uid2rhost {sck u} {
+proc uid2rhost {u} {
+ set sck [curctx sock]
return [tnda get "rhost/$::netname($sck)/$u"]
}
-proc uid2host {sck u} {
+proc uid2host {u} {
+ set sck [curctx sock]
return [tnda get "vhost/$::netname($sck)/$u"]
}
-proc uid2ident {sck u} {
+proc uid2ident {u} {
+ set sck [curctx sock]
return [tnda get "ident/$::netname($sck)/$u"]
}
-proc nick2host {sck nick} {
+proc nick2host {nick} {
+ set sck [curctx sock]
return [tnda get "vhost/$::netname($sck)/[nick2uid $netname $nick]"]
}
-proc nick2ident {sck nick} {
+proc nick2ident {nick} {
+ set sck [curctx sock]
return [tnda get "ident/$::netname($sck)/[nick2uid $netname $nick]"]
}
-proc nick2rhost {sck nick} {
+proc nick2rhost {nick} {
+ set sck [curctx sock]
return [tnda get "rhost/$::netname($sck)/[nick2uid $netname $nick]"]
}
-proc nick2ipaddr {sck nick} {
+proc nick2ipaddr {nick} {
+ set sck [curctx sock]
return [tnda get "ipaddr/$::netname($sck)/[nick2uid $netname $nick]"]
}
-proc getts {sck chan} {
+proc getts {chan} {
+ set sck [curctx sock]
return [tnda get "channels/$::netname($sck)/[ndaenc $chan]/ts"]
}
-proc getpfx {sck chan nick} {
+proc getpfx {chan nick} {
+ set sck [curctx sock]
return [tnda get "channels/$::netname($sck)/[ndaenc $chan]/modes/[nick2uid $netname $nick]"]
}
-proc getupfx {sck chan u} {
+proc getupfx {chan u} {
return [tnda get "channels/$::netname($sck)/[ndaenc $chan]/modes/$u"]
+ set sck [curctx sock]
}
-proc getpfxchars {sck modes} {
+proc getpfxchars {modes} {
+ set sck [curctx sock]
set o ""
foreach {c} [split $modes {}] {
append o [nda get "netinfo/$::netname($sck)/prefix/$c"]
}
return $o
}
-proc getmetadata {sck nick metadatum} {
+proc getmetadata {nick metadatum} {
+ set sck [curctx sock]
return [tnda get "metadata/$::netname($sck)/[nick2uid $netname $nick]/[ndcenc $metadatum]"]
}
-proc getcertfp {sck nick} {
+proc getcertfp {nick} {
+ set sck [curctx sock]
return [tnda get "certfps/$::netname($sck)/[nick2uid $netname $nick]"]
}
@@ -76,11 +92,13 @@ putcmdlog "down $mc $f $t $p $n"
tnda set "channels/$n/$chan/modes/$p" [string map [list $mc ""] [tnda get "channels/$n/$chan/modes/$p"]]
}
-proc uid2intclient {sck u} {
+proc uid2intclient {u} {
+ set sck [curctx sock]
return [tnda get "intclient/$::netname($sck)/$u"]
}
-proc getfreeuid {sck} {
+proc getfreeuid {} {
+ set sck [curctx sock]
set work 1
set cns [list]
foreach {_ cnum} [tnda get "intclient/$::netname($sck)"] {lappend cns $cnum}
diff --git a/core/0003-fireegl-cron.tcl b/core/0003-fireegl-cron.tcl
@@ -0,0 +1,322 @@
+# cron -- A cron-like scheduler for scripts.
+
+# Copyright (C) 2010 Tcldrop Development Team <Tcldrop-Dev>
+
+# $Id$
+
+# Usage:
+#
+# cron valid $cron
+# Returns 1 if the cron format is valid, 0 otherwise.
+# cron parse $cron
+# Takes a standard cron time format and returns a dict containing all the possible minutes/hours/days/months/weekdays.
+# cron match $dict
+# Takes the dict returned from parse and returns 1 if the current time/date matches, 0 otherwise.
+# crontab add $cron $command ...
+# Add a new crontab, where $cron is a standard cron time format, and $command is the command to run when there's a match. Returns an ID for the new crontab.
+# crontab remove $id
+# Removes a crontab by ID.
+# crond start
+# Starts the 1-minute loop necessary for running the crontab commands.
+# Note: It's started automatically when a crontab is added.
+# crond stop
+# Stops the 1-minute loop.
+# Note: It's stopped automatically when all the crontabs are removed.
+
+# For the cron syntax, see "man 5 crontab".
+
+namespace eval ::cron {
+ package provide cron 1.0
+ variable IDCount
+ if {![info exists IDCount]} { variable IDCount 0 }
+ variable TimerID
+ if {![info exists TimerID]} { variable TimerID {} }
+ namespace export cron crontab crond
+ namespace ensemble create -command cron -subcommands [list match valid parse add remove start stop]
+ namespace ensemble create -command crontab -subcommands [list add remove]
+ namespace ensemble create -command crond -subcommands [list start stop]
+}
+
+# parses $cron and returns a dict containing all the minutes/hours/days/months/weekdays specified by $cron
+# Example:
+# input: 50-60/2 */4,21 09/2 7-9,december 7-4
+# result: minutes {0 50 52 54 56 58} hours {0 4 8 12 16 20 21} days {9 11 13 15 17 19 21 23 25 27 29 31} months {7 8 9 12} weekdays {0 1 2 3 4}
+proc ::cron::parse {cron} {
+ # Allow special strings:
+ switch -- $cron {
+ {@hourly} { set cron {0 * * * *} }
+ {@midnight} { set cron {0 0 * * *} }
+ {@daily} { set cron {0 1 * * *} }
+ {@weekly} { set cron {0 0 * * 0} }
+ {@monthly} { set cron {0 0 1 * *} }
+ {@yearly} - {@annually} { set cron {0 0 1 1 *} }
+ {@reboot} { return -code error {@reboot not supported.} }
+ }
+ foreach info {{minutes 0 59} {hours 0 23} {days 1 31} {months 1 12} {weekdays 0 6}} element $cron {
+ lassign $info name min max
+ dict set times $name [list]
+ # Calls parse_element to turn the cron-syntax into one we can more generically deal with:
+ foreach element [parse_element $element $name] {
+ lassign $element skip start end
+ if {$end eq {}} {
+ # Set the end to the highest allowable.
+ set end $max
+ # Use [scan] to remove any leading 0's (zeros):
+ } elseif {![scan $end {%d} end]} {
+ # parse_element should've complained about this, but just in case:
+ return -code error "\"$end\" is invalid. (Only decimal integer values are allowed.)"
+ } elseif {$end < $min || $end > ($max + 1)} {
+ return -code error "$end is outside the allowed range for ${name}: $min-$max"
+ }
+ if {$start eq {}} {
+ # Set the start to the lowest allowable.
+ set start $min
+ # Use [scan] to remove any leading 0's (zeros):
+ } elseif {![scan $start {%d} start]} {
+ # parse_element should've complained about this, but just in case:
+ return -code error "\"$start\" is invalid. (Only decimal integer values are allowed.)"
+ } elseif {$start < $min || $start > ($max + 1)} {
+ return -code error "$start is outside the allowed range for ${name}: $min-$max"
+ } elseif {$start == ($max + 1)} {
+ # If, for example, the start (and possibly the end) is 7 for the weekday, we'll make it/them 0:
+ set start $min
+ if {$end == ($max + 1)} { set end $min }
+ # Note: Specifying 0-7 will still mean every day of the week.
+ }
+ # Generate the list of possible values:
+ set count $start
+ while {$count <= $end} {
+ if {$count == ($max + 1)} {
+ # If we landed on $max + 1, we set it as $min and break the loop.
+ # This makes 60 become 0 for minutes, 24 becomes 0 for hours, 32 becomes 1 for days, 13 becomes 1 for months, and 7 becomes 0 for weekdays..
+ dict lappend times $name $min
+ break
+ }
+ dict lappend times $name $count
+ incr count $skip
+ }
+ }
+ # Remove duplicates:
+ dict set times $name [lsort -unique -integer [dict get $times $name]]
+ }
+ return $times
+}
+
+# Used by [parse]
+# Parses a single cron element, returning {{skip start end} ...}
+# skip = the skip/step value (defaults to 1)
+# start = the start of the range (may not be specified)
+# end = the end of the range (may not be specified)
+proc ::cron::parse_element {element {name {}}} {
+ set retval [list]
+ foreach element [split $element {,;:|&}] {
+ if {$element eq {*}} {
+ # Example: *
+ lappend retval [list 1]
+ } elseif {[string is digit -strict $element]} {
+ # Example: 9
+ lappend retval [list 1 $element $element]
+ } elseif {[regexp -- {^(\d+)\-(\d+)$} $element -> from to]} {
+ # Example: 3-9
+ lappend retval [list 1 $from $to]
+ } elseif {[regexp -- {^\*/(\d+)$} $element -> div] && $div >= 1} {
+ # Example: */2
+ lappend retval [list $div]
+ } elseif {[regexp -- {^(\d+)\-(\d+)/(\d*)$} $element -> from to div]} {
+ # Example: 3-9/2
+ lappend retval [list $div $from $to]
+ } elseif {[regexp -- {^(\d+)/(\d*)$} $element -> from div] && $div >= 1} {
+ # Example: 9/2
+ lappend retval [list $div $from]
+ } elseif {[string trim $element] ne {}} {
+ # Ignore ""
+ # Try to deal with names for days/months (ranges and skip/step are not supported in this case):
+ switch -- $name {
+ {days} {
+ switch -nocase -- $element {
+ {sun} - {sunday} { set element 0 }
+ {mon} - {monday} { set element 1 }
+ {tue} - {tuesday} { set element 2 }
+ {wed} - {wednesday} { set element 3 }
+ {thu} - {thursday} { set element 4 }
+ {fri} - {friday} { set element 5 }
+ {sat} - {saturday} { set element 6 }
+ {default} { return -code error "Failed to process: $element" }
+ }
+ }
+ {months} {
+ switch -nocase -- $element {
+ {jan} - {january} { set element 1 }
+ {feb} - {february} { set element 2 }
+ {mar} - {march} { set element 3 }
+ {apr} - {april} { set element 4 }
+ {may} { set element 5 }
+ {jun} - {june} { set element 6 }
+ {jul} - {july} { set element 7 }
+ {aug} - {august} { set element 8 }
+ {sep} - {september} { set element 9 }
+ {oct} - {october} { set element 10 }
+ {nov} - {november} { set element 11 }
+ {dec} - {december} { set element 12 }
+ {default} { return -code error "Failed to process: $element" }
+ }
+ }
+ {} - {default} { return -code error "Failed to process: $element" }
+ }
+ lappend retval [list 1 $element $element]
+ }
+ }
+ # Return the lists of skips/ranges we built up, or return {1} which means a skip of 1 and the full range.
+ if {[llength $retval]} { return $retval } else { list 1 }
+}
+
+# Takes the dict given by the output of [parse] and returns 1 if the current time/date is a match, else 0.
+proc ::cron::match {dict} {
+ lassign [clock format [clock seconds] -format {%M %k %e %N %w}] minute hour day month dayofweek
+ if {[scan $minute {%d}] in [dict get $dict minutes] && $hour in [dict get $dict hours] && $month in [dict get $dict months] && ($dayofweek in [dict get $dict weekdays] || $day in [dict get $dict days])} { return 1 } else { return 0 }
+}
+
+# Checks to see if the supplied cron is valid:
+proc ::cron::valid {cron} {
+ # This RE consists of 5 instances of the same basic RE. Each instance has
+ # "\d+" substituted for a RE that validates the number sequence associated
+ # with that instance.
+ #
+ # Base Regex, explained:
+ # Match any number of comma separated items if there are any:
+ # (0*\d+|\*)(-0*\d+)?(/\d+)?,)*
+ # Match the last item in this instance:
+ # (0*\d+|\*)(-0*\d+)?(/\d+)?\s
+ regexp -expanded -- {
+ # minute (0-59) - ([0-9]|[1-5][0-9])
+ ^((0*([0-9]|[1-5][0-9])|\*)(-0*([0-9]|[1-5][0-9]))?(/\d+)?,)*
+ (0*([0-9]|[1-5][0-9])|\*)(-0*([0-9]|[1-5][0-9]))?(/\d+)?\s
+ # hour (0-23) - ([0-9]|1[0-9]|2[0-3])
+ ((0*([0-9]|1[0-9]|2[0-3])|\*)(-0*([0-9]|1[0-9]|2[0-3]))?(/\d+)?,)*
+ (0*([0-9]|1[0-9]|2[0-3])|\*)(-0*([0-9]|1[0-9]|2[0-3]))?(/\d+)?\s
+ # day of month (1-31) - ([1-9]|[12][0-9]3[01])
+ ((0*([1-9]|[12][0-9]3[01])|\*)(-0*([1-9]|[12][0-9]3[01]))?(/\d+)?,)*
+ (0*([1-9]|[12][0-9]3[01])|\*)(-0*([1-9]|[12][0-9]3[01]))?(/\d+)?\s
+ # month (1-12) - ([1-9]|1[0-2])
+ ((0*([1-9]|1[0-2])|\*)(-0*([1-9]|1[0-2]))?(/\d+)?,)*
+ (0*([1-9]|1[0-2])|\*)(-0*([1-9]|1[0-2]))?(/\d+)?\s
+ # day of week (0-7) - [0-7]
+ ((0*[0-7]|\*)(-0*[0-7])?(/\d+)?,)*
+ (0*[0-7]|\*)(-0*[0-7])?(/\d+)?$
+ } $cron
+}
+
+# Creates a new crontab which will run $args (the script) whenever the current time/date matches,
+# returns an identifier which can be used to remove it.
+proc ::cron::add {cron args} {
+ if {[llength $args]} {
+ variable IDCount
+ variable crontabs
+ dict set crontabs [incr IDCount] [dict create cron [parse $cron] command $args]
+ # Start the 1-minute loop:
+ start
+ return $IDCount
+ }
+}
+
+# Removes a crontab:
+proc ::cron::remove {id} {
+ variable crontabs
+ if {[dict exists $crontabs $id]} {
+ dict unset crontabs $id
+ if {[dict size $crontabs] == 0} {
+ # Stop the 1-minute loop if there aren't any crontabs set.
+ stop
+ }
+ }
+}
+
+# This is the 1-minute looping proc, it processes all the matching crontabs for this minute:
+proc ::cron::DoCron {} {
+ # Start another after timer to run this proc again at the start of the next minute + 1 second + 17ms to 126ms:
+ variable TimerID [after [expr { 60000 - ([clock milliseconds] % 60000) + 1017 + int(rand() * 127) }] [namespace code DoCron]]
+ # Run all the crontabs that match for this minute:
+ variable crontabs
+ set count 231
+ dict for {id info} $crontabs {
+ if {[match [dict get $info cron]]} {
+ # Run this command 16 to 256ms from now..
+ # (Trying to make each command in this batch run 16ms apart.)
+ after [expr { 16 + ([incr count 16] % 247) }] [dict get $info command]
+ }
+ }
+ # Notes and logic behind the weird expr's:
+ # The extra 1 second added to the 1-minute loop is to avoid any issue with leap seconds...
+ # If an extra second is added due to leap seconds,
+ # the loop would start at the 59th second of the minute it already did.
+ # (I think, I don't know this for sure.)
+ #
+ # Example:
+ # An after timer is started at 23:59:00 to run 1000ms in the future.
+ # If a leap-second is added, when the script runs after 1000ms is up
+ # it will then be 23:59:59 when the script does a [clock format].
+ # (Somebody correct me if I'm wrong please.)
+ # I may be off by 1 minute.. If the leap second is added at 00:00:00,
+ # the script, when run, would see the time as 00:00:59.
+ #
+ # The extra 16ms between running the commands is so they don't run
+ # all at once, causing the process to use a lot of CPU-time in a short
+ # amount of time. If they're 16ms apart, it spreads the load out.
+ # 16ms, on Windows XP at least, is how often a process gets its share of the CPU.
+ #
+ # There's no good reason for the rand(). =P
+ #
+ # The effect of all this, is that the command scripts will run at most 1.4 seconds into the minute.
+}
+
+# Starts the 1-minute loop if it's not already running:
+proc ::cron::start {} {
+ variable TimerID
+ if {$TimerID eq {}} {
+ variable TimerID [after [expr { 60000 - ([clock milliseconds] % 60000) + 1017 + int(rand() * 127) }] [namespace code DoCron]]
+ }
+}
+
+# Stops the 1-minute loop:
+proc ::cron::stop {} {
+ variable TimerID
+ after cancel $TimerID
+ variable TimerID {}
+}
+
+# The rest is just used for testing purposes:
+
+# field allowed values
+# ----- --------------
+# minute 0-59
+# hour 0-23
+# day of month 1-31
+# month 1-12 (or names, see below)
+# day of week 0-7 (0 or 7 is Sun, or use names)
+
+if {0} {
+ namespace eval ::cron {
+ puts "now: [clock format [clock seconds] -format {%M %H %d %m %w}]"
+ # minute hour day month weekday
+ set testval "50-60/2;09 */4,21 09/2 7-9,december *"
+ #set testval $argv
+ puts "cron input: $testval"
+ puts "parse result: [set parseresult [::cron::parse $testval]]"
+ puts "match result: [::cron::match $parseresult]"
+ puts "parse time: [time { ::cron::parse $testval } 10000]"
+ puts "match time: [time { ::cron::match $parseresult } 10000]"
+ set matchmax [dict create minutes {0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59} hours {0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23} days {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31} months {1 2 3 4 5 6 7 8 9 10 11 12} weekdays {0 1 2 3 4 5 6}]
+ puts "match time (max): [time { ::cron::match $matchmax } 10000]"
+ set matchmin [dict create minutes {} hours {} days {} months {} weekdays {}]
+ puts "match time (min): [time { ::cron::match $matchmin } 10000]"
+ add {*/2} puts test
+ }
+ after 999999 [list set ::forever 1]
+ vwait ::forever
+}
+
+puts stdout "fireegl was here"
+namespace eval cron {
+ namespace export *
+ namespace ensemble create
+}
diff --git a/core/0004-hashing.tcl b/core/0004-hashing.tcl
@@ -0,0 +1,63 @@
+#! /usr/bin/env tclsh
+
+# Yea, another password manager. "Password--" it's called, because it's entirely stateless.
+# Just takes a master password, a protocol, and a site, and spits out a password.
+
+#
+# This file is part of the password-- distribution (https://github.com/xxxx or http://xxx.github.io).
+# Copyright (c) 2016 Ellenor Malik, legal name "Jack Dennis Johnson". All rights reserved.
+#
+# This file is free software - you may distribute it under the M.I.T. license.
+# If included with GPL'd software, this file is instead available under the terms of
+# the GPL, of the version relevant to the whole.
+# Permission is hereby granted, free of charge, to any person obtaining a copy
+# of this software and associated documentation files (the "Software"), to deal
+# in the Software without restriction, including without limitation the rights
+# to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+# copies of the Software, and to permit persons to whom the Software is
+# furnished to do so, subject to the following conditions:
+#
+# The above copyright notice and this permission notice shall be included in
+# all copies or substantial portions of the Software.
+#
+# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+# IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+# FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+# AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+# LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+# OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN
+# THE SOFTWARE.
+
+package require Expect
+package require base64
+package require aes
+package require sha256
+
+proc pad {origlen {mult 16}} {
+ set next [expr $origlen/$mult+1]
+ set nextl [expr ${next}*${mult}]
+ set padlen [expr ${nextl}-${origlen}]
+ return $padlen
+}
+
+proc encrypt {site pass} {
+ set inited [::aes::Init ecb [::sha2::sha256 -bin -- [join [list $site $pass] ":"]] "aaaaaaaaaaaaaaaa"]
+ set padout [pad [string length $site]]
+ append site [string repeat \0 $padout]
+ set encd [::aes::Encrypt $inited [::sha2::sha256 -bin -- $pass]]
+ ::aes::Final $inited
+ return [encrypt-v1 $site $encd]
+}
+
+proc encrypt-v1 {site pass} {
+ set inited [::aes::Init ecb [::sha2::sha256 -bin -- $pass] "aaaaaaaaaaaaaaaa"]
+ set padout [pad [string length $site]]
+ append site [string repeat \0 $padout]
+ set encd [::aes::Encrypt $inited $site]
+ ::aes::Final $inited
+ return $encd
+}
+
+proc pwhash.SSHA256 {pass {site "a"}} {
+ return [format "SSHA256/%s/%s" $site [string map {/ - + _ = {}} [::base64::encode -maxlen 0 -wrapchar "" [encrypt $site $pass]]]]
+}
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} {
@@ -21,6 +22,7 @@ proc mknetwork {headlines block} {
set pass [dict get $block pass]
set host [dict get $block host]
set port [dict get $block port]
+ set isupport [dict get $block isupport]
set servername [lindex $headlines 1]
set netname [lindex $headlines 0]
if {[catch {set ::sock($netname)} result] == 0} {
@@ -44,10 +46,64 @@ proc mknetwork {headlines block} {
# safe defaults, will cover charybdis and chatircd
tnda set "netinfo/$netname/prefix" [list @ o % h + v]
}
+ if {[dict exists $block type]} {
+ tnda set "netinfo/$netname/type" [dict get $block type]
+ } { tnda set "netinfo/$netname/type" norm }
+ if {[string length $isupport] > 0} {
+ foreach {tok} [split $isupport " "] {
+ foreach {key val} [split $tok "="] {
+ if {$key == "PREFIX"} {
+ if {[tnda get "netinfo/$netname/pfxissjoin"] == 1} {continue}
+ set v [string range $val 1 end]
+ set mod [split $v ")"]
+ set modechar [split [lindex $mod 1] {}]
+ set modepref [split [lindex $mod 0] {}]
+ foreach {c} $modechar {x} $modepref {
+ tnda set "netinfo/$netname/prefix/$c" $x
+ }
+ foreach {x} $modechar {c} $modepref {
+ tnda set "netinfo/$netname/pfxchar/$c" $x
+ }
+ } elseif {$key == "SJOIN"} {
+ tnda set "netinfo/$netname/pfxissjoin" 1
+ set v [string range $val 1 end]
+ set mod [split $v ")"]
+ set modechar [split [lindex $mod 1] {}]
+ set modepref [split [lindex $mod 0] {}]
+ foreach {c} $modechar {x} $modepref {
+ tnda set "netinfo/$netname/prefix/$c" $x
+ }
+ foreach {x} $modechar {c} $modepref {
+ tnda set "netinfo/$netname/pfxchar/$c" $x
+ }
+ } elseif {$key == "CHANMODES"} {
+ set spt [split $val ","]
+ tnda set "netinfo/$netname/chmban" [lindex $spt 0]
+ tnda set "netinfo/$netname/chmparm" [format "%s%s" [lindex $spt 0] [lindex $spt 1]]
+ tnda set "netinfo/$netname/chmpartparm" [lindex $spt 2]
+ tnda set "netinfo/$netname/chmnoparm" [lindex $spt 3]
+ } else {
+ tnda set "netinfo/$netname/isupport/[ndaenc $key]" $val
+ }
+ }
+ }
+ }
# open a connection
set socke [connect $host $port [list $proto irc-main]]
after 500 $proto login $socke $numeric $pass $netname $servername
llbind - dead - $socke [list after 5000 [list mknetwork $headlines $block]]
+ foreach {def} {
+ protectop protecthalfop protectvoice operit autoop autohalfop autovoice bitch halfbitch voicebitch
+ } {
+ setudef flag $def
+ }
+ tnda set "netinfo/$netname/crontab" [cron add "* * * * *" eval [concat firellmbind $socke time - {[clock format [clock seconds] -format "%M %H %d %m %Y"]} \
+ {[clock format [clock seconds] -format "%M"]} \
+ {[clock format [clock seconds] -format "%H"]} \
+ {[clock format [clock seconds] -format "%d"]} \
+ {[clock format [clock seconds] -format "%m"]} \
+ {[clock format [clock seconds] -format "%Y"]} \
+ ]]
# store it up
# postblock network $headlines $block
}
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" {}]
@@ -31,7 +31,7 @@ proc ::ts6::b64d {numb} {
}
proc putl {args} {
-# puts stdout [join $args " "]
+ puts stdout [join $args " "]
puts {*}$args
}
@@ -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]
@@ -149,6 +149,9 @@ proc ::ts6::part {sck uid targ msg} {
set sendnn [string repeat "A" [expr {6-[string length $sendid]}]]
append sendnn $sendid
putl $sck [format ":%s%s PART %s :%s" $sid $sendnn $targ $msg]
+ set chan [ndaenc $targ]
+ tnda set "userchan/$::netname($sck)/$sid$sendnn/$chan" 0
+ tnda set "channels/$::netname($sck)/$chan/status/[lindex $comd 0]" ""
}
proc ::ts6::quit {sck uid msg} {
@@ -200,7 +203,24 @@ proc ::ts6::putmode {sck uid targ mode {parm ""} {ts ""}} {
set sendid [::ts6::b64e $uid]
set sendnn [string repeat "A" [expr {6-[string length $sendid]}]]
append sendnn $sendid
- putl $sck [format ":%s%s TMODE %s %s %s %s" $sid $sendnn $ts $targ $mode $parm]
+ putl $sck [format ":%s" [set com [format "%s%s TMODE %s %s %s %s" $sid $sendnn $ts $targ $mode $parm]]]
+ set comd [split $com " "]
+ set ctr 4
+ set state 1
+ foreach {c} [split $mode {}] {
+ if {$c == "+"} {
+ set state 1
+ } elseif {$c == "-"} {
+ set state 0
+ } elseif {[string match [format "*%s*" $c] [tnda get "netinfo/$::netname($sck)/chmparm"]] || ($state&&[string match [format "*%s*" $c] [tnda get "netinfo/$::netname($sck)/chmpartparm"]])} {
+ [expr {$state?"::ts6::checkop":"::ts6::checkdeop"}] [lindex $comd 0] [lindex $comd 3] [format "%s%s" [expr {$state?"+":"-"}] $c] [lindex $comd [incr ctr]]
+# firellmbind $sck mode - [format "%s %s%s" [string tolower [lindex $comd 3]] [expr {$state ? "+" : "-"}] $c] [lindex $comd 0] [lindex $comd 3] [format "%s%s" [expr {$state?"+":"-"}] $c] [lindex $comd [incr ctr]]
+ } else {
+ [expr {$state?"::ts6::checkop":"::ts6::checkdeop"}] [lindex $comd 0] [lindex $comd 3] [format "%s%s" [expr {$state?"+":"-"}] $c] [lindex $comd [incr ctr]]
+# firellmbind $sck mode - [format "%s %s%s" [string tolower [lindex $comd 3]] [expr {$state ? "+" : "-"}] $c] [lindex $comd 0] [lindex $comd 3] [format "%s%s" [expr {$state?"+":"-"}] $c] ""
+# firellmbind $sck mode "-" [expr {$state ? "+" : "-"}] $c [lindex $comd 0] [lindex $comd 3] ""
+ }
+ }
}
proc ::ts6::sendencap {sck uid targ args} {
@@ -227,6 +247,9 @@ proc ::ts6::putjoin {sck uid targ {ts ""}} {
set sendnn [string repeat "A" [expr {6-[string length $sendid]}]]
append sendnn $sendid
putl $sck [format ":%s SJOIN %s %s + :%s%s" $sid $ts $targ $sid $sendnn]
+ set chan [ndaenc $targ]
+ tnda set "userchan/$::netname($sck)/$sid$sendnn/$chan" 1
+# tnda set "channels/$::netname($sck)/$chan/status/[lindex $comd 0]" ""
}
proc ::ts6::validchan {sck channelname} {
@@ -253,7 +276,7 @@ proc ::ts6::quitstorm {sck sid comment {doinit 1}} {
proc ::ts6::irc-main {sck} {
global sid sock socksid
if {[eof $sck]} {
- putl stdout "We're dead, folks."
+ puts stdout "We're dead, folks."
# firellbind $sck evnt "-" "ts6.dead" $::netname($sck) $sck
firellbind $sck evnt "-" "dead" $::netname($sck) $sck
firellbind - evnt "-" "dead" $sck $::netname($sck)
@@ -271,9 +294,15 @@ proc ::ts6::irc-main {sck} {
if {$gotsplitwhere != -1} {lappend comd $payload}
if {[lindex $comd 0] == "PING"} {putl $sck "PONG $::snames($sck) :$payload"}
if {[lindex $comd 0] == "SERVER"} {putl $sck "VERSION"}
+ if {$one == 1} {
+ set sourceof [lindex $comd 0]
+ set two 2
+ } { set sourceof ""
+ set two 1}
+ 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"
@@ -308,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)
@@ -327,7 +356,7 @@ proc ::ts6::irc-main {sck} {
tnda set "userchan/$::netname($sck)/$uidd/$chan" 0
}
- ::ts6::snote $sck F [format "!! NETSPLIT: %s (%s) has quit due to netsplit (%s: %s)" [tnda get "nick/$::netname($sck)/$uidd"] $uidd [tnda get "servers/$::netname($sck)/[ndaenc $srv]/name"] [lindex $comd [expr {$one + 2}]]
+ ::ts6::snote $sck x [format "!! NETSPLIT: %s (%s) has quit due to netsplit (%s: %s)" [tnda get "nick/$::netname($sck)/$uidd"] $uidd [tnda get "servers/$::netname($sck)/[ndaenc $srv]/name"] [lindex $comd [expr {$one + 2}]]
tnda unset "login/$::netname($sck)/$uidd"
tnda unset "nick/$::netname($sck)/$uidd"
tnda set "oper/$::netname($sck)/$uidd" 0
@@ -374,6 +403,7 @@ proc ::ts6::irc-main {sck} {
}
} elseif {$key == "CHANMODES"} {
set spt [split $val ","]
+ tnda set "netinfo/$::netname($sck)/chmban" [lindex $spt 0]
tnda set "netinfo/$::netname($sck)/chmparm" [format "%s%s" [lindex $spt 0] [lindex $spt 1]]
tnda set "netinfo/$::netname($sck)/chmpartparm" [lindex $spt 2]
tnda set "netinfo/$::netname($sck)/chmnoparm" [lindex $spt 3]
@@ -387,12 +417,41 @@ proc ::ts6::irc-main {sck} {
"PRIVMSG" {
if {[::ts6::validchan $sck [lindex $comd 2]]} {
set client chan
- firellbind $sck pub "-" [string tolower [lindex [split $payload " "] 0]] [lindex $comd 2] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
- firellbind $sck evnt "-" "chanmsg" [lindex $comd 0] [lindex $comd 2] $payload
+ set words [split $payload " "]
+ set kword [lindex $words 0]
+ if {[string index $payload 0] == "\001"} {
+ set payload [string range $payload 1 end-1]
+ set words [split $payload " "]
+ set kword [lindex $words 0]
+ set payload [join [lrange $words 1 end] " "]
+ firellbind $sck ctcp - [string tolower $payload] [lindex $comd 0] [lindex $comd 2] $kword $payload
+ } {
+ set mpayload [join [lrange $words 1 end] " "]
+ firellbind $sck pub - [string tolower $payload] [lindex $comd 0] [lindex $comd 2] $mpayload
+ firellmbind $sck pubm - [string tolower $payload] [lindex $comd 0] [lindex $comd 2] $payload
+ }
+ #firellbind $sck notc "-" [string tolower [lindex [split $payload " "] 0]] [lindex $comd 2] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
+ #firellmbind $sck pnotcm $client [string tolower [lindex [split $payload " "] 0]] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
+# firellbind $sck pubnotc-m "-" [string tolower [lindex [split $payload " "] 0]] [lindex $comd 2] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
+ #firellbind $sck "evnt" "-" "channotc" [lindex $comd 0] [lindex $comd 2] $payload
} {
set client [tnda get "intclient/$::netname($sck)/[lindex $comd 2]"]
- firellbind $sck msg $client [string tolower [lindex [split $payload " "] 0]] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
- firellbind $sck "evnt" "-" "privmsg" [lindex $comd 0] [lindex $comd 2] $payload
+ set words [split $payload " "]
+ set kword [lindex $words 0]
+ if {[string index $payload 0] == "\001"} {
+ set payload [string range $payload 1 end-1]
+ set words [split $payload " "]
+ set kword [lindex $words 0]
+ set payload [join [lrange $words 1 end] " "]
+ firellbind $sck ctcp - [string tolower $kword] [lindex $comd 0] [% uid2nick [lindex $comd 2]] $kword $payload
+ } {
+ set mpayload [join [lrange $words 1 end] " "]
+ firellbind $sck msg $client [string tolower $kword] [lindex $comd 0] $mpayload
+ firellmbind $sck msgm $client [string tolower $payload] [lindex $comd 0] $payload
+ }
+ #firellbind $sck notc $client [string tolower [lindex [split $payload " "] 0]] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
+ #firellmbind $sck notcm $client [string tolower [lindex [split $payload " "] 0]] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
+ #firellbind $sck "evnt" "-" "privnotc" [lindex $comd 0] [lindex $comd 2] $payload
}
}
@@ -400,13 +459,33 @@ proc ::ts6::irc-main {sck} {
if {![tnda get "netinfo/$::netname($sck)/connected"]} {return}
if {[::ts6::validchan $sck [lindex $comd 2]]} {
set client chan
- firellbind $sck pubnotc "-" [string tolower [lindex [split $payload " "] 0]] [lindex $comd 2] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
+ if {[string index $payload 0] == "\001"} {
+ set payload [string range $payload 1 end-1]
+ set words [split $payload " "]
+ set kword [lindex $words 0]
+ set payload [join [lrange $words 1 end] " "]
+ firellbind $sck ctcr - [string tolower $payload] [lindex $comd 0] [lindex $comd 2] $kword $payload
+ } {
+ firellmbind $sck notc - [string tolower $payload] [lindex $comd 0] [lindex $comd 2] $payload
+ }
+ #firellbind $sck notc "-" [string tolower [lindex [split $payload " "] 0]] [lindex $comd 2] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
+ #firellmbind $sck pnotcm $client [string tolower [lindex [split $payload " "] 0]] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
# firellbind $sck pubnotc-m "-" [string tolower [lindex [split $payload " "] 0]] [lindex $comd 2] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
- firellbind $sck "evnt" "-" "channotc" [lindex $comd 0] [lindex $comd 2] $payload
+ #firellbind $sck "evnt" "-" "channotc" [lindex $comd 0] [lindex $comd 2] $payload
} {
set client [tnda get "intclient/$::netname($sck)/[lindex $comd 2]"]
- firellbind $sck notc $client [string tolower [lindex [split $payload " "] 0]] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
- firellbind $sck "evnt" "-" "privnotc" [lindex $comd 0] [lindex $comd 2] $payload
+ if {[string index $payload 0] == "\001"} {
+ set payload [string range $payload 1 end-1]
+ set words [split $payload " "]
+ set kword [lindex $words 0]
+ set payload [join [lrange $words 1 end] " "]
+ firellbind $sck ctcr - [string tolower $payload] [lindex $comd 0] [% uid2nick [lindex $comd 2]] $kword $payload
+ } {
+ firellmbind $sck notc - [string tolower $payload] [lindex $comd 0] [% uid2nick [lindex $comd 2]] $payload
+ }
+ #firellbind $sck notc $client [string tolower [lindex [split $payload " "] 0]] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
+ #firellmbind $sck notcm $client [string tolower [lindex [split $payload " "] 0]] [lindex $comd 0] [join [lrange [split $payload " "] 1 end] " "]
+ #firellbind $sck "evnt" "-" "privnotc" [lindex $comd 0] [lindex $comd 2] $payload
}
}
@@ -425,7 +504,8 @@ proc ::ts6::irc-main {sck} {
"JOIN" {
set chan [string map {/ [} [::base64::encode [string tolower [lindex $comd 3]]]]
if {""==[tnda get "channels/$::netname($sck)/$chan/ts"]} {firellbind $sck create "-" "-" [lindex $comd 3] [lindex $comd 0] $::netname($sck)}
- firellbind $sck join "-" "-" [lindex $comd 3] [lindex $comd 0] $::netname($sck)
+# firellbind $sck join "-" "-" [lindex $comd 3] [lindex $comd 0] $::netname($sck)
+ firellmbind $sck join - [format "%s %s!%s@%s" [lindex $comd 3] [% uid2nick [lindex $comd 0]] [% uid2ident [lindex $comd 0]] [% uid2host [lindex $comd 0]]] [lindex $comd 0] [lindex $comd 3]
tnda set "channels/$::netname($sck)/$chan/ts" [lindex $comd 2]
tnda set "userchan/$::netname($sck)/[lindex $comd 0]/$chan" 1
}
@@ -437,7 +517,9 @@ proc ::ts6::irc-main {sck} {
if {[lindex $comd 2] > [tnda get "channels/$::netname($sck)/$chan/ts"]} {return} ;# send it packing.
set type [lindex $comd 4]
foreach {mask} $adding {
- firellbind $sck mode - + $type [lindex $comd 0] [lindex $comd 3] $mask $::netname($sck)
+ ::ts6::checkop [lindex $comd 0] [lindex $comd 3] [format "%s%s" + $type] $mask
+ firellmbind $sck mode - [format "%s +%s" [lindex $comd 3] $type] [lindex $comd 0] [lindex $comd 3] "+$type" $mask
+ #+ $type [lindex $comd 0] [lindex $comd 3] $mask $::netname($sck)
}
}
@@ -450,9 +532,12 @@ proc ::ts6::irc-main {sck} {
} elseif {$c == "-"} {
set state 0
} elseif {[string match [format "*%s*" $c] [tnda get "netinfo/$::netname($sck)/chmparm"]] || ($state&&[string match [format "*%s*" $c] [tnda get "netinfo/$::netname($sck)/chmpartparm"]])} {
- firellbind $sck mode "-" [expr {$state ? "+" : "-"}] $c [lindex $comd 0] [lindex $comd 3] [lindex $comd [incr ctr]] $::netname($sck)
+ [expr {$state?"::ts6::checkop":"::ts6::checkdeop"}] [lindex $comd 0] [lindex $comd 3] [format "%s%s" [expr {$state?"+":"-"}] $c] [lindex $comd [incr ctr]]
+ firellmbind $sck mode - [format "%s %s%s" [string tolower [lindex $comd 3]] [expr {$state ? "+" : "-"}] $c] [lindex $comd 0] [lindex $comd 3] [format "%s%s" [expr {$state?"+":"-"}] $c] [lindex $comd [incr ctr]]
} else {
- firellbind $sck mode "-" [expr {$state ? "+" : "-"}] $c [lindex $comd 0] [lindex $comd 3] "" $::netname($sck)
+ [expr {$state?"::ts6::checkop":"::ts6::checkdeop"}] [lindex $comd 0] [lindex $comd 3] [format "%s%s" [expr {$state?"+":"-"}] $c] [lindex $comd [incr ctr]]
+ firellmbind $sck mode - [format "%s %s%s" [string tolower [lindex $comd 3]] [expr {$state ? "+" : "-"}] $c] [lindex $comd 0] [lindex $comd 3] [format "%s%s" [expr {$state?"+":"-"}] $c] ""
+# firellmbind $sck mode "-" [expr {$state ? "+" : "-"}] $c [lindex $comd 0] [lindex $comd 3] ""
}
}
}
@@ -461,10 +546,26 @@ proc ::ts6::irc-main {sck} {
set chan [ndaenc [lindex $comd 3]]
if {[string index [lindex $comd 4] 0] == "+"} {
set four 5
+ set ctr 4
if {[string match "*l*" [lindex $comd 4]]} {incr four}
if {[string match "*f*" [lindex $comd 4]]} {incr four}
if {[string match "*j*" [lindex $comd 4]]} {incr four}
if {[string match "*k*" [lindex $comd 4]]} {incr four}
+ foreach {c} [split [lindex $comd 4] {}] {
+ if {$c == "+"} {
+ set state 1
+ } elseif {$c == "-"} {
+ # _NOTREACHED
+ set state 0
+ } elseif {[string match [format "*%s*" $c] [tnda get "netinfo/$::netname($sck)/chmparm"]] || ($state&&[string match [format "*%s*" $c] [tnda get "netinfo/$::netname($sck)/chmpartparm"]])} {
+ [expr {$state?"::ts6::checkop":"::ts6::checkdeop"}] [lindex $comd 0] [lindex $comd 3] [format "%s%s" [expr {$state?"+":"-"}] $c] [lindex $comd [incr ctr]]
+ firellmbind $sck mode - [format "%s %s%s" [string tolower [lindex $comd 3]] [expr {$state ? "+" : "-"}] $c] [lindex $comd 0] [lindex $comd 3] [format "%s%s" [expr {$state?"+":"-"}] $c] [lindex $comd [incr ctr]]
+ } else {
+ [expr {$state?"::ts6::checkop":"::ts6::checkdeop"}] [lindex $comd 0] [lindex $comd 3] [format "%s%s" [expr {$state?"+":"-"}] $c] [lindex $comd [incr ctr]]
+ firellmbind $sck mode - [format "%s %s%s" [string tolower [lindex $comd 3]] [expr {$state ? "+" : "-"}] $c] [lindex $comd 0] [lindex $comd 3] [format "%s%s" [expr {$state?"+":"-"}] $c] ""
+# firellmbind $sck mode "-" [expr {$state ? "+" : "-"}] $c [lindex $comd 0] [lindex $comd 3] ""
+ }
+ }
} {
set four 4
}
@@ -485,12 +586,15 @@ 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]
- firellbind $sck join "-" "-" [lindex $comd 3] $un $::netname($sck)
+ 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
- if {""!=$uo} {tnda set "channels/$::netname($sck)/$chan/modes/$un" $uo
+ if {""!=$uo} {tnda set "channels/$::netname($sck)/$chan/status/$un" $uo
foreach {c} [split $uo {}] {
- firellbind $sck mode "-" + $c $un [lindex $comd 3] $un $::netname($sck)
+ ::ts6::checkop [lindex $comd 0] [lindex $comd 3] [format "%s%s" + $c] $un
+ firellmbind $sck mode - [format "%s +%s" [lindex $comd 3] $c] [lindex $comd 0] [lindex $comd 3] "+$c" $un
+ # firellbind $sck mode "-" + $c $un [lindex $comd 3] $un $::netname($sck)
}
}
}
@@ -498,16 +602,22 @@ proc ::ts6::irc-main {sck} {
}
"PART" {
- firellbind $sck part "-" "-" [lindex $comd 2] [lindex $comd 0] $::netname($sck)
+ set un [lindex $comd 0]
+ firellmbind $sck part - [format "%s %s!%s@%s" [lindex $comd 2] [% uid2nick $un] [% uid2ident $un] [% uid2host $un]] $un [lindex $comd 2] [lindex $comd 3]
+ firellbind $sck part "-" "-" [lindex $comd 2] [lindex $comd 0] [lindex $comd 3]
set chan [string map {/ [} [::base64::encode [string tolower [lindex $comd 2]]]]
tnda set "userchan/$::netname($sck)/[lindex $comd 0]/$chan" 0
+ tnda set "channels/$::netname($sck)/$chan/status/[lindex $comd 0]" ""
}
"KICK" {
- firellbind $sck part "-" "-" [lindex $comd 2] [lindex $comd 3] $::netname($sck)
+ firellbind $sck part "-" "-" [lindex $comd 2] [lindex $comd 3] [lindex $comd 4]
+ set chan [string map {/ [} [::base64::encode [string tolower [lindex $comd 2]]]]
+ tnda set "userchan/$::netname($sck)/[lindex $comd 3]/$chan" 0
}
"NICK" {
+ firellmbind $sck nick "-" [format "%s %s" "*" [lindex $comd 2]] [lindex $comd 0] "*" [lindex $comd 2]
tnda set "nick/$::netname($sck)/[lindex $comd 0]" [lindex $comd 2]
tnda set "ts/$::netname($sck)/[lindex $comd 0]" [lindex $comd 3]
}
@@ -589,11 +699,12 @@ 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)
tnda set "userchan/$::netname($sck)/[lindex $comd 0]/$chan" 0
+ tnda set "channels/$::netname($sck)/$chan/status/[lindex $comd 0]" ""
}
tnda unset "login/$::netname($sck)/[lindex $comd 0]"
@@ -628,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" {
@@ -687,8 +798,8 @@ proc ::ts6::login {sck {osid "42"} {password "link"} {servname "net"} {servernam
putl $sck "SERVER $servername 1 :chary.tcl for Eggdrop and related bots"
putl $sck "SVINFO 6 6 0 :[clock format [clock seconds] -format %s]"
putl $sck ":$num VERSION"
- llbind $sck mode - + ::ts6::checkop
- llbind $sck mode - - ::ts6::checkdeop
+# llbind $sck mode - "* +*" ::ts6::checkop
+# llbind $sck mode - "* -*" ::ts6::checkdeop
chan event $sck readable [list ::ts6::irc-main $sck]
}
@@ -710,6 +821,9 @@ proc ::ts6::intclient2uid {sck nick} {
proc ::ts6::uid2nick {sck u} {
return [tnda get "nick/$::netname($sck)/$u"]
}
+proc ::ts6::uid2rname {sck u} {
+ return [tnda get "rname/$::netname($sck)/$u"]
+}
proc ::ts6::uid2rhost {sck u} {
return [tnda get "rhost/$::netname($sck)/$u"]
}
@@ -735,10 +849,10 @@ proc ::ts6::getts {sck chan} {
return [tnda get "channels/$::netname($sck)/[ndaenc $chan]/ts"]
}
proc ::ts6::getpfx {sck chan nick} {
- return [tnda get "channels/$::netname($sck)/[ndaenc $chan]/modes/[::ts6::nick2uid $netname $nick]"]
+ return [tnda get "channels/$::netname($sck)/[ndaenc $chan]/status/[::ts6::nick2uid $netname $nick]"]
}
proc ::ts6::getupfx {sck chan u} {
- return [tnda get "channels/$::netname($sck)/[ndaenc $chan]/modes/$u"]
+ return [tnda get "channels/$::netname($sck)/[ndaenc $chan]/status/$u"]
}
proc ::ts6::getpfxchars {sck modes} {
set o ""
@@ -754,26 +868,71 @@ proc ::ts6::getcertfp {sck nick} {
return [tnda get "certfps/$::netname($sck)/[::ts6::nick2uid $netname $nick]"]
}
-proc ::ts6::checkop {mc s c p n} {
- set f $s
- set t $c
- if {[tnda get "netinfo/$n/pfxchar/$mc"]==""} {return}
-putcmdlog "up $mc $f $t $p $n"
+proc ::ts6::checkop {f t m p} {
+ set n [curctx net]
+ 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}
+putloglev d * "up $mc $f $t $p $n"
set chan [string map {/ [} [::base64::encode [string tolower $t]]]
- tnda set "channels/$n/$chan/modes/$p" [format {%s%s} [string map [list $mc ""] [tnda get "channels/$n/$chan/modes/$p"]] $mc]
+ tnda set "channels/$n/$chan/status/$p" [format {%s%s} [string map [list $mc ""] [tnda get "channels/$n/$chan/status/$p"]] $mc]
}
-proc ::ts6::checkdeop {mc s c p n} {
- set f $s
- set t $c
- if {[tnda get "netinfo/$n/pfxchar/$mc"]==""} {return}
-putcmdlog "down $mc $f $t $p $n"
+proc ::ts6::checkdeop {f t m p} {
+ set n [curctx net]
+ 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}
+putloglev d * "down $mc $f $t $p $n"
set chan [string map {/ [} [::base64::encode [string tolower $t]]]
- tnda set "channels/$n/$chan/modes/$p" [string map [list $mc ""] [tnda get "channels/$n/$chan/modes/$p"]]
+ tnda set "channels/$n/$chan/status/$p" [string map [list $mc ""] [tnda get "channels/$n/$chan/status/$p"]]
+}
+
+proc ::ts6::handlemode {from t mode parm} {
+ set n [curctx net]
+ set chan [string map {/ [} [::base64::encode [string tolower $t]]]
+ puts stdout [format ":%s MODE %s %s %s" $from $t $mode $parm]
+ if {[string index $mode 0] == "+"} {set state 1} {set state 0}
+ set mc [string index $mode 1]
+ if {$state} {
+ if {[lsearch -exact [split [tnda get "netinfo/$n/chmban"] {}] $mc] == -1} {tnda set "channels/$n/$chan/mode" [format {%s%s} [string map [list $mc ""] [tnda get "channels/$n/$chan/mode"]] $mc]}
+ if {$parm != ""} {
+ if {[lsearch -exact [split [tnda get "netinfo/$n/chmban"] {}] $mc] != -1} {
+ set ban [tnda get "channels/$n/$chan/modes/[ndcenc $mc]"]
+ lappend ban $parm
+ tnda set "channels/$n/$chan/modes/[ndcenc $mc]" $ban
+ } {
+ tnda set "channels/$n/$chan/modes/[ndcenc $mc]" $parm
+ }
+ }
+ } {
+ if {[lsearch -exact [split [tnda get "netinfo/$n/chmban"] {}] $mc] == -1} {tnda set "channels/$n/$chan/mode" [string map [list $mc ""] [tnda get "channels/$n/$chan/mode"]]}
+ if {$parm != "" || [lsearch -exact [split [tnda get "netinfo/$n/chmpartparm"] {}] $mc] != -1} {
+ if {[lsearch -exact [split [tnda get "netinfo/$n/chmban"] {}] $mc] != -1} {
+ set ban [tnda get "channels/$n/$chan/modes/[ndcenc $mc]"]
+ lappend ban $parm
+ tnda set "channels/$n/$chan/modes/[ndcenc $mc]" $ban
+ } {
+ if {$parm == ""} {
+ tnda unset "channels/$n/$chan/modes/[ndcenc $mc]"
+ } {
+ tnda set "channels/$n/$chan/modes/[ndcenc $mc]" $parm
+ }
+ }
+ }
+ }
+ puts stdout [format "Now, the state machine for $t looks like:"]
+ puts stdout [tnda get "channels/$n/$chan"]
+ puts stdout [tnda get "userchan/$n/$chan"]
}
-proc ::ts6::formprefix {sck nick} {
- return [format ":%s " $nick]
+proc ::ts6::putnow {sck intclient msg} {
+ if {$intclient != ""} {
+ set nick [% intclient2uid $intclient]
+ } {
+ set nick $sid($sck)
+ }
+ putl $sck [format ":%s %s" $nick $msg]
}
proc ::ts6::uid2intclient {sck u} {
return [tnda get "intclient/$::netname($sck)/$u"]
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,444 +0,0 @@
-#source chanserv.conf
-
-#llbind [curctx sock] mode "-" "+" bitchopcheck
-#llbind [curctx sock] mode "-" "-" protectopcheck
-#llbind [curctx sock] join "-" "-" autoopcheck
-
-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 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 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}]}
-
-set globctx ""
-set 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] == ""} {return} ; # silently crap out
- 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 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)
- }
- }
-}
-
-foreach {pname} [list putserv puthelp putquick putnow] {
- proc $pname {msg} {
- puts [curctx sock] [[curctx proto] formprefix [curctx sock] $msg]
- }
-}
-
-proc msgmt {from msg} {
- set handle [lindex $msg 0]
- set attr [lindex $msg 1]
- set chan [lindex $msg 2]
- [curctx proto] notice [curctx sock] 77 $from "$handle $attr $chan Matchattr result: [matchattr $handle $attr $chan]"
-}
-
-#llbind [curctx sock] msg 77 "matchattr" msgmt
-
-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]
- 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 {} {
- foreach {chan _} [nda get "regchan"] {
- lappend ret $chan
- }
- return $ret
-}
-
-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 {""==[nda get "usernames/$n"]} {return 0} {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"] {
- if {$nick == $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 [nda get "usernames/$nick/setuser/[ndaenc $datafield]/[ndaenc $dataval]"]
-}
-
-proc setuser {nick datafield {dataval "body"} val} {
- return [nda set "usernames/$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
-}
-
-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 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.
-proc bind {type flag text script} {
- set ctxsock [curctx sock]
- set ctxuser [curctx unum]
- return [llbind $ctxsock $type $ctxuser [list matchthenrun $ctxsock $ctxuser $flag $script]]
-}
-
-proc matchthenrun {sock user flags script args} {
- #setctx $sock
- foreach {a} $args {
- lappend script $a
- }
-# matchattr [uid2hand $user] $flags
- eval $script
-}
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.
diff --git a/main.tcl b/main.tcl
@@ -8,7 +8,7 @@ package require sha1
source b64.tcl
-proc pwhash {pass} {
+proc pwhash.SHA1 {pass} {
global b64
set hash [::sha1::sha1 -hex $pass]
return "SHA1/$hash"
@@ -90,7 +90,19 @@ if {[file exists services.db]} {
set globwd [pwd]
set gettext [list]
+proc outputbotnick {var no oper} {
+ upvar $var v
+ set v [curctx user]
+}
+
+proc showcontexts {var no oper} {
+ upvar $var v
+# puts stdout "curctx is [curctx unum]@[curctx net]"
+}
+
trace add variable nd [list write unset] [list save.db [format "%s/%s" [pwd] services.db]]
+trace add variable botnick [list read] [list outputbotnick]
+trace add variable globuctx [list read write] [list showcontexts]
#::tie::tie nd file services.db
diff --git a/modules/chanserv.disabled b/modules/chanserv.disabled
@@ -234,7 +234,7 @@ proc adduserchan {from msg} {
if {![string is integer $addlevel]} {return}
if {$addlevel > [nda get "regchan/$ndacname/levels/[tnda get "login/$::netname($::sock($::cs(netname)))/$from"]"]} {$::maintype notice $::sock($::cs(netname)) 77 $from "You can't do that; you're not the channel's Dave";return}
if {[nda get "regchan/$ndacname/levels/$adduser"] > [nda get "regchan/$ndacname/levels/[tnda get "login/$::netname($::sock($::cs(netname)))/$from"]"]} {$::maintype notice $::sock($::cs(netname)) 77 $from "You can't do that; the person you're changing the level of is more like Dave than you.";return}
- if {$adduser == [tnda get "login/$::netname($::sock($::cs(netname)))/$from"]} {$::maintype notice $::sock($::cs(netname)) 77 $from "You can't change your own level, even if you're downgrading. Sorreh :/$::netname($::sock($::cs(netname)))/";return}
+ if {$adduser == [tnda get "login/$::netname($::sock($::cs(netname)))/$from"]} {$::maintype notice $::sock($::cs(netname)) 77 $from "You can't change your own level, even if you're downgrading. Sorreh :/";return}
$::maintype notice $::sock($::cs(netname)) 77 $from "Guess what? :) User added."
nda set "regchan/$ndacname/levels/[string tolower $adduser]" $addlevel
}
diff --git a/modules/chanserv.tcl b/modules/chanserv.tcl
@@ -0,0 +1,68 @@
+# ChanServ for TclServ
+# 2018 09 28
+# Copyright ©2018CE AsterIRC
+# All rights reserved. This file is *reluctantly* under the GNU GPL; see
+# LICENSE in the project root for information.
+
+# -----------------//----------------
+# ChanServ for TclServ.
+# Version 0.9 - released some time in 2017, ChanServ 0.9 was for a time
+# AsterIRC's only channels service. It was pretty horrendous. Nevertheless,
+# it did its job valiantly.
+# This version's just gonna be a custom Tcl runner.
+
+blocktnd chanserv
+
+llbind - evnt - alive chanserv.connect
+set numversion 1
+
+proc chanserv.connect {arg} {
+ putlog [format "there are %s chanserv blocks" [set blocks [tnda get "openconf/[ndcenc chanserv]/blocks"]]]
+ for {set i 1} {$i < ($blocks + 1)} {incr i} {
+ if {[string tolower [lindex [tnda get [format "openconf/%s/hdr%s" [ndcenc chanserv] $i]] 0]] != [string tolower $arg]} {continue}
+ after 1000 [list chanserv.oneintro [tnda get [format "openconf/%s/hdr%s" [ndcenc chanserv] $i]] [tnda get [format "openconf/%s/n%s" [ndcenc chanserv] $i]]]
+ }
+}
+
+proc cs.confighandler {servicename defdbname headline block} {
+ set net [lindex $headline 0]
+ set nsock $::sock($net)
+ set servicename [format "%s.%s" $servicename [lindex $headline 1]]
+ dictassign $block nick nick ident ident host host modes modes 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]
+ setuctx $nick
+}
+
+proc chanserv.oneintro {headline block} {
+ cs.confighandler chanserv chanserv $headline $block
+ dictassign $headline net network
+ dictassign $block config eggconf nick nick ident username host my-hostname
+
+ bind time -|- "?0 * * * *" checkchannels
+ bind time -|- "?5 * * * *" checkchannels
+ bind time -|- "0 * * * *" checkchannels
+ bind time -|- "5 * * * *" checkchannels
+ setuctx $nick
+ mysrc $eggconf
+}
+
+proc checkchannels {a b c d e} {
+ set chans [channels]
+ foreach {c} $chans {
+ set inactive [channel get $c inactive]
+ if {!$inactive} {@@ putjoin $c}
+ }
+ foreach {chan on} [tnda get "userchan/[curctx net]/[curctx uid]"] {
+ if {$on} {
+ set inactive [channel get $c inactive]
+ if {$inactive} {@@ part $c "This channel is not active"}
+ }
+ }
+}
diff --git a/modules/debugserv.tcl b/modules/debugserv.tcl
@@ -40,7 +40,8 @@ proc debugserv.oneintro {headline block} {
set net [lindex $headline 0]
set nsock $::sock($net)
dictassign $block logchan logchan nick nick ident ident host host modes modes realname realname rehashprivs rehashprivs idcommand nspass nickserv nickserv nsserv nsserv \
- dnsconf dnsconf tclprivs tclprivs
+ dnsconf dnsconf dbname dbname
+ if {$dbname == ""} {set dbname debugserv}
tnda set "debugserv/$net/rehashprivs" $rehashprivs
tnda set "debugserv/$net/tclprivs" $tclprivs
tnda set "debugserv/$net/logchan" $logchan
@@ -65,7 +66,7 @@ proc debugserv.oneintro {headline block} {
if {[string first [debugserv.find6sid $net $nsserv] [% nick2uid $nickserv]] == 0} {
% privmsg $ourid $nickserv $nspass
} {
- % privmsg $ourid $logchan [gettext debugserv.impostornickserv $nickserv [$::nettype($net) nick2uid $n $nickserv] $nsserv [debugserv.find6sid $net $nsserv]]
+ % privmsg $ourid $logchan [gettext debugserv.impostornickserv $nickserv [% nick2uid $nickserv] $nsserv [debugserv.find6sid $net $nsserv]]
}
}
after 650 % putjoin $ourid $logchan
diff --git a/modules/quoteserv.tcl b/modules/quoteserv.tcl
@@ -49,7 +49,7 @@ proc quoteserv.oneintro {headline block} {
if {[string first [quoteserv.find6sid $net $nsserv] [% nick2uid $nickserv]] == 0} {
% privmsg $ourid $nickserv $nspass
} {
- % privmsg $ourid $logchan [gettext quoteserv.impostornickserv $nickserv [$::nettype($net) nick2uid $n $nickserv] $nsserv [quoteserv.find6sid $net $nsserv]]
+ % privmsg $ourid $logchan [gettext quoteserv.impostornickserv $nickserv [nick2uid $nickserv] $nsserv [quoteserv.find6sid $net $nsserv]]
}
}
after 650 % putjoin $ourid $logchan
@@ -130,14 +130,18 @@ proc quoteservdo {n chan from m} {
set ndacname [string map {/ [} [::base64::encode [string tolower [lindex $opara 0]]]]
set para [lrange $para 1 end]
if {![quoteservenabled [lindex $opara 0]]} {
- % privmsg [tnda get "quoteserv/[curctx net]/ourid"] $targ [gettext quoteserv.disabled $chan]
- return
- }
+ set disabled 1
+ } { set disabled 0}
} else {
set targ $chan
+ set disabled 0
}
switch -nocase -glob -- $subcmd {
"se*" {
+ if {$disabled} {
+ % privmsg [tnda get "quoteserv/[curctx net]/ourid"] $targ [gettext quoteserv.disabled $chan]
+ return
+ }
set ptn [format "*%s*" [join $para " "]]
set qts [quotesearch $chan $ptn]
if {[llength $qts] != 0} {
@@ -146,7 +150,11 @@ proc quoteservdo {n chan from m} {
% privmsg [tnda get "quoteserv/[curctx net]/ourid"] $targ [gettext quoteserv.noresults]
}
}
- "vi*1st*ma*" {
+ "vi*1*ma*" {
+ if {$disabled} {
+ % privmsg [tnda get "quoteserv/[curctx net]/ourid"] $targ [gettext quoteserv.disabled $chan]
+ return
+ }
set ptn [format "*%s*" [join $para " "]]
set qts [quotesearch $chan $ptn]
if {[llength $qts]} {
@@ -160,6 +168,10 @@ proc quoteservdo {n chan from m} {
}
}
"ad*" {
+ if {$disabled} {
+ % privmsg [tnda get "quoteserv/[curctx net]/ourid"] $targ [gettext quoteserv.disabled $chan]
+ return
+ }
set qt [join $para " "]
set qtn [expr {([llength [nda get "quoteserv/[curctx net]/quotes/$ndacname"]]/6)+1}]
nda set "quoteserv/[curctx net]/quotes/$ndacname/q$qtn" $qt
@@ -180,6 +192,10 @@ proc quoteservdo {n chan from m} {
}
}
"de*" {
+ if {$disabled} {
+ % privmsg [tnda get "quoteserv/[curctx net]/ourid"] $targ [gettext quoteserv.disabled $chan]
+ return
+ }
set qtn [lindex $para 0]
if {![string is integer $qtn]} {
% privmsg [tnda get "quoteserv/[curctx net]/ourid"] $targ [gettext quoteserv.usevalidint]
@@ -210,7 +226,7 @@ proc quoteservdo {n chan from m} {
}
}
"jo*" {
- set tochan [lindex $para 0]
+ set tochan $chan
if {[ismodebutnot $tochan $from v] || [operHasPrivilege [curctx net] $from [tnda get "quoteserv/[curctx net]/operflags"]]} {
quoteservjoin $tochan
} {
@@ -218,6 +234,10 @@ proc quoteservdo {n chan from m} {
}
}
"goa*" - "pa*" - "le*" {
+ if {$disabled} {
+ % privmsg [tnda get "quoteserv/[curctx net]/ourid"] $targ [gettext quoteserv.disabled $chan]
+ return
+ }
set tochan [lindex $para 0]
if {[ismodebutnot $tochan $from v] || [operHasPrivilege [curctx net] $from [tnda get "quoteserv/[curctx net]/operflags"]]} {
quoteservpart $tochan [format "(%s) %s!%s@%s" [tnda get "login/[curctx net]/$from"] [% uid2nick $from] [% uid2ident $from] [% uid2host $from]]
@@ -226,6 +246,10 @@ proc quoteservdo {n chan from m} {
}
}
"vi*" {
+ if {$disabled} {
+ % privmsg [tnda get "quoteserv/[curctx net]/ourid"] $targ [gettext quoteserv.disabled $chan]
+ return
+ }
set qtn [lindex $para 0]
if {![string is integer $qtn]} {% privmsg [tnda get "quoteserv/[curctx net]/ourid"] $targ [gettext quoteserv.usevalidint]}
set qt [nda get "quoteserv/[curctx net]/quotes/$ndacname/q$qtn"]
diff --git a/modules/weather.tcl b/modules/weather.tcl
@@ -49,7 +49,7 @@ proc weatherserv.oneintro {headline block} {
if {[string first [weatherserv.find6sid $net $nsserv] [% nick2uid $nickserv]] == 0} {
% privmsg $ourid $nickserv $nspass
} {
- % privmsg $ourid $logchan [gettext weatherserv.impostornickserv $nickserv [$::nettype($net) nick2uid $n $nickserv] $nsserv [weatherserv.find6sid $net $nsserv]]
+ % privmsg $ourid $logchan [gettext weatherserv.impostornickserv $nickserv [nick2uid $nickserv] $nsserv [weatherserv.find6sid $net $nsserv]]
}
}
after 650 [list % putjoin $ourid $logchan]
diff --git a/nda.tcl b/nda.tcl
@@ -66,6 +66,40 @@ namespace eval nda {
namespace ensemble create
}
+# alt API:
+namespace eval dbase {
+ proc ::dbase::get {args} {
+ global nd
+ if {[info exists nd] && ![catch {dict get $nd {*}$args} eee]} {return $eee} {return ""}
+ }
+
+ proc ::dbase::set {args} {
+ global nd
+ if {[lindex $args 1] == ""} {
+ return ""
+ }
+ return [dict set nd {*}$args]
+ }
+
+ proc ::dbase::lappend {args} {
+ global nd
+ if {[lindex $args 1] == ""} {
+ return ""
+ }
+ ::set orig [::dbase::get {*}[lrange $args 0 end-1]]
+ ::lappend orig [lindex $args end]
+ return [dict set nd {*}[lrange $args 0 end-1] $orig]
+ }
+
+ proc ::dbase::unset {args} {
+ global nd
+ return [dict unset nd {*}$args]
+ }
+
+ namespace export *
+ namespace ensemble create
+}
+
namespace eval tnda {
proc ::tnda::get {path} {
global tnd
diff --git a/services.conf.example b/services.conf.example
@@ -1,12 +1,14 @@
# TCLServ Config File
+# This is a valid Tcl script when sourced by TCLServ
-# needs prefix for ts6
+# needs prefix for ts6; this example is for irca. Give it the isupport from your ircd if you are running some other TS6.
network "pand" "services.invalid" {
host 127.0.0.1 port +6697
numeric 53
pass link
proto ts6
prefix {*~&@%+ yqaohv}
+ isupport "CHANMODES=beIM,k,flj,CDFQRTXcgimnprstu CHANLIMIT=&'#+\"1234567890:100 PREFIX=(yqaohv)*~&@%+ MAXLIST=beIM:100 MODES=4 NETWORK=Pandersticks STATUSMSG=@ PRIVILEGEMSG=@,.,qaohv SJOIN=(yqaohv)*~&@%+"
}
#old;
@@ -19,6 +21,7 @@ network "pand" "services.invalid" {
loadmodule debugserv
loadmodule quoteserv
+loadmodule chanserv
# module confs after here, load before here
@@ -30,18 +33,19 @@ debugserv "pand" {
modes +oiS
comment "Or +oiDS if you dont want it to hear channel convos"
comment "idcommand is obvious."
+ realname "Depanner"
nickserv "NickServ"
nsserv services.umbrellix.net
idcommand "IDENTIFY InvictusWAUS None"
}
-
-quoteserv "umb" {
+quoteserv "pand" {
logchan #services
nick QuoteServ
ident Quote
host Umbrellix/Special/TclServ/QuoteServ
modes +oiS
+ realname "Quotes Services"
comment "Or +oiDS if you dont want it to hear channel convos"
comment "NSPass can be a username space password, if your nickserv is an atheme nickserv."
nickserv "NickServ"
@@ -49,3 +53,17 @@ quoteserv "umb" {
idcommand "IDENTIFY InvictusWAUS 5467"
operflags "oper:quote,oper:admin"
}
+
+# Syntax for ChanServ's header is different.
+# Instead of just being network, it is network servicename.
+# This is because ChanServ is not ChanServ, but a script runner.
+# the config is referenced relative to the working directory when you
+# start TclServ.
+chanserv "pand" "ChanServ" {
+ nick ChanServ
+ ident Channel
+ host Services.Umbrellix.Net
+ modes +oiS
+ config chanserv.conf
+ realname "Channels Services"
+}
