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

Diff of /tcldrop/modules/server/server.tcl

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

revision 1.17 by fireegl, Wed Dec 3 04:08:36 2003 UTC revision 1.18 by uid66278, Wed Dec 24 06:15:56 2003 UTC
# Line 59  namespace eval ::tcldrop::server { Line 59  namespace eval ::tcldrop::server {
59          ::tcldrop::SetDefault botname {}          ::tcldrop::SetDefault botname {}
60          ::tcldrop::SetDefault botnick {}          ::tcldrop::SetDefault botnick {}
61          ::tcldrop::SetDefault max-queue-msg {99}          ::tcldrop::SetDefault max-queue-msg {99}
62            ::tcldrop::SetDefault network {Unknown}
63          checkmodule conn          checkmodule conn
64  }  }
65    
66  proc ::tcldrop::server::isbotnick {nick} { string equal -nocase $nick $::botnick }  proc ::tcldrop::server::isbotnick {nick} { string equal -nocase $nick $::botnick }
67    
68  proc ::tcldrop::server::Read {idx line} {  proc ::tcldrop::server::Read {idx line} {
69            set starttime [clock clicks]
70          if {[valididx $idx]} {          if {[valididx $idx]} {
71                  putloglev r * "\[@\] $line"                  putloglev r * "\[@\] $line"
72                  set lline [split $line]                  set lline [split $line]
# Line 85  proc ::tcldrop::server::Read {idx line} Line 87  proc ::tcldrop::server::Read {idx line}
87          } else {          } else {
88                  Error {EOF} {Got EOF From Server}                  Error {EOF} {Got EOF From Server}
89          }          }
90            putloglev d * "raw: process time: [expr {[clock clicks] - $starttime}]"
91  }  }
92    
93  # Sends the NICK and USER info to the IRC server as soon as the socket is open:  # Sends the NICK and USER info to the IRC server as soon as the socket is open:
# Line 110  proc ::tcldrop::server::quit {{reason {} Line 113  proc ::tcldrop::server::quit {{reason {}
113          callevent predisconnect-server          callevent predisconnect-server
114          global server-online server real-server server-idx          global server-online server real-server server-idx
115          putnow "QUIT :$reason"          putnow "QUIT :$reason"
         killidx ${server-idx}  
116          set server-online 0          set server-online 0
117          set server-idx 0          set server-idx 0
118          set server {}          set server {}
# Line 120  proc ::tcldrop::server::quit {{reason {} Line 122  proc ::tcldrop::server::quit {{reason {}
122    
123  proc ::tcldrop::server::server {{serv {}} {port 0} {password {}}} {  proc ::tcldrop::server::server {{serv {}} {port 0} {password {}}} {
124          global server servers default-port server-online my-ip server-timeout server-idx          global server servers default-port server-online my-ip server-timeout server-idx
125            # FixMe: There should be a global option to decide weather to choose a random server,
126            #        or to go in the same order as the $servers list.
127          if {$serv == {}} {          if {$serv == {}} {
128                  if {[set port [lindex [split [set serv [lindex $servers [rand [llength $servers]]]] :] 1]] != {}} {                  if {[set port [lindex [split [set serv [lindex $servers [rand [llength $servers]]]] :] 1]] != {}} {
129                          set serv [lindex [split $serv :] 0]                          set serv [lindex [split $serv :] 0]
# Line 130  proc ::tcldrop::server::server {{serv {} Line 134  proc ::tcldrop::server::server {{serv {}
134          callevent connect-server          callevent connect-server
135          variable TimerID          variable TimerID
136          catch { killutimer $TimerID }          catch { killutimer $TimerID }
137          set fail [catch { connect $serv $port -timeout ${server-timeout} -myaddr ${my-ip} -control ::tcldrop::server::Read -errors ::tcldrop::server::ConnectErrors -writable ::tcldrop::server::Write } idx]          set fail [catch { connect $serv $port -timeout [fuzz ${server-timeout}] -myaddr ${my-ip} -control ::tcldrop::server::Read -errors ::tcldrop::server::Error -writable ::tcldrop::server::Write } idx]
138          if {!$fail} {          if {!$fail} {
139                  ::tcldrop::idx::ChInfo $idx [list handle (server) remote $serv hostname $serv port $port type SERVER other serv traffictype irc timestamp [set timestamp [unixtime]]]                  setidxinfo $idx [list handle (server) remote $serv hostname $serv port $port type SERVER other serv traffictype irc timestamp [set timestamp [unixtime]]]
140                  # Eggdrop compatibility stuff:                  # Eggdrop compatibility stuff:
141                  set server "$serv:$port"                  set server "$serv:$port"
142                  set server-online $timestamp                  set server-online $timestamp
143                  set server-idx $idx                  set server-idx $idx
                 # The timeout here is so that we can try another server.  
                 set TimerID [utimer [expr { ${server-timeout} + 1 }] [list ::tcldrop::server::ConnectTimeout $idx]]  
144          } else {          } else {
145                  set TimerID [utimer ${server-cycle-wait} [list ::tcldrop::server::server]]                  # Wait $server-cycle-wait before trying again.
146                    set TimerID [utimer [fuzz ${server-cycle-wait}] [list ::tcldrop::server::server]]
147          }          }
148          return "$serv:$port"          return "$serv:$port"
149  }  }
150    
 proc ::tcldrop::server::ConnectTimeout {idx} {  
         if {![valididx $idx]} { Error {CONNECT_TIMEOUT} "Timeout during connect" }  
 }  
   
151  # This procs job is to close the current server connection,  # This procs job is to close the current server connection,
152  # and then wait until it's time to connect to another.  # and then wait until it's time to connect to another.
153  proc ::tcldrop::server::Error {type {reason {Error}}} {  proc ::tcldrop::server::Error {idx {reason {Error}}} {
154          quit "$type: $reason"          quit $reason
155          utimer ${::server-cycle-wait} [list ::tcldrop::server::server]          utimer [fuzz ${::server-cycle-wait}] [list ::tcldrop::server::server]
 }  
   
 proc ::tcldrop::server::ConnectErrors {idx reason} {  
         Error {CONNECT_ERROR} $reason  
156  }  }
157    
158  proc ::tcldrop::server::jump {{server {}} {port 0} {password {}}} {  proc ::tcldrop::server::jump {{server {}} {port 0} {password {}}} {
         if {$port == 0} { set port ${::default-port} }  
159          if {${::server-online}} { quit {Changing Servers...} }          if {${::server-online}} { quit {Changing Servers...} }
160          server $server $port $password          server $server $port $password
161  }  }
# Line 220  proc ::tcldrop::server::GetPenalty {line Line 214  proc ::tcldrop::server::GetPenalty {line
214          variable SentData          variable SentData
215          # Add the current milliseconds for this line to the list..          # Add the current milliseconds for this line to the list..
216          lappend SentData(lastclicks) [clock clicks -milliseconds]          lappend SentData(lastclicks) [clock clicks -milliseconds]
217          # And make sure there's only at most 5 in the list..          # Make sure there's only at most 5 in the list..
218          if {[llength $SentData(lastclicks)] > 5} { set SentData(lastclicks) [lrange $SentData(lastclicks) end-4 end] }          if {[llength $SentData(lastclicks)] > 5} { set SentData(lastclicks) [lrange $SentData(lastclicks) end-4 end] }
219          set allowance 0          set allowance 0
220          # See how much allowance we've saved up for bursts:          # See how much allowance we've saved up for bursts:
221          foreach b $SentData(lastclicks) {          foreach b $SentData(lastclicks) { incr allowance [expr {[clock clicks -milliseconds] - $b}] }
222                  incr allowance [expr {[clock clicks -milliseconds] - $b}]          # > 50000 means we haven't bursted our 5 lines in 10 seconds allowance..
         }  
         putloglev d * "total allowance: $allowance"  
223          if {$allowance > 50000} {          if {$allowance > 50000} {
224                  # > 50000 means we haven't bursted our 5 lines in 10 seconds allowance..                  # Note, it's possible that this gives a percent over 100..
225                    putloglev d * {burst: 1}
226                  # Let's spend our allowance!  =D                  # Let's spend our allowance!  =D
227                  set penalty 0                  set penalty 0
228          } else {          } else {
229                    putloglev d * {burst: 0}
230                  # We can't burst any more, so apply the penalties...                  # We can't burst any more, so apply the penalties...
231                    # Note that 1000 (ms) equals 1 second....
232                  switch -- [string toupper [lindex [split $line] 0]] {                  switch -- [string toupper [lindex [split $line] 0]] {
233                          {INVITE} { set penalty 3000 }                          {INVITE} { set penalty 3000 }
234                          {JOIN} { set penalty 2000 }                          {JOIN} { set penalty 2000 }
# Line 245  proc ::tcldrop::server::GetPenalty {line Line 240  proc ::tcldrop::server::GetPenalty {line
240                          {ISON} { set penalty 1000 }                          {ISON} { set penalty 1000 }
241                          {WHOIS} { set penalty 2000 }                          {WHOIS} { set penalty 2000 }
242                          {DNS} { set penalty 2000 }                          {DNS} { set penalty 2000 }
243                            {PING} { set penalty 100 }
244                            {PONG} { set penalty 100 }
245                          {default} {                          {default} {
246                                  # The number of destinations (targets) for the command:                                  # The number of destinations (targets) for the command:
247                                  # Note: it's possible that targets can be 0, if the command                                  # Note: it's possible that targets can be 0, if the command
# Line 322  proc ::tcldrop::server::Queue {{queue {9 Line 319  proc ::tcldrop::server::Queue {{queue {9
319                          # We process the next queue on the next iteration..                          # We process the next queue on the next iteration..
320                  }                  }
321          } elseif {$queue == 0} {          } elseif {$queue == 0} {
322                  # What?!  We didn't wait long enough!?  How is that possible! =P                  # What?!  We didn't wait long enough!?  How is that possible! =/
323                  # Anyways, let's wait out the rest of the time, plus a little bit more and try again..                  # Anyways, let's wait out the rest of the time, plus a little bit more and try again..
324                  after [expr {$SentData(penalty) - $waited + 99}] [list ::tcldrop::server::Queue 0]                  after [expr {$SentData(penalty) - $waited + 99}] [list ::tcldrop::server::Queue 0]
325          }          }
# Line 335  proc ::tcldrop::server::putnow {text} { Line 332  proc ::tcldrop::server::putnow {text} {
332          if {[valididx ${::server-idx}]} {          if {[valididx ${::server-idx}]} {
333                  putidx ${::server-idx} $text                  putidx ${::server-idx} $text
334          } else {          } else {
335                  clearqueue {all}                  clearqueue all
336          }          }
337  }  }
338    

Legend:
Removed from v.1.17  
changed lines
  Added in v.1.18

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