28 |
|
|
29 |
namespace eval ::tcldrop::channels::arraydb { |
namespace eval ::tcldrop::channels::arraydb { |
30 |
# Provide the channels::arraydb module: |
# Provide the channels::arraydb module: |
31 |
variable version {0.1} |
variable version {0.8} |
32 |
variable rcsid {$Id$} |
variable rcsid {$Id$} |
33 |
package provide tcldrop::channels::arraydb $version |
package provide tcldrop::channels::arraydb $version |
34 |
# Initialize variables: |
# Initialize variables: |
35 |
|
variable Udefs |
36 |
|
array set Udefs {} |
37 |
variable Channels |
variable Channels |
38 |
array set Channels {} |
array set Channels {} |
39 |
|
# Set the internal defaults: |
40 |
|
::tcldrop::SetDefault chanfile {tcldrop.chan} |
41 |
} |
} |
42 |
|
|
|
# Set the internal defaults: |
|
|
::tcldrop::SetDefault chanfile {tcldrop.chan} |
|
|
|
|
43 |
proc ::tcldrop::channels::arraydb::channel {command channel opts} { |
proc ::tcldrop::channels::arraydb::channel {command channel opts} { |
|
# FixMe: Change the args variable name in the rest of this proc... |
|
|
set args $opts |
|
44 |
variable Channels |
variable Channels |
45 |
set lowerchannel [string tolower $channel] |
set lowerchannel [string tolower $channel] |
46 |
switch -- $command { |
switch -- $command { |
47 |
{add} { |
{add} { |
48 |
if {[llength $args] > 1} { |
if {[llength $opts] > 1} { |
49 |
set options $args |
set options $opts |
50 |
} else { |
} else { |
51 |
set options [lindex $args 0] |
set options [lindex $opts 0] |
52 |
} |
} |
53 |
# Add the channel: |
# Add the channel: |
54 |
set Channels($lowerchannel) [list name $channel] |
set Channels($lowerchannel) [list name $channel] |
55 |
# Call ourself again to set the options: |
# Call ourself again to set the options: |
56 |
channel set $channel $options |
channel set $channel $options |
57 |
|
SetUdefDefaults |
58 |
} |
} |
59 |
{set} { |
{set} { |
60 |
# In the case of "set", $args is already in the form we can use. |
# In the case of "set", $opts is already in the form we can use. |
61 |
set options $args |
set options $opts |
62 |
array set chaninfo $Channels($lowerchannel) |
array set chaninfo $Channels($lowerchannel) |
63 |
set setnext 0 |
set setnext 0 |
64 |
foreach o $options { |
foreach o $options { |
89 |
} |
} |
90 |
} |
} |
91 |
} else { |
} else { |
92 |
switch -- [set type [::tcldrop::channels::UdefType [set name [string trimleft $o {+-}]]]] { |
switch -- [set type [UdefType [set name [string trimleft $o {+-}]]]] { |
93 |
{flag} { |
{flag} { |
94 |
switch -- [string index $o 0] { |
switch -- [string index $o 0] { |
95 |
{+} { set chaninfo($name) 1 } |
{+} { set chaninfo($name) 1 } |
121 |
{get} { |
{get} { |
122 |
if {[info exists Channels($lowerchannel)]} { |
if {[info exists Channels($lowerchannel)]} { |
123 |
array set chaninfo $Channels($lowerchannel) |
array set chaninfo $Channels($lowerchannel) |
124 |
if {[info exists chaninfo($args)]} { |
if {[info exists chaninfo($opts)]} { |
125 |
return $chaninfo($args) |
return $chaninfo($opts) |
126 |
} else { |
} else { |
127 |
return -code error "Unknown channel setting: $args" |
return -code error "Unknown channel setting: $opts" |
128 |
} |
} |
129 |
} else { |
} else { |
130 |
return -code error "no such channel record: $channel" |
return -code error "no such channel record: $channel" |
159 |
} |
} |
160 |
|
|
161 |
# Saves the channel info to $chanfile: |
# Saves the channel info to $chanfile: |
162 |
proc ::tcldrop::channels::arraydb::savechannels {opts} { |
proc ::tcldrop::channels::arraydb::savechannels {{opts {}}} { |
|
set args $opts |
|
163 |
set fid [open $::chanfile w] |
set fid [open $::chanfile w] |
164 |
if {[lsearch $args -flush] != -1} { set flush 1 } else { set flush 0 |
if {[lsearch $opts -flush] != -1} { set flush 1 } else { set flush 0 |
165 |
fconfigure $fid -blocking 0 -buffering full |
fconfigure $fid -blocking 0 -buffering full |
166 |
} |
} |
167 |
variable Channels |
variable Channels |
184 |
} else { |
} else { |
185 |
putlog "no chanfile exists..yet." |
putlog "no chanfile exists..yet." |
186 |
} |
} |
187 |
::tcldrop::channels::SetUdefDefaults |
SetUdefDefaults |
188 |
} |
} |
189 |
|
|
190 |
# 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: |
200 |
# Module: channels |
# Module: channels |
201 |
# |
# |
202 |
# channame2dname <channel-name> |
# channame2dname <channel-name> |
|
# chandname2name <channel-dname> |
|
203 |
|
# chandname2name <channel-dname> |
204 |
|
|
205 |
|
# Gives the type of the udef given in $name: |
206 |
|
# It returns one of the following: int, flag, str, list, or unknown. |
207 |
|
proc ::tcldrop::channels::arraydb::UdefType {name} { |
208 |
|
variable Udefs |
209 |
|
if {[info exists Udefs($name)]} { |
210 |
|
return $Udefs($name) |
211 |
|
} else { |
212 |
|
return {unknown} |
213 |
|
} |
214 |
|
} |
215 |
|
|
216 |
|
proc ::tcldrop::channels::arraydb::SetUdefDefaults {{name {*}}} { |
217 |
|
variable Channels |
218 |
|
variable UdefDefaults |
219 |
|
foreach c [array names Channels] { |
220 |
|
array set chaninfo $Channels($c) |
221 |
|
foreach n [array names UdefDefaults $name] { |
222 |
|
if {![info exists chaninfo($n)]} { |
223 |
|
# It's not already set, so we set it to the default: |
224 |
|
set chaninfo($n) $UdefDefaults($n) |
225 |
|
set Channels($c) [array get chaninfo] |
226 |
|
} |
227 |
|
} |
228 |
|
array unset chaninfo |
229 |
|
} |
230 |
|
} |
231 |
|
|
232 |
|
# Note, types for udef's should be: flag, int, str, and list. |
233 |
|
# In the case of lists, the channel command should provide lappend, lreplace, and lremove commands. |
234 |
|
|
235 |
|
# Defines a new udef: |
236 |
|
proc ::tcldrop::channels::arraydb::setudef {type name {default {}}} { |
237 |
|
# Store the default for this udef: |
238 |
|
variable UdefDefaults |
239 |
|
switch -- $type { |
240 |
|
{flag} { |
241 |
|
switch -- $default { |
242 |
|
{1} - {+} { set UdefDefaults($name) 1 } |
243 |
|
{0} - {-} - {default} { set UdefDefaults($name) 0 } |
244 |
|
} |
245 |
|
} |
246 |
|
{int} { |
247 |
|
if {$default != {}} { |
248 |
|
set UdefDefaults($name) $default |
249 |
|
} else { |
250 |
|
set UdefDefaults($name) 0 |
251 |
|
} |
252 |
|
} |
253 |
|
{str} - {list} { set UdefDefaults($name) $default } |
254 |
|
{default} { |
255 |
|
# FixMe: Give an invalid type error. |
256 |
|
} |
257 |
|
} |
258 |
|
# Store the udef itself: |
259 |
|
variable Udefs |
260 |
|
set Udefs($name) [string tolower $type] |
261 |
|
# Apply the default to all channels that don't already have it set: |
262 |
|
SetUdefDefaults $name |
263 |
|
} |
264 |
|
|
265 |
|
# renudef <flag/int> <oldname> <newname> |
266 |
|
# Description: renames a user defined channel flag or integer setting. |
267 |
|
# Returns: nothing |
268 |
|
# Module: channels |
269 |
|
# Proc written by Papillon@EFNet. |
270 |
|
# FixMe: This proc is untested and unmodified from what he sent me. |
271 |
|
proc ::tcldrop::channels::arraydb::renudef {type oldname newname} { |
272 |
|
variable Channels |
273 |
|
variable Udefs |
274 |
|
variable UdefDefaults |
275 |
|
if {[info exists Udefs($oldname)] && [string compare -nocase $Udefs($oldname) $type]} { |
276 |
|
#just delete this loop if you don't want it to rename the udef in all channels |
277 |
|
foreach c [array names Channels] { |
278 |
|
array set chaninfo $Channels($c) |
279 |
|
foreach n [array names UdefDefaults $oldname] { |
280 |
|
if {[info exists chaninfo($n)]} { |
281 |
|
set chaninfo($newname) $UdefDefaults($n) |
282 |
|
set Channels($c) [array get chaninfo] |
283 |
|
array unset Channels $n |
284 |
|
} |
285 |
|
} |
286 |
|
array unset chaninfo |
287 |
|
} |
288 |
|
|
289 |
|
set tempUdefs($newname) $Udefs($oldname) |
290 |
|
set tempDefaults($newname) $Udefs($oldname) |
291 |
|
array unset Udefs $oldname |
292 |
|
array unset UdefDefaults $oldname |
293 |
|
array set Udefs [array get tempUdefs] |
294 |
|
array set UdefDefaults [array get tempDefaults] |
295 |
|
} |
296 |
|
} |
297 |
|
|
298 |
|
|
299 |
|
# deludef <flag/int> <name> |
300 |
|
# Description: deletes a user defined channel flag or integer setting. |
301 |
|
# Returns: nothing |
302 |
|
# Module: channels |
303 |
|
# Proc written by Papillon@EFNet. |
304 |
|
# FixMe: This proc is untested and unmodified from what he sent me. |
305 |
|
proc ::tcldrop::channels::arraydb::deludef {type name} { |
306 |
|
variable Channels |
307 |
|
variable Udefs |
308 |
|
variable UdefDefaults |
309 |
|
if {[info exists Udefs($name)] && [string compare -nocase $Udefs($name) $type]} { |
310 |
|
#just delete this loop if you don't want it to remove the udef from all channels |
311 |
|
foreach c [array names Channels] { |
312 |
|
array set chaninfo $Channels($c) |
313 |
|
foreach n [array names UdefDefaults $name] { |
314 |
|
if {[info exists chaninfo($n)]} { |
315 |
|
array unset Channels $n |
316 |
|
} |
317 |
|
} |
318 |
|
array unset chaninfo |
319 |
|
} |
320 |
|
array unset Udefs $name |
321 |
|
array unset UdefDefaults $name |
322 |
|
} |
323 |
|
} |