31 |
variable rcsid {$Id$} |
variable rcsid {$Id$} |
32 |
package provide tcldrop::channels $version |
package provide tcldrop::channels $version |
33 |
# Initialize variables: |
# Initialize variables: |
|
variable Channels |
|
|
array set Channels {} |
|
34 |
variable Udefs |
variable Udefs |
35 |
array set Udefs {} |
array set Udefs {} |
36 |
# Export all the commands that should be available to 3rd-party scripters: |
# Export all the commands that should be available to 3rd-party scripters: |
37 |
namespace export channel channels loadchannels savechannels validchan setudef renudef deludef countchannels |
namespace export channel channels loadchannels savechannels validchan setudef renudef deludef countchannels |
38 |
|
# Set the default channel database module: |
39 |
|
::tcldrop::SetDefault channeldbs [list {arraydb}] |
40 |
} |
} |
41 |
|
|
42 |
# Set the internal defaults: |
# Set the internal defaults: |
|
::tcldrop::SetDefault chanfile {tcldrop.chan} |
|
43 |
::tcldrop::SetDefault force-expire 0 |
::tcldrop::SetDefault force-expire 0 |
44 |
::tcldrop::SetDefault share-greet 0 |
::tcldrop::SetDefault share-greet 0 |
45 |
::tcldrop::SetDefault use-info 1 |
::tcldrop::SetDefault use-info 1 |
71 |
} |
} |
72 |
|
|
73 |
proc ::tcldrop::channels::channel {command channel args} { |
proc ::tcldrop::channels::channel {command channel args} { |
74 |
variable Channels |
foreach a [binds channels channel] { |
75 |
set lowerchannel [string tolower $channel] |
foreach {type flags mask count proc} $a {} |
76 |
switch -- $command { |
if {[set lev [catch { $proc $command $channel $args } val]]} { |
77 |
{add} { |
putlog "Error in script: $proc: $val" |
78 |
if {[llength $args] > 1} { |
puterrlog "$::errorInfo" |
79 |
set options $args |
} |
80 |
} else { |
::tcldrop::countbind $type $mask $proc |
81 |
set options [lindex $args 0] |
if {![info exists retval]} { |
82 |
} |
set retlev $lev |
83 |
# Add the channel: |
set retval $val |
|
set Channels($lowerchannel) [list name $channel] |
|
|
# Call ourself again to set the options: |
|
|
channel set $channel $options |
|
|
} |
|
|
{set} { |
|
|
# In the case of "set" $args is already in the form we can use. |
|
|
set options $args |
|
|
array set chaninfo $Channels($lowerchannel) |
|
|
set setnext 0 |
|
|
foreach o $options { |
|
|
if {$setnext} { |
|
|
set setnext 0 |
|
|
switch -- $type { |
|
|
{int} { |
|
|
# Note, settings such as flood-chan are treated as int's. Hence the need for using split here: |
|
|
set chaninfo($name) [split $o {:{ }}] |
|
|
} |
|
|
{str} { set chaninfo($name) $o } |
|
|
{list} { lappend chaninfo($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 { |
|
|
{+} - {1} { set chaninfo($name) 1 } |
|
|
{-} - {0} { set chaninfo($name) 0 } |
|
|
{default} { |
|
|
# FixMe: Give an error. |
|
|
} |
|
|
} |
|
|
} |
|
|
{unknown} - {default} { |
|
|
# FixMe: Give an error. |
|
|
} |
|
|
} |
|
|
} else { |
|
|
switch -- [set type [UdefType [set name [string trimleft $o {+-}]]]] { |
|
|
{flag} { |
|
|
switch -- [string index $o 0] { |
|
|
{+} { set chaninfo($name) 1 } |
|
|
{-} { set chaninfo($name) 0 } |
|
|
{default} { |
|
|
# They must want to set it using a second arg... |
|
|
set setnext 1 |
|
|
} |
|
|
} |
|
|
} |
|
|
{int} - {str} - {list} { set setnext 1 } |
|
|
{unknown} - {default} { |
|
|
# FixMe: Give an error. |
|
|
} |
|
|
} |
|
|
} |
|
|
} |
|
|
set Channels($lowerchannel) [array get chaninfo] |
|
|
} |
|
|
{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 {[info exists Channels($lowerchannel)]} { |
|
|
return $Channels($lowerchannel) |
|
|
} else { |
|
|
return -code error "no such channel record: $channel" |
|
|
} |
|
|
} |
|
|
{get} { |
|
|
if {[info exists Channels($lowerchannel)]} { |
|
|
array set chaninfo $Channels($lowerchannel) |
|
|
if {[info exists chaninfo($args)]} { |
|
|
return $chaninfo($args) |
|
|
} else { |
|
|
return -code error "Unknown channel setting: $args" |
|
|
} |
|
|
} else { |
|
|
return -code error "no such channel record: $channel" |
|
|
} |
|
|
} |
|
|
{remove} { |
|
|
if {[info exists Channels($lowerchannel)]} { |
|
|
unset Channels($lowerchannel) |
|
|
} else { |
|
|
return -code error "no such channel record: $channel" |
|
|
} |
|
84 |
} |
} |
85 |
} |
} |
86 |
|
if {[info exists retval]} { |
87 |
|
return -code $retlev $retval |
88 |
|
} else { |
89 |
|
return -code error {No channel database module has been loaded.} |
90 |
|
} |
91 |
} |
} |
92 |
|
|
93 |
# Just like in Eggdrop, returns the list of channels. |
# Just like in Eggdrop, returns the list of channels. |
94 |
proc ::tcldrop::channels::channels {} { |
proc ::tcldrop::channels::channels {} { |
95 |
variable Channels |
foreach a [binds channels channels] { |
96 |
set channels {} |
foreach {type flags mask count proc} $a {} |
97 |
foreach c [array names Channels] { |
if {[set lev [catch { $proc } val]]} { |
98 |
array set chaninfo $Channels($c) |
putlog "Error in script: $proc: $val" |
99 |
lappend channels $chaninfo(name) |
puterrlog "$::errorInfo" |
100 |
|
} |
101 |
|
::tcldrop::countbind $type $mask $proc |
102 |
|
if {![info exists retval]} { |
103 |
|
set retlev $lev |
104 |
|
set retval $val |
105 |
|
} |
106 |
|
} |
107 |
|
if {[info exists retval]} { |
108 |
|
return -code $retlev $retval |
109 |
|
} else { |
110 |
|
return -code error {No channel database module has been loaded.} |
111 |
} |
} |
|
return $channels |
|
112 |
} |
} |
113 |
|
|
114 |
# This isn't from Eggdrop, but I'm providing it anyway: |
# This isn't from Eggdrop, but I'm providing it anyway: |
115 |
# Works just like [countusers], except this counts how many channels there are. |
# Works just like [countusers], except this counts how many channels there are. |
116 |
proc ::tcldrop::channels::countchannels {} { |
proc ::tcldrop::channels::countchannels {} { |
117 |
variable Channels |
foreach a [binds channels countchannels] { |
118 |
array size Channels |
foreach {type flags mask count proc} $a {} |
119 |
|
if {[set lev [catch { $proc } val]]} { |
120 |
|
putlog "Error in script: $proc: $val" |
121 |
|
puterrlog "$::errorInfo" |
122 |
|
} |
123 |
|
::tcldrop::countbind $type $mask $proc |
124 |
|
if {![info exists retval]} { |
125 |
|
set retlev $lev |
126 |
|
set retval $val |
127 |
|
} |
128 |
|
} |
129 |
|
if {[info exists retval]} { |
130 |
|
return -code $retlev $retval |
131 |
|
} else { |
132 |
|
return -code error {No channel database module has been loaded.} |
133 |
|
} |
134 |
} |
} |
135 |
|
|
136 |
# Saves the channel info to $chanfile: |
# Saves the channel info to $chanfile: |
137 |
proc ::tcldrop::channels::savechannels {args} { |
proc ::tcldrop::channels::savechannels {args} { |
138 |
set fid [open $::chanfile w] |
foreach a [binds channels savechannels] { |
139 |
if {[lsearch $args -flush] != -1} { set flush 1 } else { set flush 0 |
foreach {type flags mask count proc} $a {} |
140 |
fconfigure $fid -blocking 0 -buffering full |
if {[set lev [catch { $proc $args } val]]} { |
141 |
|
putlog "Error in script: $proc: $val" |
142 |
|
puterrlog "$::errorInfo" |
143 |
|
} |
144 |
|
::tcldrop::countbind $type $mask $proc |
145 |
|
if {![info exists retval]} { |
146 |
|
set retlev $lev |
147 |
|
set retval $val |
148 |
|
} |
149 |
|
} |
150 |
|
if {[info exists retval]} { |
151 |
|
return -code $retlev $retval |
152 |
|
} else { |
153 |
|
return -code error {No channel database module has been loaded.} |
154 |
} |
} |
|
variable Channels |
|
|
puts $fid [array get Channels] |
|
|
if {$flush} { flush $fid } |
|
|
close $fid |
|
155 |
} |
} |
156 |
|
|
157 |
proc ::tcldrop::channels::SetUdefDefaults {{name {*}}} { |
proc ::tcldrop::channels::SetUdefDefaults {{name {*}}} { |
172 |
|
|
173 |
# Loads the channel info from $chanfile: |
# Loads the channel info from $chanfile: |
174 |
proc ::tcldrop::channels::loadchannels {} { |
proc ::tcldrop::channels::loadchannels {} { |
175 |
if {[file exists $::chanfile]} { |
foreach a [binds channels loadchannels] { |
176 |
set fid [open $::chanfile r] |
foreach {type flags mask count proc} $a {} |
177 |
variable Channels |
if {[set lev [catch { $proc } val]]} { |
178 |
putlog "loading chanfile ($::chanfile)..." |
putlog "Error in script: $proc: $val" |
179 |
# FixMe: This shouldn't just dump the file into the Channels array... |
puterrlog "$::errorInfo" |
180 |
# It needs to check each channel for udefs that |
} |
181 |
# are no longer in use, and discard them. |
::tcldrop::countbind $type $mask $proc |
182 |
array set Channels [read $fid [file size $::chanfile]] |
if {![info exists retval]} { |
183 |
close $fid |
set retlev $lev |
184 |
|
set retval $val |
185 |
|
} |
186 |
|
} |
187 |
|
if {[info exists retval]} { |
188 |
|
return -code $retlev $retval |
189 |
} else { |
} else { |
190 |
putlog "no chanfile exists..yet." |
return -code error {No channel database module has been loaded.} |
191 |
} |
} |
192 |
SetUdefDefaults |
SetUdefDefaults |
193 |
} |
} |
194 |
|
|
195 |
# Returns 1 if a channel exists in the channel database, or 0 if it doesn't: |
# Returns 1 if a channel exists in the channel database, or 0 if it doesn't: |
196 |
proc ::tcldrop::channels::validchan {channel} { |
proc ::tcldrop::channels::validchan {channel} { |
197 |
variable Channels |
foreach a [binds channels validchan] { |
198 |
info exists Channels([string tolower $channel]) |
foreach {type flags mask count proc} $a {} |
199 |
|
if {[set lev [catch { $proc $channel } val]]} { |
200 |
|
putlog "Error in script: $proc: $val" |
201 |
|
puterrlog "$::errorInfo" |
202 |
|
} |
203 |
|
::tcldrop::countbind $type $mask $proc |
204 |
|
if {![info exists retval]} { |
205 |
|
set retlev $lev |
206 |
|
set retval $val |
207 |
|
} |
208 |
|
} |
209 |
|
if {[info exists retval]} { |
210 |
|
return -code $retlev $retval |
211 |
|
} else { |
212 |
|
return -code error {No channel database module has been loaded.} |
213 |
|
} |
214 |
} |
} |
215 |
|
|
216 |
# Note, types for udef's should be: flag, int, str, and list. |
# Note, types for udef's should be: flag, int, str, and list. |
344 |
setudef str need-halfop {} |
setudef str need-halfop {} |
345 |
setudef str need-voice {} |
setudef str need-voice {} |
346 |
# Note, global-chanset better be a list: |
# Note, global-chanset better be a list: |
347 |
foreach f ${::global-chanset} { |
foreach n ${::global-chanset} { |
348 |
if {$f != {}} { |
if {$n != {}} { |
349 |
setudef flag [string range $f 1 end] [string index $f 0] |
setudef flag [string range $n 1 end] [string index $n 0] |
350 |
|
} |
351 |
|
} |
352 |
|
set dbpriority 1 |
353 |
|
# Load all of the database modules.. |
354 |
|
foreach n $channeldbs { |
355 |
|
loadmodule "channels::$n" |
356 |
|
foreach c [namespace export] { |
357 |
|
if {[info commands "::tcldrop::channels::${n}::$c"] != {}} { |
358 |
|
bind channels {+|+} $c "::tcldrop::channels::${n}::$c" -priority $dbpriority |
359 |
|
} |
360 |
} |
} |
361 |
|
incr dbpriority |
362 |
} |
} |
363 |
unset f |
unset dbpriority n c |
364 |
} |
} |
365 |
|
|
366 |
# After Tcldrop loads, we (re)load the chanfile: |
# After Tcldrop loads, we (re)load the chanfile: |