/[tcldrop]/tcldrop/modules/idx.tcl
ViewVC logotype

Diff of /tcldrop/modules/idx.tcl

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.11 by fireegl, Tue Dec 2 09:27:14 2003 UTC revision 1.12 by uid66278, Wed Dec 24 06:15:56 2003 UTC
# Line 24  Line 24 
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
# Line 137  proc ::tcldrop::idx::putidx {idx text} { Line 207  proc ::tcldrop::idx::putidx {idx text} {
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  }  }

Legend:
Removed from v.1.11  
changed lines
  Added in v.1.12

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26