24 |
# |
# |
25 |
# idx module for tcldrop. |
# idx module for tcldrop. |
26 |
# This module is required. |
# This module is required. |
|
|
|
27 |
namespace eval ::tcldrop::idx { |
namespace eval ::tcldrop::idx { |
28 |
variable rcsid {$id$} |
# Provide the dcc module: |
29 |
variable version {0.6} |
variable version {0.4} |
30 |
package provide tcldrop::idx $version |
package provide tcldrop::idx $version |
31 |
variable idxlist |
variable rcsid {$Id$} |
|
variable idxcount |
|
|
if {![info exists idxcount]} { variable idxcount 1 } |
|
32 |
# Export all the commands that should be available to 3rd-party scripters: |
# Export all the commands that should be available to 3rd-party scripters: |
33 |
namespace export putidx valididx killidx |
namespace export putidx valididx killidx sock2idx idx2sock initidx idxlist listidx setidxinfo getidxinfo idxinfo assignidx registeridx unregisteridx |
34 |
|
variable IDXList |
35 |
|
if {![info exists IDXCount]} { variable IDXCount 1 } |
36 |
} |
} |
37 |
|
|
38 |
# Assigns a unique idx handle for a connection: |
# Assigns a unique idx handle for a connection: |
39 |
proc ::tcldrop::idx::Assign {args} { |
proc ::tcldrop::idx::assignidx {args} { |
40 |
variable idxcount |
variable IDXCount |
41 |
incr idxcount |
incr IDXCount |
42 |
} |
} |
43 |
|
|
44 |
# Registers a socket. |
# Registers an idx. |
45 |
# info is a key/value pair list. |
# info is a key/value pair list. |
46 |
# Required keys are: type sock idx hostname port timestamp handle other |
# Required keys are: type sock idx hostname port timestamp handle other |
47 |
# See info about the dcclist command in eggdrop/doc/tcl-commands.doc, |
# See info about the dcclist command in eggdrop/doc/tcl-commands.doc, |
48 |
# because it's dcclist that requires most of these keys. |
# because it's dcclist that requires most of these keys. |
49 |
proc ::tcldrop::idx::Register {idx info} { |
proc ::tcldrop::idx::registeridx {idx {info {}}} { |
50 |
variable idxlist |
variable IDXList |
51 |
set idxlist($idx) $info |
set IDXList($idx) $info |
52 |
} |
} |
53 |
|
|
54 |
# Unregisters all connections matching idxmask: |
# Unregisters an idx: |
55 |
proc ::tcldrop::idx::Unregister {idx} { |
proc ::tcldrop::idx::unregisteridx {idx} { |
56 |
variable idxlist |
variable IDXList |
57 |
array unset idxlist $idx |
array unset IDXList $idx |
|
# FixMe: If it's a server connection, reset the server, server-online, and server-socket variables. |
|
58 |
} |
} |
59 |
|
|
60 |
# Returns all connections matching $idx. |
# Asks for a new idx to be assigned, sets it's info to $info, and returns the assigned idx: |
61 |
# $idx should be either the idx you want, or * (the default) which lists all of them. |
# info is a key/value pair list. |
62 |
proc ::tcldrop::idx::Info {{idx {*}}} { |
# Required keys are: type sock idx hostname port timestamp handle other |
63 |
variable idxlist |
# See info about the dcclist command in eggdrop/doc/tcl-commands.doc, |
64 |
array get idxlist $idx |
# because it's dcclist that requires most of these keys. |
65 |
|
# Note: This does the job of both assignidx and registeridx. |
66 |
|
proc ::tcldrop::idx::initidx {{info {}}} { |
67 |
|
variable IDXCount |
68 |
|
variable IDXList |
69 |
|
set IDXList([set count [incr IDXCount]]) $info |
70 |
|
return $count |
71 |
} |
} |
72 |
|
|
73 |
# FixMe: Should this be doing error checking/returning errors? |
# idxlist ?info? |
74 |
proc ::tcldrop::idx::GetInfo {idx infotype} { |
# Returns: a key/value pair list of active local connections: |
75 |
if {![valididx $idx]} { |
# {<idx>} {<info>} |
76 |
return -code error "invalid idx: $idx" |
# |
77 |
} else { |
# The types are: chat, bot, files, file_receiving, file_sending, |
78 |
variable idxlist |
# file_send_pending, script, socket (these are connections that have |
79 |
array set idxinfo $idxlist($idx) |
# not yet been put under 'control'), telnet, and server. The timestamp |
80 |
if {[info exists idxinfo($infotype)]} { |
# is in unixtime format. |
81 |
return $idxinfo($infotype) |
# Module: core |
82 |
} else { |
# Example: idxlist {type CHAT} |
83 |
return -code error "no such type: $infotype" |
# Would return all the idx's and their info matching type CHAT. |
84 |
|
proc ::tcldrop::idx::idxlist {{info {}}} { |
85 |
|
variable IDXList |
86 |
|
switch -- $info { |
87 |
|
{} { array get IDXList } |
88 |
|
{default} { |
89 |
|
lappend list |
90 |
|
foreach idx [array names IDXList] { |
91 |
|
array set idxinfo $IDXList($idx) |
92 |
|
set add 1 |
93 |
|
foreach {i p} $info { |
94 |
|
if {![info exists idxinfo($i)] || ![string match -nocase $p $idxinfo($i)]} { |
95 |
|
set add 0 |
96 |
|
break |
97 |
|
} |
98 |
|
} |
99 |
|
if {$add} { lappend list $idx $IDXList($idx) } |
100 |
|
array unset idxinfo |
101 |
|
} |
102 |
|
return $list |
103 |
} |
} |
104 |
} |
} |
105 |
} |
} |
106 |
|
|
107 |
# Adds to or replaces info about an existing idx: |
# Works just like idxlist, but this just returns the idx's (without their info). |
108 |
proc ::tcldrop::idx::ChInfo {idx info} { |
proc ::tcldrop::idx::listidx {{info {}}} { |
109 |
variable idxlist |
variable IDXList |
110 |
foreach {a d} [Info $idx] { array set idxinfo $d } |
switch -- $info { |
111 |
array set idxinfo $info |
{} { array get IDXList } |
112 |
set idxlist($idx) [array get idxinfo] |
{default} { |
113 |
} |
lappend list |
114 |
|
foreach idx [array names IDXList] { |
115 |
# Lists all of the idx's matching $info: |
array set idxinfo $IDXList($idx) |
116 |
# If $info is omitted, then it lists all the idx's. |
set add 1 |
117 |
# The actual info about the idx is NOT included. |
foreach {i p} $info { |
118 |
# $info should be an even number of key/value pairs.. |
if {![info exists idxinfo($i)] || ![string match -nocase $p $idxinfo($i)]} { |
119 |
# For example: handle FireEgl |
set add 0 |
120 |
# If none are found, -1 is returned. |
break |
121 |
proc ::tcldrop::idx::List {{info {}}} { |
} |
122 |
if {$info == {} || $info == {*}} { |
} |
123 |
variable idxlist |
if {$add} { lappend list $idx } |
124 |
if {[llength [set list [array names idxlist]]] == 0} { |
array unset idxinfo |
125 |
return {-1} |
} |
|
} else { |
|
126 |
return $list |
return $list |
127 |
} |
} |
128 |
} else { |
} |
129 |
foreach {a d} [::tcldrop::idx::Info] { |
} |
130 |
array set idxinfo $d |
|
131 |
foreach {i p} $info { |
# Returns or sets one piece of info about $idx: |
132 |
if {[info exists idxinfo($i)] && [string match -nocase $p $idxinfo($i)]} { |
# Or returns all info about the idx. |
133 |
lappend list $a |
# Note: Using setidxinfo and getidxinfo are prefered over using this command. |
134 |
break |
proc ::tcldrop::idx::idxinfo {idx {info {}} {value {}}} { |
135 |
|
variable IDXList |
136 |
|
if {[info exists IDXList($idx)]} { |
137 |
|
switch -- $info { |
138 |
|
{} { return $IDXList($idx) } |
139 |
|
{default} { |
140 |
|
array set idxinfo $IDXList($idx) |
141 |
|
if {$value != {}} { |
142 |
|
set idxinfo($info) $value |
143 |
|
set IDXList($idx) [array get idxinfo] |
144 |
|
return $value |
145 |
|
} elseif {[info exists idxinfo($info)]} { |
146 |
|
return $idxinfo($info) |
147 |
|
} else { |
148 |
|
return -code error "no such type: $info" |
149 |
} |
} |
150 |
} |
} |
151 |
} |
} |
152 |
if {[info exists list]} { |
} else { |
153 |
return $list |
return -code error "invalid idx: $idx" |
154 |
|
} |
155 |
|
} |
156 |
|
|
157 |
|
# Adds to or replaces info about an existing idx: |
158 |
|
proc ::tcldrop::idx::setidxinfo {idx {info {}}} { |
159 |
|
variable IDXList |
160 |
|
if {[info exists IDXList($idx)]} { array set idxinfo $IDXList($idx) } |
161 |
|
array set idxinfo $info |
162 |
|
set IDXList($idx) [array get idxinfo] |
163 |
|
} |
164 |
|
|
165 |
|
# Companion to setidxinfo: |
166 |
|
proc ::tcldrop::idx::getidxinfo {idx} { |
167 |
|
variable IDXList |
168 |
|
if {[info exists IDXList($idx)]} { return $IDXList($idx) } |
169 |
|
} |
170 |
|
|
171 |
|
# Deletes a piece of info about the idx (to save a tad of memory): |
172 |
|
proc ::tcldrop::idx::delidxinfo {idx info} { |
173 |
|
variable IDXList |
174 |
|
if {[info exists IDXList($idx)]} { |
175 |
|
array set idxinfo $IDXList($idx) |
176 |
|
if {[info exists $idxinfo($info)]} { |
177 |
|
unset idxinfo($info) |
178 |
|
set IDXList($idx) [array get idxinfo] |
179 |
|
return 1 |
180 |
} else { |
} else { |
181 |
return {-1} |
return 0 |
182 |
} |
} |
183 |
|
} else { |
184 |
|
return 0 |
185 |
} |
} |
186 |
} |
} |
187 |
|
|
188 |
|
# Returns 1 if $idx is a valid idx, or 0 if it's not: |
189 |
|
# Note: This is an Eggdrop v1.6 and less command. |
190 |
proc ::tcldrop::idx::valididx {idx} { |
proc ::tcldrop::idx::valididx {idx} { |
191 |
variable idxlist |
variable IDXList |
192 |
info exists idxlist($idx) |
info exists IDXList($idx) |
193 |
} |
} |
194 |
|
|
195 |
|
# Sends $text to $idx: |
196 |
|
# Note: This is an Eggdrop v1.6 and less command. |
197 |
proc ::tcldrop::idx::putidx {idx text} { |
proc ::tcldrop::idx::putidx {idx text} { |
198 |
foreach {a d} [Info $idx] { |
variable IDXList |
199 |
array set idxinfo $d |
if {[info exists IDXList($idx)]} { |
200 |
|
array set idxinfo $IDXList($idx) |
201 |
if {[catch { puts $idxinfo(sock) $text }]} { return 0 } else { |
if {[catch { puts $idxinfo(sock) $text }]} { return 0 } else { |
202 |
|
# FixMe: flush should be optional, and it shouldn't do it by default: |
203 |
flush $idxinfo(sock) |
flush $idxinfo(sock) |
204 |
traffic $idxinfo(traffictype) out [string length $text] |
traffic $idxinfo(traffictype) out [string length $text] |
205 |
return 1 |
return 1 |
207 |
} |
} |
208 |
} |
} |
209 |
|
|
210 |
proc ::tcldrop::idx::killidx {idx} { |
# Closes any sockets that the idx is associated with, and unsets all the info known about it: |
211 |
foreach {a d} [Info $idx] { array set idxinfo $d |
# Note: This is a Tcldrop specific command. |
212 |
|
proc ::tcldrop::idx::killidx {idx args} { |
213 |
|
variable IDXList |
214 |
|
if {[info exists IDXList($idx)]} { |
215 |
|
array set idxinfo $IDXList($idx) |
216 |
catch { fileevent $idxinfo(sock) writable {} } |
catch { fileevent $idxinfo(sock) writable {} } |
217 |
catch { fileevent $idxinfo(sock) readable {} } |
catch { fileevent $idxinfo(sock) readable {} } |
218 |
catch { close $idxinfo(sock) } |
catch { close $idxinfo(sock) } |
219 |
Unregister $idxinfo(idx) |
unset IDXList($idx) |
220 |
} |
} |
221 |
} |
} |