"SfR Fresh" - the SfR Freeware/Shareware Archive 
As a special service "SfR Fresh" has tried to format the requested source page into HTML format using (guessed) Tcl/Tk source code syntax highlighting with prefixed line numbers.
Alternatively you can here view or download the uninterpreted source code file.
That can be also achieved for any archive member file by clicking within an archive contents listing on the first character of the file(path) respectively on the according byte size field.
1 #!/usr/bin/tclsh
2 # OpenVerse Server Program
3 #
4 # This is the server code! :)
5 #
6 # Module Name - Server Program
7 # Current Maintainter - Cruise <cruise@openverse.org>
8 # Sourced By - Command Line Or Client
9 #
10 # Copyright (C) 1999-2001 David Gale <cruise@openverse.org>
11 # For more information visit http://OpenVerse.org/
12 #
13 # This program is free software; you can redistribute it and/or
14 # modify it under the terms of the GNU General Public License
15 # as published by the Free Software Foundation; either version 2
16 # of the License, or (at your option) any later version.
17 #
18 # This program is distributed in the hope that it will be useful,
19 # but WITHOUT ANY WARRANTY; without even the implied warranty of
20 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
21 # GNU General Public License for more details.
22 #
23 # You should have received a copy of the GNU General Public License
24 # along with this program; if not, write to the Free Software
25 # Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
26 # USA.
27 #
28 #
29 # FIRST - Setup some server variables.
30 #
31 # Please see the Technical Help section of the documentation in your
32 # client software for a complete list of variables and their descriptions.
33 # Whenever possible, they have been described here in the code too.
34 #
35 global MVS tcl_interactive
36 # -----------------------------------------------------------------------
37 set MVS(log) 1; # Do we output our logs at all?
38 set MVS(log_scroll) 1; # Do we scroll the log file in GUI mode?
39 set MVS(waiter) 1; # Sleeper variable for a dedicated server.
40 set MVS(serving) 1; # Is server running?
41 set MVS(users) 0; # Total number of conected users.
42 set MVS(socks) {}; # List of connected users.
43 set MVS(tell_registry) {}; # List of objects with TELL registry needs.
44 set MVS(entry_registry) {}; # List of object with ENTRY registry needs.
45 set MVS(submit_registry) {}; # List of objects with SUBMIT reigstry needs.
46 set MVS(registry.servers) {}; # List of objects in the SERVERS registry. (Used with ORT Registrations
47 set MVS(ORT_current_ort) -1; # Is an ORT stopped at our server? -1 is no.
48 set MVS(dcc_list) {}; # A list of active file transfers.
49 set MVS(dcc_num) 0; # Self incremening list of transfer IDs
50 set MVS(hooks.Connect) {}; # List of hooks for new connections.
51 set MVS(hooks.DisconnectUser) {}; # List of hooks for DisconnectUser
52 set MVS(hooks.Move) {}; # List of hooks for MOVE Commands.
53 set MVS(hooks.Input) {}; # List of hooks for general input
54 set MVS(hooks.Chat) {}; # List of hooks for CHAT commands.
55 # -----------------------------------------------------------------------
56 #
57 # Central Logging Facility
58 #
59 # Usage: LogIt "Text To Log"
60 #
61 # Everything uses this so we must define it first.
62 # CRUISE - 10/23/2001 - Added a time stamp (duh!)
63 # CRUISE - 10/23/2001 - Added a ability to shut off logs.
64 #
65 proc LogIt {text} {
66 global MVS
67
68 if {!$MVS(log)} {return}
69
70 set timestamp [clock format [clock seconds] -format "%b %d %Y - %T"]
71 if $MVS(standalone) {
72 # we are running from a command line
73 puts "$timestamp -- $text"
74 } else {
75 # we are running from a gui
76 if {[winfo exists .ovserver]} {
77 .ovserver.log.text insert end "$timestamp -- $text\n"
78 if {$MVS(log_scroll)} {
79 .ovserver.log.text see end
80 }
81 # TODO (6) Check for number of lines and trim.
82 }
83 }
84 unset text
85 }
86 #
87 # Send text to ALL users.
88 #
89 # Usage: SendToAllUsers "Text To Send"
90 #
91 # This function will send the provided text to all connected users. The
92 # text should be pre-formated and ready to go.
93 #
94 proc SendToAllUsers {what} {
95 global MVS
96
97 foreach sckt $MVS(socks) {
98 if [string compare $MVS($sckt.name) "*"] {
99 LogIt "($sckt)-> $what"
100 catch {puts $sckt "$what"}
101 }
102 }
103 unset what
104 }
105 # Server Hooks Registration
106 #
107 # Call thusly....
108 # RegisterHook ModuleName HookName YourFunction
109 #
110 # When a hook is activated, it will check the return value of the
111 # function. If it is 0, it will not continue it's normal processing. You
112 # should always return 1 unless you are sure you don't want the server to
113 # continue with the function it was processing!!!!
114 #
115 # Available hooks {and the parameters they call with} include.....
116 #
117 # ------------------------------------
118 # Connect {$who}
119 # ------------------------------------
120 # DisconnectUser {$who $announce}
121 # ------------------------------------
122 # Move {$who $is_exiting}
123 # ------------------------------------
124 # Input {$who $what}
125 # ------------------------------------
126 # Chat {$who $what}
127 # ------------------------------------
128 #
129 proc RegisterHook {module hook func} {
130 global MVS
131
132 lappend MVS(hooks.$hook) $module
133 lappend MVS(hooks.$hook.$module) $func
134 }
135 #
136 # (re)Load the server config file.
137 #
138 # Usage: ReloadConfig
139 #
140 # This function will (re)load the server config file. Any changes will
141 # take effect at the time of reload.
142 #
143 # CRUISE - 10/25/2001 - The maxusers variable was blank by default, now it's set to 100
144 # CRUISE - 11/08/2001 - Moved things around a bit, added some docs to the variables.
145 #
146 proc ReloadConfig {} {
147 global MVS
148
149 LogIt "------------ Loading Config File -----------"
150 #
151 # Basic Server Settings.
152 #
153 set MVS(port) "7000"; # What port the server is runing on.
154 set MVS(timeout) 120; # Seconds to wait before calling a transfer failed.
155 set MVS(roomname) "My Own Room"; # The name of this room.
156 set MVS(maxheight) "200"; # Maximum allowed image height
157 set MVS(maxwidth) "320"; # Maximum Allowed Image Width.
158 set MVS(push) 1; # Does the server support pushing?
159 set MVS(sendbuffer) 4096; # Sending buffer size for file transfers.
160 set MVS(maxmsglen) 256; # Maximum lengs of messages which the server accepts.
161 set MVS(flood_threshold) 10; # Maximum things a user can send before they are flooded offline.
162 set MVS(exits) {}; # A list of exit server:port entries.
163 set MVS(locations) {}; # A list of coords for the EXIT type exits.
164 set MVS(maxpushdistance) 100; # How far (pixels) can we push someone?
165 set MVS(maxpushvelocity) 100; # How fast can we push them?
166 set MVS(max_same_users) 10; # Maximum users from the same host.
167 set MVS(maxusers) 100; # Maximum number of users allowed to log in.
168 set MVS(max_ignores) 50; # Maximum users you may ignore (per type)
169 set MVS(max_socket_retries) 20; # Maximum times we will try to open a socket on a busy day.
170 set MVS(retry_wait_time) 300; # Time to wait between retries to open a new socket.
171 #
172 # File and dir names
173 #
174 set MVS(avatars) "$MVS(homedir)/simages"; # Where the remote user's avatars will be placed.
175 set MVS(sobjects) "$MVS(homedir)/sobjects"; # The directory where avatars are stored.
176 set MVS(images) "$MVS(homedir)/images"; # Where our images are stored.
177 set MVS(icons) "$MVS(homedir)/icons"; # Where our icons are stored
178 set MVS(tickler) "$MVS(homedir)/TickleMe"; # Config File Tickler, reload config when it exists.
179 set MVS(mem_tickler) "$MVS(homedir)/TickleMem"; # Memory tickler - Dump mem when it exists.
180 set MVS(roomdir) "$MVS(homedir)/rooms"; # The directory where room images are stored.
181 set MVS(roomfile) "room.gif"; # The name (not the full path) of the room image.
182 #
183 # ORT Section
184 #
185 set MVS(register_ort) 1; # Should we register with the ort?
186 set MVS(ORT_Admin) "Joe Admin"; # The Admin's name
187 set MVS(ORT_AdminEmail) "openverse@openverse.org"; # The Admin's email address.
188 set MVS(ORT_Country) "United States"; # The country this server is in.
189 set MVS(ORT_Description) "Description Not Set!"; # A brief description of this server.
190 set MVS(ORT_Image) "ov_tram_logo.gif"; # Our banner image for the ORT
191 set MVS(ORT_Rating) "PG"; # Our content Rating.
192 set MVS(ORT_WebSite) "http://openverse.org/"; # This server's website address.
193 set MVS(ORT_Server) {}; # A list of ORT server:port values.
194 set MVS(ORT_Username) {}; # A list of ORT username values for each server.
195 set MVS(ORT_Password) {}; # A list of ORT passwords for each server.
196 set MVS(ORT_Location) {}; # A list of ORT screen locations for each server.
197 set MVS(ORT.force) 0; # Force the ORT image?
198 set MVS(ORT.force.image) "default.gif"; # Force the ORT image?
199 set MVS(ORT.msg) "All Aboard!!!"; # What does the ORT say?
200 #
201 # Create required directories.
202 #
203 if ![file exists $MVS(avatars)] {file mkdir "$MVS(avatars)"}
204 if ![file exists $MVS(sobjects)] {file mkdir "$MVS(sobjects)"}
205 if ![file exists $MVS(images)] {file mkdir "$MVS(images)"}
206 if ![file exists $MVS(roomdir)] {file mkdir "$MVS(roomdir)"}
207 if ![file exists $MVS(icons)] {file mkdir "$MVS(icons)"}
208 #
209 # reset the variables as we want them to be.
210 #
211 if [file exists "$MVS(configfile)"] {source $MVS(configfile)}
212 if [file exists "$MVS(tickler)"] {
213 catch {
214 file delete -force "$MVS(tickler)"
215 }
216 }
217 if [file exists "$MVS(mem_tickler)"] {
218 catch {
219 file delete -force "$MVS(mem_tickler)"
220 }
221 }
222 #
223 # These might have changed, lets send them just in case.
224 #
225 SendToAllUsers "ROOMNAME $MVS(roomname)"
226 SendToAllUsers "ROOM $MVS(roomfile) [file size "$MVS(roomdir)/$MVS(roomfile)"]"
227 }
228 #
229 # Accept New Connections.
230 #
231 # Usage: NewConnect socket address port
232 #
233 # This function will accept a new connection and setup some initial
234 # variables for the user. It will also set a trigger on the incoming
235 # socket which will read data on the socket.
236 #
237 # CRUISE - 10/25/2001 - Made the maxusers variable actually do something.
238 #
239 proc NewConnect {sck address port} {
240 global MVS
241
242 LogIt "($sck)<- New Connection! $address:$port"
243 fconfigure $sck -blocking 0 -buffering line
244 fileevent $sck readable "Serv_ReadFrom $sck"
245 if {[lsearch $MVS(socks) $sck] == -1} {
246 lappend MVS(socks) $sck
247 } else {
248 close $sck
249 unset sck address port
250 return
251 }
252 set MVS($sck.name) "*"
253 set MVS($sck.flood) 0
254 set MVS($sck.time) [clock seconds]
255 set MVS($sck.address) "$address"
256 set MVS($sck.port) "$port"
257 set MVS($sck.ping) 0
258 set MVS($sck.ping_response) [clock seconds]
259 set MVS($sck.x) -1
260 set MVS($sck.y) -1
261 set MVS($sck.avatar) "*connecting*"
262 set MVS($sck.av_head_x) "-1"
263 set MVS($sck.av_head_y) "-1"
264 set MVS($sck.av_baloon_x) "-1"
265 set MVS($sck.av_baloon_y) "-1"
266 set MVS($sck.downloads) {}
267 set MVS($sck.ig.av) {}
268 set MVS($sck.ig.effect) {}
269 set MVS($sck.ig.move) {}
270 set MVS($sck.ig.chat) {}
271 set MVS($sck.ig.sub) {}
272 set MVS($sck.ig.url) {}
273 set MVS($sck.ig.all) {}
274 incr MVS(users)
275 if !$MVS(standalone) {
276 .ovserver.buttons.info.v configure -text $MVS(users)
277 }
278 set count 0
279 foreach sock $MVS(socks) {
280 if {$MVS($sock.address) == $address} {incr count}
281 }
282 if {$count > $MVS(max_same_users)} {
283 SendToUser $sck "TOOMANYCONNECTIONS"
284 DisconnectUser $sck 0
285 }
286 if {[llength $MVS(socks)] >= $MVS(maxusers)} {
287 SendToUser $sck "ROOMFULL"
288 DisconnectUser $sck 0
289 }
290 unset sck address port
291 }
292 #
293 # Check name validity.
294 #
295 # Usage: CheckName "NickName"
296 #
297 # this function will check a given nickname to be sure it is allowed. Some
298 # nicknames are not allowed if they contain special characters.
299 #
300 proc CheckName {name} {
301 if {[string trim $name] == "" || \
302 [string trim $name] == "*" || \
303 [string trim $name] == "." || \
304 [string range $name 0 0] == "-"} {
305 unset name
306 return 0
307 } else {
308 unset name
309 return 1
310 }
311 }
312 #
313 # Read Incomming Text
314 #
315 # Usage: Serv_ReadFrom socket
316 #
317 # This function will read text from a socket and process it. If the user
318 # is not authenticated, it will authenticate them. If the user is just
319 # requesting a number of connected users, this function will process the
320 # request. If it has nothing to do other than to read the text, it will
321 # pass this text off to the Serv_ProcessInput function for processing.
322 #
323 proc Serv_ReadFrom {who} {
324 global MVS
325
326 set input ""
327 catch {gets $who input}
328 # Update before we process anything!
329 if {[eof $who] == 1} {
330 if {![string compare $MVS($who.name) "*"]} {
331 DisconnectUser $who 0
332 } else {
333 DisconnectUser $who 1
334 }
335 unset input who
336 return
337 }
338
339 if {![string compare $MVS($who.name) "*"]} {
340 #
341 # User is not logged in yet.
342 #
343 LogIt "<- $input"
344 set Srv_Cmd [lindex [split $input " "] 0]
345 switch -- $Srv_Cmd {
346 "USERS" {
347 SendToUser $who "USERS [expr [llength $MVS(socks)] -1]"
348 DisconnectUser $who 0
349 return
350 }
351 "TRANS" {
352 TransAuth $who $input
353 return
354 }
355 "AUTH" {
356 # For now allow it to just pass through.
357 # User auth needs to be broken out of this
358 # function and sent to it's own function.
359 }
360 default {
361 SendToUser $who "AUTH REQD"
362 DisconnectUser $who 0
363 }
364 }
365 set parms [split [string range $input 5 end] " "]
366 if {[TestNum [lindex $parms 1]] || \
367 [TestNum [lindex $parms 2]] || \
368 [TestNum [lindex $parms 4]] || \
369 [TestNum [lindex $parms 5]] || \
370 [TestNum [lindex $parms 6]] || \
371 [TestNum [lindex $parms 7]] || \
372 [TestNum [lindex $parms 8]] } {
373 SendToUser $who "AUTH FAILED (Non Numeric)"
374 DisconnectUser $who 0
375 unset input who
376 return
377 }
378 if {[string length [lindex $parms 1]] > 3 || \
379 [string length [lindex $parms 2]] > 3 || \
380 [string length [lindex $parms 4]] > 4 || \
381 [string length [lindex $parms 5]] > 4 || \
382 [string length [lindex $parms 6]] > 6 || \
383 [string length [lindex $parms 7]] > 4 || \
384 [string length [lindex $parms 8]] > 4 || \
385 [lindex $parms 1] < 0 || \
386 [lindex $parms 2] < 0 || \
387 [lindex $parms 6] < 0} {
388 SendToUser $who "AUTH FAILED (String Lengths)"
389 DisconnectUser $who 0
390 unset input who
391 return
392 }
393
394 set MVS($who.name) [string range [lindex $parms 0] 0 12]
395 set MVS($who.x) [lindex $parms 1]
396 set MVS($who.y) [lindex $parms 2]
397 set MVS($who.avatar) [lindex $parms 3]
398 set MVS($who.av_head_x) [lindex $parms 4]
399 set MVS($who.av_head_y) [lindex $parms 5]
400 set MVS($who.av_baloon_x) [lindex $parms 7]
401 set MVS($who.av_baloon_y) [lindex $parms 8]
402 set size [lindex $parms 6]
403
404 if ![CheckName $MVS($who.name)] {
405 SendToUser $who "BADNAME"
406 DisconnectUser $who 0
407 unset input parms size who
408 return
409 }
410 foreach sckt $MVS(socks) {
411 if {![string compare $MVS($sckt.name) $MVS($who.name)] && [string compare $sckt $who]} {
412 SendToUser $who "NAMEINUSE"
413 DisconnectUser $who 0
414 unset input parms size sckt who
415 return
416 }
417 }
418
419 # User is logged in now. But no one can see him
420 # and we have not told him about anyone else. at
421 # this point, a server object may want to
422 # disconnect the user. If this returns 0, we will
423 # disconnect the
424 # user (the object should have sent notification)
425
426 foreach hook $MVS(hooks.Connect) {
427 if {![$MVS(hooks.Connect.$hook) $who]} {
428 # dont notify cause no one knew
429 # they were here.
430 DisconnectUser $who 0
431 return
432 }
433 }
434 SendToUser $who "ROOMNAME $MVS(roomname)"
435 SendToUser $who "ROOM $MVS(roomfile) [file size $MVS(roomdir)/$MVS(roomfile)]"
436 #
437 # If we have an ORT stopped, display it.
438 #
439 if {$MVS(ORT_current_ort) != -1} {
440 if {![file exists "$MVS(avatars)/$MVS(ORT_info.$MVS(ORT_current_ort).image)"]} {
441 set image "default.gif"
442 } else {
443 set image "$MVS(ORT_info.$MVS(ORT_current_ort).image)"
444 }
445 SendToUser $who "NEW $MVS(ORT_info.$MVS(ORT_current_ort).name) $MVS(ORT_info.$MVS(ORT_current_ort).x) $MVS(ORT_info.$MVS(ORT_current_ort).y) $image 0 60 [file size $MVS(avatars)/$image] 66 -44"
446 set a $MVS(ORT_info.$MVS(ORT_current_ort).x)
447 set b $MVS(ORT_info.$MVS(ORT_current_ort).y)
448 SendToUser $who "EXIT_OBJ ov_tram_exit [expr $a - 60] [expr $b - 60] [expr $a + 60] [expr $b + 60] 0 $MVS(ORT_info.$MVS(ORT_current_ort).host) $MVS(ORT_info.$MVS(ORT_current_ort).port)"
449 }
450 #
451 # This is where server objects happen.
452 #
453 SendObjects $who
454
455 if ![file exists $MVS(avatars)/$MVS($who.avatar)] {
456 SendToAllUsers "NEW $MVS($who.name) $MVS($who.x) $MVS($who.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
457 LogIt "($who) $MVS($who.avatar) does not exist"
458 GetBinaryFile $who $MVS($who.avatar) $size AVATAR 0
459 } else {
460 if {[file size $MVS(avatars)/$MVS($who.avatar)] != $size} {
461 SendToAllUsers "NEW $MVS($who.name) $MVS($who.x) $MVS($who.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
462 LogIt "($who) $MVS($who.avatar) $size != [file size $MVS(avatars)/$MVS($who.avatar)]"
463 GetBinaryFile $who $MVS($who.avatar) $size AVATAR 0
464 } else {
465 if [CheckGif "$MVS(avatars)/$MVS($who.avatar)"] {
466 SendToAllUsers "NEW $MVS($who.name) $MVS($who.x) $MVS($who.y) $MVS($who.avatar) $MVS($who.av_head_x) $MVS($who.av_head_y) [file size $MVS(avatars)/$MVS($who.avatar)] $MVS($who.av_baloon_x) $MVS($who.av_baloon_y)"
467 } else {
468 SendToAllUsers "NEW $MVS($who.name) $MVS($who.x) $MVS($who.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
469 SendToUser $who "TOOBIG"
470 set MVS($who.avatar) "default.gif"
471 }
472 }
473 }
474
475 foreach sckt $MVS(socks) {
476 if [string compare $MVS($sckt.name) "*"] {
477 if {[string compare $MVS($sckt.name) $MVS($who.name)]} {
478 if [file exists $MVS(avatars)/$MVS($sckt.avatar)] {
479 SendToUser $who "NEW $MVS($sckt.name) $MVS($sckt.x) $MVS($sckt.y) $MVS($sckt.avatar) $MVS($sckt.av_head_x) $MVS($sckt.av_head_y) [file size $MVS(avatars)/$MVS($sckt.avatar)] $MVS($sckt.av_baloon_x) $MVS($sckt.av_baloon_y)"
480 } else {
481 SendToUser $who "NEW $MVS($sckt.name) $MVS($sckt.x) $MVS($sckt.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
482 }
483 }
484 }
485 }
486 unset input who
487 return
488 }
489 Serv_ProcessInput $who $input
490 unset input who
491 }
492 #
493 # Authenticate transport systems
494 #
495 # Usage: TransAuth user_socket parms_list
496 #
497 # This function will authenticate transport systems.
498 #
499 # Transport systems are assigned a username and password by each server
500 # which registers with a transport system. Your transport registration
501 # information should be in your server.cfg file.
502 #
503 proc TransAuth {who what} {
504 global MVS
505
506 if {[llength $MVS(ORT_Server)] <= 0} {
507 LogIt "No ORTs Configured (not expecting this login, rejecting)"
508 SendToUser $who "AUTH REQD"
509 DisconnectUser $who 0
510 }
511 set what [string range $what [expr [string first " " $what] +1] end]
512 set parms [split $what]
513 #
514 # Login 0
515 # Password 1
516 # Image 2
517 # Image size 3
518 # Time 4
519 # OrtUserPort 5
520 # name 6-
521 set valid 0
522 for {set idx 0} {$idx < [llength $MVS(ORT_Server)] && !$valid} {incr idx} {
523 if {![string compare [lindex $MVS(ORT_Username) $idx] [lindex $parms 0]] && ![string compare [lindex $MVS(ORT_Password) $idx] [lindex $parms 1]]} {
524 # Valid ORT, You are welcome here.
525 set valid $idx
526 }
527 }
528 set idx $valid
529 unset valid
530 if {$idx >= 0} {
531 if {![file exists $MVS(avatars)/[lindex $parms 2]]} {
532 LogIt "(ORT - $who) [lindex $parms 2] does not exist"
533 set MVS($who.av_baloon_x) 0
534 set MVS($who.av_baloon_y) 0
535 GetBinaryFile $who [lindex $parms 2] [lindex $parms 3] ORT 0
536 } else {
537 LogIt "(ORT - $who) Image exists."
538 }
539 SendToUser $who "USERS [llength $MVS(socks)]"
540 SendToUser $who "REGISTERED"
541 DisconnectUser $who 0
542 DisplayORT $idx [lindex $parms 2] "[string range $what [expr [string first "|" $what] +1] end]" [lindex $parms 4] [lindex $parms 5]
543 } else {
544 LogIt "Invalid ORT (no login/password), Rejecting Connection."
545 SendToUser $who "AUTH REQD"
546 DisconnectUser $who 0
547 }
548 }
549 #
550 # Display Transport System
551 #
552 # Usage: TransAuth index image name time port
553 #
554 # This function will display the ORT to the users. It will schedule it to
555 # be destroyed later.
556 #
557 proc DisplayORT {idx image name time port} {
558 global MVS
559
560 set name_parts [split $name]
561 set name [join $name_parts "_"]
562 set parms [split [lindex $MVS(ORT_Location) $idx]]
563 set x [lindex $parms 0]
564 set y [lindex $parms 1]
565 set server_parms [split [lindex $MVS(ORT_Server) $idx] ":"]
566
567 set unique 1
568 foreach sck $MVS(socks) {
569 if {![string compare $name $MVS($sck.name)]} {
570 set unique 0
571 }
572 }
573 if {!$unique} {
574 append name "_(REAL)"
575 }
576
577 set MVS(ORT_info.$idx.image) $image
578 set MVS(ORT_info.$idx.name) $name
579 set MVS(ORT_info.$idx.host) [lindex $server_parms 0]
580 set MVS(ORT_info.$idx.port) $port
581 set MVS(ORT_info.$idx.time) $time
582 set MVS(ORT_info.$idx.x) [lindex $parms 0]
583 set MVS(ORT_info.$idx.y) [lindex $parms 1]
584 set MVS(ORT_current_ort) $idx
585
586 if {![file exists "$MVS(avatars)/$image"]} {
587 set image "default.gif"
588 }
589
590 if {$MVS(ORT.force)} {
591 set image $MVS(ORT.force.image)
592 }
593
594 SendToAllUsers "NEW $name [lindex $parms 0] [lindex $parms 1] $image 0 60 [file size $MVS(avatars)/$image] 66 -44"
595 SendToAllUsers "EXIT_OBJ ov_tram_exit [expr $x - 60] [expr $y - 60] [expr $x + 60] [expr $y + 60] 0 [lindex $server_parms 0] $port"
596 after [expr 500 * $time] "WarnOrt $idx"
597 }
598 #
599 # Announce transport departure.
600 #
601 # Usage: WarnOrt index
602 #
603 # This will announce that the transport is getting ready to leave.
604 #
605 proc WarnOrt {idx} {
606 global MVS
607
608 SendToAllUsers "CHAT $MVS(ORT_info.$idx.name) $MVS(ORT.msg)"
609 after [expr 500 * $MVS(ORT_info.$idx.time)] "KillOrt $idx"
610 }
611 #
612 # Remove transport.
613 #
614 # Usage: KillOrt: index
615 #
616 # Removes a transport telling all user's it's gone.
617 #
618 proc KillOrt {idx} {
619 global MVS
620
621 set MVS(ORT_current_ort) -1
622 SendToAllUsers "NOMORE $MVS(ORT_info.$idx.name)"
623 SendToAllUsers "EXIT_OBJ ov_tram_exit 0 0 0 0 1 dummyhost 0"
624 #
625 # Clean up the memory this ORT was using.
626 #
627 catch {unset MVS(ORT_info.$idx.host)}
628 catch {unset MVS(ORT_info.$idx.image)}
629 catch {unset MVS(ORT_info.$idx.name)}
630 catch {unset MVS(ORT_info.$idx.port)}
631 catch {unset MVS(ORT_info.$idx.time)}
632 catch {unset MVS(ORT_info.$idx.x)}
633 catch {unset MVS(ORT_info.$idx.y)}
634 }
635 #
636 # Disconnect users from the system.
637 #
638 # Usage: DisconnectUser socket announce_disconnect
639 #
640 # This function is used to disconnect a user from the system.
641 # A general cleanup will be done with the variables the user was
642 # consuming and an annoucement will be made to all connected users if it
643 # is requested with the announce_disconnect parameter (set to 1)
644 #
645 # CRUISE - 10/24/2001 - Fixing a bug which would make ending a DCC for
646 # a logged off user cause an error. UPDATE - Forgot to close listening
647 # sockets :) they're closed too when a user logs off.
648 #
649 proc DisconnectUser {who announce} {
650 global MVS
651
652 # Process Server Hooks.
653 #
654 # NOTE!!! YOU NEED TO BE DAMN SURE IF YOU ARE RETURNING 0 FROM
655 # YOUR HOOK TO THIS FUNCTION!
656 #
657 foreach hook $MVS(hooks.Connect) {
658 if {![$MVS(hooks.Connect.$hook) $who $announce]} {
659 return
660 }
661 }
662
663 if {[lsearch -exact $MVS(socks) $who] == -1} {return}
664 LogIt "($who)<- Disconnected! $MVS($who.address):$MVS($who.port)"
665 incr MVS(users) -1
666 if !$MVS(standalone) {
667 .ovserver.buttons.info.v configure -text $MVS(users)
668 }
669 catch {close $who}
670 set which [lsearch -exact $MVS(socks) $who]
671 set MVS(socks) [lreplace $MVS(socks) $which $which]
672
673 if $announce {
674 foreach sckt $MVS(socks) {
675 SendToUser $sckt "NOMORE $MVS($who.name)"
676 }
677 }
678 #
679 # Kill any DCC Transfers this user had going.
680 #
681 foreach idx $MVS(dcc_list) {
682 if {$MVS(DCC.$idx.sender) == $who} {
683 if {$MVS(DCC.$idx.server) > 0} {
684 catch {close $MVS(DCC.$idx.server)}
685 }
686 Serv_endDCC Logout $idx 0 "User Disconnected - $MVS(DCC.$idx.file)"
687 }
688 }
689 #
690 # Clean up the mess this user made!
691 #
692 catch {unset MVS($who.name)}
693 catch {unset MVS($who.downloads)}
694 catch {unset MVS($who.address)}
695 catch {unset MVS($who.av_baloon_x)}
696 catch {unset MVS($who.av_baloon_y)}
697 catch {unset MVS($who.av_head_x)}
698 catch {unset MVS($who.av_head_y)}
699 catch {unset MVS($who.avatar)}
700 catch {unset MVS($who.ping)}
701 catch {unset MVS($who.ping_response)}
702 catch {unset MVS($who.port)}
703 catch {unset MVS($who.x)}
704 catch {unset MVS($who.y)}
705 catch {unset MVS($who.flood)}
706 catch {unset MVS($who.time)}
707 catch {unset MVS($sck.ig.av)}
708 catch {unset MVS($sck.ig.effect)}
709 catch {unset MVS($sck.ig.move)}
710 catch {unset MVS($sck.ig.chat)}
711 catch {unset MVS($sck.ig.sub)}
712 catch {unset MVS($sck.ig.url)}
713 catch {unset MVS($sck.ig.all)}
714 }
715 #
716 # Flood Checker
717 #
718 # Usage: FloodCheck who
719 #
720 # This process keeps track of how much information the user has
721 # Sent to the server in how much time. It's used to disconnect
722 # malicious users. See the MVS(flood_threshold) variable to
723 # Change the ammount of flood a user is allowed.
724 #
725 proc FloodCheck {who} {
726 global MVS
727
728 incr MVS($who.flood)
729 if {$MVS($who.flood) >= $MVS(flood_threshold)} {
730 if {[clock seconds] == $MVS($who.time)} {
731 SendToUser $who "CHAT $MVS($who.name) You are being booted for flooding"
732 LogIt "($who) <- FLOODER (IP is $MVS($who.address) - BOOTING!"
733 DisconnectUser $who 1
734 return 1
735 } else {
736 set MVS($who.flood) 0
737 set MVS($who.time) [clock seconds]
738 }
739 }
740 return 0
741 }
742 #
743 # Send Text To a Connect User
744 #
745 # Usage: SendToUser socket "text to send"
746 #
747 # This function will send the provided text to the user specified
748 # It should be pre-formated and ready to go.
749 #
750 proc SendToUser {who what} {
751 LogIt "($who)-> $what"
752 catch {puts $who "$what"}
753 unset who what
754 }
755 #
756 # Process Input from users.
757 #
758 # Usage: Serv_ProcessInput socket "text to process"
759 #
760 # This function is the root of the protocol. It processes all of the
761 # things which a client can send to the server. If the client sends
762 # something it does not understand... it will ignore it. Please see the
763 # protocol documentation within the technical documentation for a complete
764 # descritption of the logic within this function.
765 #
766 proc Serv_ProcessInput {who what} {
767 global MVS
768
769 LogIt "($who)<- $what"
770 # Process hooks.
771 #
772 # If 0 is returned then we will ignore the input.
773 #
774 foreach hook $MVS(hooks.Input) {
775 if {![$MVS(hooks.Input.$hook) $who $what]} {
776 return
777 }
778 }
779
780 if {[string first " " $what] != -1} {
781 set cmd [string range $what 0 [expr [string first " " $what] -1]]
782 set rest [string range $what [expr [string first " " $what] +1] end]
783 set parms [split $rest " "]
784 } else {
785 set cmd $what
786 set rest ""
787 set parms {}
788 }
789 switch -exact -- $cmd {
790 "MOVE" {
791 if {[FloodCheck $who]} {return}
792 #
793 #fixes a bug that MVSbMVS found.
794 #
795 set retflag 0
796 if {[TestNum [lindex $parms 1]] || \
797 [TestNum [lindex $parms 2]] || \
798 [TestNum [lindex $parms 3]]} {set retflag 1}
799 if {[string length [lindex $parms 1]] > 4} {set retflag 1}
800 if {[string length [lindex $parms 2]] > 4} {set retflag 1}
801 if {[string length [lindex $parms 3]] > 2} {set retflag 1}
802 if {[lindex $parms 1] < 0} {set retflag 1}
803 if {[lindex $parms 2] < 0} {set retflag 1}
804 if {[lindex $parms 3] < 0} {set retflag 1}
805 if $retflag {
806 unset cmd rest parms retflag
807 return
808 }
809 set MVS($who.x) [lindex $parms 1]
810 set MVS($who.y) [lindex $parms 2]
811 set is_exiting 0
812 set idx 0
813 foreach exit $MVS(exits) {
814 set exl [split $exit " "]
815 set x1 [lindex $exl 0]
816 set y1 [lindex $exl 1]
817 set x2 [lindex $exl 2]
818 set y2 [lindex $exl 3]
819 if {$MVS($who.x) > $x1 && \
820 $MVS($who.x) < $x2 && \
821 $MVS($who.y) > $y1 && \
822 $MVS($who.y) < $y2} {
823 set is_exiting 1
824 set eidx $idx
825 }
826 incr idx
827 unset exl x1 y1 x2 y2
828 }
829 # Process hooks.
830 #
831 # If 0 is returned then we will stop processing.
832 #
833 foreach hook $MVS(hooks.Move) {
834 if {![$MVS(hooks.Move.$hook) $who $is_exiting]} {
835 return
836 }
837 }
838
839 # Ignorable. We send to each from here.
840 foreach w $MVS(socks) {
841 if {[lsearch -exact $MVS(