#!/usr/bin/tclsh
# OpenVerse Server Program
#
# This is the server code! :)
#
# Module Name - Server Program
# Current Maintainter - Cruise <cruise@openverse.org>
# Sourced By - Command Line Or Client
#
# Copyright (C) 1999-2001 David Gale <cruise@openverse.org>
# For more information visit http://OpenVerse.org/
#
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
# USA.
#
#
# FIRST - Setup some server variables.
#
# Please see the Technical Help section of the documentation in your
# client software for a complete list of variables and their descriptions.
# Whenever possible, they have been described here in the code too.
#
global MVS tcl_interactive
# -----------------------------------------------------------------------
set MVS(log) 1; # Do we output our logs at all?
set MVS(log_scroll) 1; # Do we scroll the log file in GUI mode?
set MVS(waiter) 1; # Sleeper variable for a dedicated server.
set MVS(serving) 1; # Is server running?
set MVS(users) 0; # Total number of conected users.
set MVS(socks) {}; # List of connected users.
set MVS(tell_registry) {}; # List of objects with TELL registry needs.
set MVS(entry_registry) {}; # List of object with ENTRY registry needs.
set MVS(submit_registry) {}; # List of objects with SUBMIT reigstry needs.
set MVS(registry.servers) {}; # List of objects in the SERVERS registry. (Used with ORT Registrations
set MVS(ORT_current_ort) -1; # Is an ORT stopped at our server? -1 is no.
set MVS(dcc_list) {}; # A list of active file transfers.
set MVS(dcc_num) 0; # Self incremening list of transfer IDs
set MVS(hooks.Connect) {}; # List of hooks for new connections.
set MVS(hooks.DisconnectUser) {}; # List of hooks for DisconnectUser
set MVS(hooks.Move) {}; # List of hooks for MOVE Commands.
set MVS(hooks.Input) {}; # List of hooks for general input
set MVS(hooks.Chat) {}; # List of hooks for CHAT commands.
# -----------------------------------------------------------------------
#
# Central Logging Facility
#
# Usage: LogIt "Text To Log"
#
# Everything uses this so we must define it first.
# CRUISE - 10/23/2001 - Added a time stamp (duh!)
# CRUISE - 10/23/2001 - Added a ability to shut off logs.
#
proc LogIt {text} {
global MVS
if {!$MVS(log)} {return}
set timestamp [clock format [clock seconds] -format "%b %d %Y - %T"]
if $MVS(standalone) {
# we are running from a command line
puts "$timestamp -- $text"
} else {
# we are running from a gui
if {[winfo exists .ovserver]} {
.ovserver.log.text insert end "$timestamp -- $text\n"
if {$MVS(log_scroll)} {
.ovserver.log.text see end
}
# TODO (6) Check for number of lines and trim.
}
}
unset text
}
#
# Send text to ALL users.
#
# Usage: SendToAllUsers "Text To Send"
#
# This function will send the provided text to all connected users. The
# text should be pre-formated and ready to go.
#
proc SendToAllUsers {what} {
global MVS
foreach sckt $MVS(socks) {
if [string compare $MVS($sckt.name) "*"] {
LogIt "($sckt)-> $what"
catch {puts $sckt "$what"}
}
}
unset what
}
# Server Hooks Registration
#
# Call thusly....
# RegisterHook ModuleName HookName YourFunction
#
# When a hook is activated, it will check the return value of the
# function. If it is 0, it will not continue it's normal processing. You
# should always return 1 unless you are sure you don't want the server to
# continue with the function it was processing!!!!
#
# Available hooks {and the parameters they call with} include.....
#
# ------------------------------------
# Connect {$who}
# ------------------------------------
# DisconnectUser {$who $announce}
# ------------------------------------
# Move {$who $is_exiting}
# ------------------------------------
# Input {$who $what}
# ------------------------------------
# Chat {$who $what}
# ------------------------------------
#
proc RegisterHook {module hook func} {
global MVS
lappend MVS(hooks.$hook) $module
lappend MVS(hooks.$hook.$module) $func
}
#
# (re)Load the server config file.
#
# Usage: ReloadConfig
#
# This function will (re)load the server config file. Any changes will
# take effect at the time of reload.
#
# CRUISE - 10/25/2001 - The maxusers variable was blank by default, now it's set to 100
# CRUISE - 11/08/2001 - Moved things around a bit, added some docs to the variables.
#
proc ReloadConfig {} {
global MVS
LogIt "------------ Loading Config File -----------"
#
# Basic Server Settings.
#
set MVS(port) "7000"; # What port the server is runing on.
set MVS(timeout) 120; # Seconds to wait before calling a transfer failed.
set MVS(roomname) "My Own Room"; # The name of this room.
set MVS(maxheight) "200"; # Maximum allowed image height
set MVS(maxwidth) "320"; # Maximum Allowed Image Width.
set MVS(push) 1; # Does the server support pushing?
set MVS(sendbuffer) 4096; # Sending buffer size for file transfers.
set MVS(maxmsglen) 256; # Maximum lengs of messages which the server accepts.
set MVS(flood_threshold) 10; # Maximum things a user can send before they are flooded offline.
set MVS(exits) {}; # A list of exit server:port entries.
set MVS(locations) {}; # A list of coords for the EXIT type exits.
set MVS(maxpushdistance) 100; # How far (pixels) can we push someone?
set MVS(maxpushvelocity) 100; # How fast can we push them?
set MVS(max_same_users) 10; # Maximum users from the same host.
set MVS(maxusers) 100; # Maximum number of users allowed to log in.
set MVS(max_ignores) 50; # Maximum users you may ignore (per type)
set MVS(max_socket_retries) 20; # Maximum times we will try to open a socket on a busy day.
set MVS(retry_wait_time) 300; # Time to wait between retries to open a new socket.
#
# File and dir names
#
set MVS(avatars) "$MVS(homedir)/simages"; # Where the remote user's avatars will be placed.
set MVS(sobjects) "$MVS(homedir)/sobjects"; # The directory where avatars are stored.
set MVS(images) "$MVS(homedir)/images"; # Where our images are stored.
set MVS(icons) "$MVS(homedir)/icons"; # Where our icons are stored
set MVS(tickler) "$MVS(homedir)/TickleMe"; # Config File Tickler, reload config when it exists.
set MVS(mem_tickler) "$MVS(homedir)/TickleMem"; # Memory tickler - Dump mem when it exists.
set MVS(roomdir) "$MVS(homedir)/rooms"; # The directory where room images are stored.
set MVS(roomfile) "room.gif"; # The name (not the full path) of the room image.
#
# ORT Section
#
set MVS(register_ort) 1; # Should we register with the ort?
set MVS(ORT_Admin) "Joe Admin"; # The Admin's name
set MVS(ORT_AdminEmail) "openverse@openverse.org"; # The Admin's email address.
set MVS(ORT_Country) "United States"; # The country this server is in.
set MVS(ORT_Description) "Description Not Set!"; # A brief description of this server.
set MVS(ORT_Image) "ov_tram_logo.gif"; # Our banner image for the ORT
set MVS(ORT_Rating) "PG"; # Our content Rating.
set MVS(ORT_WebSite) "http://openverse.org/"; # This server's website address.
set MVS(ORT_Server) {}; # A list of ORT server:port values.
set MVS(ORT_Username) {}; # A list of ORT username values for each server.
set MVS(ORT_Password) {}; # A list of ORT passwords for each server.
set MVS(ORT_Location) {}; # A list of ORT screen locations for each server.
set MVS(ORT.force) 0; # Force the ORT image?
set MVS(ORT.force.image) "default.gif"; # Force the ORT image?
set MVS(ORT.msg) "All Aboard!!!"; # What does the ORT say?
#
# Create required directories.
#
if ![file exists $MVS(avatars)] {file mkdir "$MVS(avatars)"}
if ![file exists $MVS(sobjects)] {file mkdir "$MVS(sobjects)"}
if ![file exists $MVS(images)] {file mkdir "$MVS(images)"}
if ![file exists $MVS(roomdir)] {file mkdir "$MVS(roomdir)"}
if ![file exists $MVS(icons)] {file mkdir "$MVS(icons)"}
#
# reset the variables as we want them to be.
#
if [file exists "$MVS(configfile)"] {source $MVS(configfile)}
if [file exists "$MVS(tickler)"] {
catch {
file delete -force "$MVS(tickler)"
}
}
if [file exists "$MVS(mem_tickler)"] {
catch {
file delete -force "$MVS(mem_tickler)"
}
}
#
# These might have changed, lets send them just in case.
#
SendToAllUsers "ROOMNAME $MVS(roomname)"
SendToAllUsers "ROOM $MVS(roomfile) [file size "$MVS(roomdir)/$MVS(roomfile)"]"
}
#
# Accept New Connections.
#
# Usage: NewConnect socket address port
#
# This function will accept a new connection and setup some initial
# variables for the user. It will also set a trigger on the incoming
# socket which will read data on the socket.
#
# CRUISE - 10/25/2001 - Made the maxusers variable actually do something.
#
proc NewConnect {sck address port} {
global MVS
LogIt "($sck)<- New Connection! $address:$port"
fconfigure $sck -blocking 0 -buffering line
fileevent $sck readable "Serv_ReadFrom $sck"
if {[lsearch $MVS(socks) $sck] == -1} {
lappend MVS(socks) $sck
} else {
close $sck
unset sck address port
return
}
set MVS($sck.name) "*"
set MVS($sck.flood) 0
set MVS($sck.time) [clock seconds]
set MVS($sck.address) "$address"
set MVS($sck.port) "$port"
set MVS($sck.ping) 0
set MVS($sck.ping_response) [clock seconds]
set MVS($sck.x) -1
set MVS($sck.y) -1
set MVS($sck.avatar) "*connecting*"
set MVS($sck.av_head_x) "-1"
set MVS($sck.av_head_y) "-1"
set MVS($sck.av_baloon_x) "-1"
set MVS($sck.av_baloon_y) "-1"
set MVS($sck.downloads) {}
set MVS($sck.ig.av) {}
set MVS($sck.ig.effect) {}
set MVS($sck.ig.move) {}
set MVS($sck.ig.chat) {}
set MVS($sck.ig.sub) {}
set MVS($sck.ig.url) {}
set MVS($sck.ig.all) {}
incr MVS(users)
if !$MVS(standalone) {
.ovserver.buttons.info.v configure -text $MVS(users)
}
set count 0
foreach sock $MVS(socks) {
if {$MVS($sock.address) == $address} {incr count}
}
if {$count > $MVS(max_same_users)} {
SendToUser $sck "TOOMANYCONNECTIONS"
DisconnectUser $sck 0
}
if {[llength $MVS(socks)] >= $MVS(maxusers)} {
SendToUser $sck "ROOMFULL"
DisconnectUser $sck 0
}
unset sck address port
}
#
# Check name validity.
#
# Usage: CheckName "NickName"
#
# this function will check a given nickname to be sure it is allowed. Some
# nicknames are not allowed if they contain special characters.
#
proc CheckName {name} {
if {[string trim $name] == "" || \
[string trim $name] == "*" || \
[string trim $name] == "." || \
[string range $name 0 0] == "-"} {
unset name
return 0
} else {
unset name
return 1
}
}
#
# Read Incomming Text
#
# Usage: Serv_ReadFrom socket
#
# This function will read text from a socket and process it. If the user
# is not authenticated, it will authenticate them. If the user is just
# requesting a number of connected users, this function will process the
# request. If it has nothing to do other than to read the text, it will
# pass this text off to the Serv_ProcessInput function for processing.
#
proc Serv_ReadFrom {who} {
global MVS
set input ""
catch {gets $who input}
# Update before we process anything!
if {[eof $who] == 1} {
if {![string compare $MVS($who.name) "*"]} {
DisconnectUser $who 0
} else {
DisconnectUser $who 1
}
unset input who
return
}
if {![string compare $MVS($who.name) "*"]} {
#
# User is not logged in yet.
#
LogIt "<- $input"
set Srv_Cmd [lindex [split $input " "] 0]
switch -- $Srv_Cmd {
"USERS" {
SendToUser $who "USERS [expr [llength $MVS(socks)] -1]"
DisconnectUser $who 0
return
}
"TRANS" {
TransAuth $who $input
return
}
"AUTH" {
# For now allow it to just pass through.
# User auth needs to be broken out of this
# function and sent to it's own function.
}
default {
SendToUser $who "AUTH REQD"
DisconnectUser $who 0
}
}
set parms [split [string range $input 5 end] " "]
if {[TestNum [lindex $parms 1]] || \
[TestNum [lindex $parms 2]] || \
[TestNum [lindex $parms 4]] || \
[TestNum [lindex $parms 5]] || \
[TestNum [lindex $parms 6]] || \
[TestNum [lindex $parms 7]] || \
[TestNum [lindex $parms 8]] } {
SendToUser $who "AUTH FAILED (Non Numeric)"
DisconnectUser $who 0
unset input who
return
}
if {[string length [lindex $parms 1]] > 3 || \
[string length [lindex $parms 2]] > 3 || \
[string length [lindex $parms 4]] > 4 || \
[string length [lindex $parms 5]] > 4 || \
[string length [lindex $parms 6]] > 6 || \
[string length [lindex $parms 7]] > 4 || \
[string length [lindex $parms 8]] > 4 || \
[lindex $parms 1] < 0 || \
[lindex $parms 2] < 0 || \
[lindex $parms 6] < 0} {
SendToUser $who "AUTH FAILED (String Lengths)"
DisconnectUser $who 0
unset input who
return
}
set MVS($who.name) [string range [lindex $parms 0] 0 12]
set MVS($who.x) [lindex $parms 1]
set MVS($who.y) [lindex $parms 2]
set MVS($who.avatar) [lindex $parms 3]
set MVS($who.av_head_x) [lindex $parms 4]
set MVS($who.av_head_y) [lindex $parms 5]
set MVS($who.av_baloon_x) [lindex $parms 7]
set MVS($who.av_baloon_y) [lindex $parms 8]
set size [lindex $parms 6]
if ![CheckName $MVS($who.name)] {
SendToUser $who "BADNAME"
DisconnectUser $who 0
unset input parms size who
return
}
foreach sckt $MVS(socks) {
if {![string compare $MVS($sckt.name) $MVS($who.name)] && [string compare $sckt $who]} {
SendToUser $who "NAMEINUSE"
DisconnectUser $who 0
unset input parms size sckt who
return
}
}
# User is logged in now. But no one can see him
# and we have not told him about anyone else. at
# this point, a server object may want to
# disconnect the user. If this returns 0, we will
# disconnect the
# user (the object should have sent notification)
foreach hook $MVS(hooks.Connect) {
if {![$MVS(hooks.Connect.$hook) $who]} {
# dont notify cause no one knew
# they were here.
DisconnectUser $who 0
return
}
}
SendToUser $who "ROOMNAME $MVS(roomname)"
SendToUser $who "ROOM $MVS(roomfile) [file size $MVS(roomdir)/$MVS(roomfile)]"
#
# If we have an ORT stopped, display it.
#
if {$MVS(ORT_current_ort) != -1} {
if {![file exists "$MVS(avatars)/$MVS(ORT_info.$MVS(ORT_current_ort).image)"]} {
set image "default.gif"
} else {
set image "$MVS(ORT_info.$MVS(ORT_current_ort).image)"
}
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"
set a $MVS(ORT_info.$MVS(ORT_current_ort).x)
set b $MVS(ORT_info.$MVS(ORT_current_ort).y)
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)"
}
#
# This is where server objects happen.
#
SendObjects $who
if ![file exists $MVS(avatars)/$MVS($who.avatar)] {
SendToAllUsers "NEW $MVS($who.name) $MVS($who.x) $MVS($who.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
LogIt "($who) $MVS($who.avatar) does not exist"
GetBinaryFile $who $MVS($who.avatar) $size AVATAR 0
} else {
if {[file size $MVS(avatars)/$MVS($who.avatar)] != $size} {
SendToAllUsers "NEW $MVS($who.name) $MVS($who.x) $MVS($who.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
LogIt "($who) $MVS($who.avatar) $size != [file size $MVS(avatars)/$MVS($who.avatar)]"
GetBinaryFile $who $MVS($who.avatar) $size AVATAR 0
} else {
if [CheckGif "$MVS(avatars)/$MVS($who.avatar)"] {
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)"
} else {
SendToAllUsers "NEW $MVS($who.name) $MVS($who.x) $MVS($who.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
SendToUser $who "TOOBIG"
set MVS($who.avatar) "default.gif"
}
}
}
foreach sckt $MVS(socks) {
if [string compare $MVS($sckt.name) "*"] {
if {[string compare $MVS($sckt.name) $MVS($who.name)]} {
if [file exists $MVS(avatars)/$MVS($sckt.avatar)] {
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)"
} else {
SendToUser $who "NEW $MVS($sckt.name) $MVS($sckt.x) $MVS($sckt.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
}
}
}
}
unset input who
return
}
Serv_ProcessInput $who $input
unset input who
}
#
# Authenticate transport systems
#
# Usage: TransAuth user_socket parms_list
#
# This function will authenticate transport systems.
#
# Transport systems are assigned a username and password by each server
# which registers with a transport system. Your transport registration
# information should be in your server.cfg file.
#
proc TransAuth {who what} {
global MVS
if {[llength $MVS(ORT_Server)] <= 0} {
LogIt "No ORTs Configured (not expecting this login, rejecting)"
SendToUser $who "AUTH REQD"
DisconnectUser $who 0
}
set what [string range $what [expr [string first " " $what] +1] end]
set parms [split $what]
#
# Login 0
# Password 1
# Image 2
# Image size 3
# Time 4
# OrtUserPort 5
# name 6-
set valid 0
for {set idx 0} {$idx < [llength $MVS(ORT_Server)] && !$valid} {incr idx} {
if {![string compare [lindex $MVS(ORT_Username) $idx] [lindex $parms 0]] && ![string compare [lindex $MVS(ORT_Password) $idx] [lindex $parms 1]]} {
# Valid ORT, You are welcome here.
set valid $idx
}
}
set idx $valid
unset valid
if {$idx >= 0} {
if {![file exists $MVS(avatars)/[lindex $parms 2]]} {
LogIt "(ORT - $who) [lindex $parms 2] does not exist"
set MVS($who.av_baloon_x) 0
set MVS($who.av_baloon_y) 0
GetBinaryFile $who [lindex $parms 2] [lindex $parms 3] ORT 0
} else {
LogIt "(ORT - $who) Image exists."
}
SendToUser $who "USERS [llength $MVS(socks)]"
SendToUser $who "REGISTERED"
DisconnectUser $who 0
DisplayORT $idx [lindex $parms 2] "[string range $what [expr [string first "|" $what] +1] end]" [lindex $parms 4] [lindex $parms 5]
} else {
LogIt "Invalid ORT (no login/password), Rejecting Connection."
SendToUser $who "AUTH REQD"
DisconnectUser $who 0
}
}
#
# Display Transport System
#
# Usage: TransAuth index image name time port
#
# This function will display the ORT to the users. It will schedule it to
# be destroyed later.
#
proc DisplayORT {idx image name time port} {
global MVS
set name_parts [split $name]
set name [join $name_parts "_"]
set parms [split [lindex $MVS(ORT_Location) $idx]]
set x [lindex $parms 0]
set y [lindex $parms 1]
set server_parms [split [lindex $MVS(ORT_Server) $idx] ":"]
set unique 1
foreach sck $MVS(socks) {
if {![string compare $name $MVS($sck.name)]} {
set unique 0
}
}
if {!$unique} {
append name "_(REAL)"
}
set MVS(ORT_info.$idx.image) $image
set MVS(ORT_info.$idx.name) $name
set MVS(ORT_info.$idx.host) [lindex $server_parms 0]
set MVS(ORT_info.$idx.port) $port
set MVS(ORT_info.$idx.time) $time
set MVS(ORT_info.$idx.x) [lindex $parms 0]
set MVS(ORT_info.$idx.y) [lindex $parms 1]
set MVS(ORT_current_ort) $idx
if {![file exists "$MVS(avatars)/$image"]} {
set image "default.gif"
}
if {$MVS(ORT.force)} {
set image $MVS(ORT.force.image)
}
SendToAllUsers "NEW $name [lindex $parms 0] [lindex $parms 1] $image 0 60 [file size $MVS(avatars)/$image] 66 -44"
SendToAllUsers "EXIT_OBJ ov_tram_exit [expr $x - 60] [expr $y - 60] [expr $x + 60] [expr $y + 60] 0 [lindex $server_parms 0] $port"
after [expr 500 * $time] "WarnOrt $idx"
}
#
# Announce transport departure.
#
# Usage: WarnOrt index
#
# This will announce that the transport is getting ready to leave.
#
proc WarnOrt {idx} {
global MVS
SendToAllUsers "CHAT $MVS(ORT_info.$idx.name) $MVS(ORT.msg)"
after [expr 500 * $MVS(ORT_info.$idx.time)] "KillOrt $idx"
}
#
# Remove transport.
#
# Usage: KillOrt: index
#
# Removes a transport telling all user's it's gone.
#
proc KillOrt {idx} {
global MVS
set MVS(ORT_current_ort) -1
SendToAllUsers "NOMORE $MVS(ORT_info.$idx.name)"
SendToAllUsers "EXIT_OBJ ov_tram_exit 0 0 0 0 1 dummyhost 0"
#
# Clean up the memory this ORT was using.
#
catch {unset MVS(ORT_info.$idx.host)}
catch {unset MVS(ORT_info.$idx.image)}
catch {unset MVS(ORT_info.$idx.name)}
catch {unset MVS(ORT_info.$idx.port)}
catch {unset MVS(ORT_info.$idx.time)}
catch {unset MVS(ORT_info.$idx.x)}
catch {unset MVS(ORT_info.$idx.y)}
}
#
# Disconnect users from the system.
#
# Usage: DisconnectUser socket announce_disconnect
#
# This function is used to disconnect a user from the system.
# A general cleanup will be done with the variables the user was
# consuming and an annoucement will be made to all connected users if it
# is requested with the announce_disconnect parameter (set to 1)
#
# CRUISE - 10/24/2001 - Fixing a bug which would make ending a DCC for
# a logged off user cause an error. UPDATE - Forgot to close listening
# sockets :) they're closed too when a user logs off.
#
proc DisconnectUser {who announce} {
global MVS
# Process Server Hooks.
#
# NOTE!!! YOU NEED TO BE DAMN SURE IF YOU ARE RETURNING 0 FROM
# YOUR HOOK TO THIS FUNCTION!
#
foreach hook $MVS(hooks.Connect) {
if {![$MVS(hooks.Connect.$hook) $who $announce]} {
return
}
}
if {[lsearch -exact $MVS(socks) $who] == -1} {return}
LogIt "($who)<- Disconnected! $MVS($who.address):$MVS($who.port)"
incr MVS(users) -1
if !$MVS(standalone) {
.ovserver.buttons.info.v configure -text $MVS(users)
}
catch {close $who}
set which [lsearch -exact $MVS(socks) $who]
set MVS(socks) [lreplace $MVS(socks) $which $which]
if $announce {
foreach sckt $MVS(socks) {
SendToUser $sckt "NOMORE $MVS($who.name)"
}
}
#
# Kill any DCC Transfers this user had going.
#
foreach idx $MVS(dcc_list) {
if {$MVS(DCC.$idx.sender) == $who} {
if {$MVS(DCC.$idx.server) > 0} {
catch {close $MVS(DCC.$idx.server)}
}
Serv_endDCC Logout $idx 0 "User Disconnected - $MVS(DCC.$idx.file)"
}
}
#
# Clean up the mess this user made!
#
catch {unset MVS($who.name)}
catch {unset MVS($who.downloads)}
catch {unset MVS($who.address)}
catch {unset MVS($who.av_baloon_x)}
catch {unset MVS($who.av_baloon_y)}
catch {unset MVS($who.av_head_x)}
catch {unset MVS($who.av_head_y)}
catch {unset MVS($who.avatar)}
catch {unset MVS($who.ping)}
catch {unset MVS($who.ping_response)}
catch {unset MVS($who.port)}
catch {unset MVS($who.x)}
catch {unset MVS($who.y)}
catch {unset MVS($who.flood)}
catch {unset MVS($who.time)}
catch {unset MVS($sck.ig.av)}
catch {unset MVS($sck.ig.effect)}
catch {unset MVS($sck.ig.move)}
catch {unset MVS($sck.ig.chat)}
catch {unset MVS($sck.ig.sub)}
catch {unset MVS($sck.ig.url)}
catch {unset MVS($sck.ig.all)}
}
#
# Flood Checker
#
# Usage: FloodCheck who
#
# This process keeps track of how much information the user has
# Sent to the server in how much time. It's used to disconnect
# malicious users. See the MVS(flood_threshold) variable to
# Change the ammount of flood a user is allowed.
#
proc FloodCheck {who} {
global MVS
incr MVS($who.flood)
if {$MVS($who.flood) >= $MVS(flood_threshold)} {
if {[clock seconds] == $MVS($who.time)} {
SendToUser $who "CHAT $MVS($who.name) You are being booted for flooding"
LogIt "($who) <- FLOODER (IP is $MVS($who.address) - BOOTING!"
DisconnectUser $who 1
return 1
} else {
set MVS($who.flood) 0
set MVS($who.time) [clock seconds]
}
}
return 0
}
#
# Send Text To a Connect User
#
# Usage: SendToUser socket "text to send"
#
# This function will send the provided text to the user specified
# It should be pre-formated and ready to go.
#
proc SendToUser {who what} {
LogIt "($who)-> $what"
catch {puts $who "$what"}
unset who what
}
#
# Process Input from users.
#
# Usage: Serv_ProcessInput socket "text to process"
#
# This function is the root of the protocol. It processes all of the
# things which a client can send to the server. If the client sends
# something it does not understand... it will ignore it. Please see the
# protocol documentation within the technical documentation for a complete
# descritption of the logic within this function.
#
proc Serv_ProcessInput {who what} {
global MVS
LogIt "($who)<- $what"
# Process hooks.
#
# If 0 is returned then we will ignore the input.
#
foreach hook $MVS(hooks.Input) {
if {![$MVS(hooks.Input.$hook) $who $what]} {
return
}
}
if {[string first " " $what] != -1} {
set cmd [string range $what 0 [expr [string first " " $what] -1]]
set rest [string range $what [expr [string first " " $what] +1] end]
set parms [split $rest " "]
} else {
set cmd $what
set rest ""
set parms {}
}
switch -exact -- $cmd {
"MOVE" {
if {[FloodCheck $who]} {return}
#
#fixes a bug that MVSbMVS found.
#
set retflag 0
if {[TestNum [lindex $parms 1]] || \
[TestNum [lindex $parms 2]] || \
[TestNum [lindex $parms 3]]} {set retflag 1}
if {[string length [lindex $parms 1]] > 4} {set retflag 1}
if {[string length [lindex $parms 2]] > 4} {set retflag 1}
if {[string length [lindex $parms 3]] > 2} {set retflag 1}
if {[lindex $parms 1] < 0} {set retflag 1}
if {[lindex $parms 2] < 0} {set retflag 1}
if {[lindex $parms 3] < 0} {set retflag 1}
if $retflag {
unset cmd rest parms retflag
return
}
set MVS($who.x) [lindex $parms 1]
set MVS($who.y) [lindex $parms 2]
set is_exiting 0
set idx 0
foreach exit $MVS(exits) {
set exl [split $exit " "]
set x1 [lindex $exl 0]
set y1 [lindex $exl 1]
set x2 [lindex $exl 2]
set y2 [lindex $exl 3]
if {$MVS($who.x) > $x1 && \
$MVS($who.x) < $x2 && \
$MVS($who.y) > $y1 && \
$MVS($who.y) < $y2} {
set is_exiting 1
set eidx $idx
}
incr idx
unset exl x1 y1 x2 y2
}
# Process hooks.
#
# If 0 is returned then we will stop processing.
#
foreach hook $MVS(hooks.Move) {
if {![$MVS(hooks.Move.$hook) $who $is_exiting]} {
return
}
}
# Ignorable. We send to each from here.
foreach w $MVS(socks) {
if {[lsearch -exact $MVS($w.ig.move) $MVS($who.name)] == -1} {
SendToUser $w "MOVE $MVS($who.name) [lindex $parms 1] [lindex $parms 2] [lindex $parms 3]"
}
}
if $is_exiting {
SendToUser $who "EXIT [lindex $MVS(locations) $eidx]"
unset eidx
}
unset idx is_exiting retflag
}
"QUERY" {
if {[FloodCheck $who]} {return}
switch -- [lindex $parms 0] {
"POS_ALL" {
foreach person $MVS(socks) {
SendToUser $who "MOVE $MVS($person.name) $MVS($person.x) $MVS($person.y) 50"
}
}
}
}
"PUSH" {
if {[FloodCheck $who]} {return}
if !$MVS(push) {return}
set retflag 0
if {[lindex $parms 0] == ""} {set retflag 1}
set velocity [lindex $parms 0]
if {[TestNum $velocity]} {set retflag 1}
if $retflag {
unset cmd rest parms retflag velocity
return
}
if { $velocity > $MVS(maxpushvelocity)} {set velocity $MVS(maxpushvelocity)}
if { $velocity < 0} {set velocity 1}
foreach s $MVS(socks) {
if {![string compare $who $s]} {continue}
if {$MVS($who.x) >= $MVS($s.x)} {
set xdistance [expr $MVS($who.x) - $MVS($s.x)]
set xpush "-"
} else {
set xdistance [expr $MVS($s.x) - $MVS($who.x)]
set xpush "+"
}
if {$MVS($who.y) >= $MVS($s.y)} {
set ydistance [expr $MVS($who.y) - $MVS($s.y)]
set ypush "-"
} else {
set ydistance [expr $MVS($s.y) - $MVS($who.y)]
set ypush "+"
}
if {$xdistance <= $MVS(maxpushdistance) && $ydistance <= $MVS(maxpushdistance)} {
LogIt "(PUSH) $xdistance $ydistance $xpush $ypush $velocity"
set MVS($s.x) [expr $MVS($s.x) $xpush ($velocity - $ydistance)]
set MVS($s.y) [expr $MVS($s.y) $ypush ($velocity - $xdistance)]
if {$MVS($s.x) <= 0 } {set MVS($s.x) 10}
if {$MVS($s.y) <= 0 } {set MVS($s.y) 10}
if {$MVS($s.x) >= 640 } {set MVS($s.x) 630}
if {$MVS($s.y) >= 480 } {set MVS($s.y) 470}
set is_exiting 0
set idx 0
foreach exit $MVS(exits) {
set exl [split $exit " "]
set x1 [lindex $exl 0]
set y1 [lindex $exl 1]
set x2 [lindex $exl 2]
set y2 [lindex $exl 3]
if {$MVS($s.x) > $x1 && \
$MVS($s.x) < $x2 && \
$MVS($s.y) > $y1 && \
$MVS($s.y) < $y2} {
set is_exiting 1
set eidx $idx
}
incr idx
}
catch {unset exl}
if $is_exiting {
SendToUser $s "PUSH $MVS($s.x) $MVS($s.y) 20"
SendToAllUsers "MOVE $MVS($s.name) $MVS($s.x) $MVS($s.y) 20"
SendToUser $s "EXIT [lindex $MVS(locations) $eidx]"
} else {
SendToUser $s "PUSH $MVS($s.x) $MVS($s.y) 20"
SendToAllUsers "MOVE $MVS($s.name) $MVS($s.x) $MVS($s.y) 20"
}
}
}
catch {
unset retflag velocity xdistance xpush ydistance \
ypush is_exiting idx x1 y1 x2 y2 eidx
}
}
"SEND" {
if ![SanityCheck [lindex $parms 0]] {return}
SendBinaryFile $who [lindex $parms 0]
}
"DCCSENDAV" {
if ![SanityCheck [lindex $parms 0]] {return}
Serv_DCCSend $who [lindex $parms 0] AVATAR 0
}
"DCCSENDOB" {
if ![SanityCheck [lindex $parms 0]] {return}
Serv_DCCSend $who [lindex $parms 0] OBJECT 0
}
"DCCSENDROOM" {
if {[FloodCheck $who]} {return}
if ![SanityCheck [lindex $parms 0]] {return}
Serv_DCCSend $who [lindex $parms 0] ROOM 0
}
"IGNORE" {
#
# will accept a list of people.
# Send only one IGNORE for each type with a list of people to ignore.
# Maximum in (each) list is configurable.
#
if {[FloodCheck $who]} {return}
set type [lindex $parms 0]
for {set c 1} {$c < [llength $parms]} {incr c} {
if {[string compare [lindex $parms $c] ""]} {
switch -- $type {
"AVATAR" {
if {[llength $MVS($who.ig.av)] >= $MVS(max_ignores)} {
SendToUser $who "IGNORE AVATAR LIST FULL"
return
}
if {[lsearch -exact $MVS($who.ig.av) [lindex $parms $c]] == -1} {
lappend MVS($who.ig.av) [lindex $parms $c]
}
}
"EFFECT" {
if {[llength $MVS($who.ig.effect)] > $MVS(max_ignores)} {
SendToUser $who "IGNORE EFFECT LIST FULL"
return
}
if {[lsearch -exact $MVS($who.ig.effect) [lindex $parms $c]] == -1} {
lappend MVS($who.ig.effect) [lindex $parms $c]
}
}
"MOVE" {
if {[llength $MVS($who.ig.move)] > $MVS(max_ignores)} {
SendToUser $who "IGNORE MOVE LIST FULL"
return
}
if {[lsearch -exact $MVS($who.ig.move) [lindex $parms $c]] == -1} {
lappend MVS($who.ig.move) [lindex $parms $c]
}
}
"CHAT" {
if {[llength $MVS($who.ig.chat)] > $MVS(max_ignores)} {
SendToUser $who "IGNORE CHAT LIST FULL"
return
}
if {[lsearch -exact $MVS($who.ig.chat) [lindex $parms $c]] == -1} {
lappend MVS($who.ig.chat) [lindex $parms $c]
}
}
"SUB" {
if {[llength $MVS($who.ig.sub)] > $MVS(max_ignores)} {
SendToUser $who "IGNORE SUB LIST FULL"
return
}
if {[lsearch -exact $MVS($who.ig.sub) [lindex $parms $c]] == -1} {
lappend MVS($who.ig.sub) [lindex $parms $c]
}
}
"URL" {
if {[llength $MVS($who.ig.url)] > $MVS(max_ignores)} {
SendToUser $who "IGNORE URL LIST FULL"
return
}
if {[lsearch -exact $MVS($who.ig.url) [lindex $parms $c]] == -1} {
lappend MVS($who.ig.url) [lindex $parms $c]
}
}
"ALL" {
# AVATAR
if {[llength $MVS($who.ig.av)] > $MVS(max_ignores)} {
SendToUser $who "IGNORE AVATAR LIST FULL"
} else {
if {[lsearch -exact $MVS($who.ig.av) [lindex $parms $c]] == -1} {
lappend MVS($who.ig.av) [lindex $parms $c]
}
}
# EFFECT
if {[llength $MVS($who.ig.effect)] > $MVS(max_ignores)} {
SendToUser $who "IGNORE EFFECT LIST FULL"
} else {
if {[lsearch -exact $MVS($who.ig.effect) [lindex $parms $c]] == -1} {
lappend MVS($who.ig.effect) [lindex $parms $c]
}
}
# MOVE
if {[llength $MVS($who.ig.move)] > $MVS(max_ignores)} {
SendToUser $who "IGNORE MOVE LIST FULL"
} else {
if {[lsearch -exact $MVS($who.ig.move) [lindex $parms $c]] == -1} {
lappend MVS($who.ig.move) [lindex $parms $c]
}
}
# CHAT
if {[llength $MVS($who.ig.chat)] > $MVS(max_ignores)} {
SendToUser $who "IGNORE CHAT LIST FULL"
} else {
if {[lsearch -exact $MVS($who.ig.chat) [lindex $parms $c]] == -1} {
lappend MVS($who.ig.chat) [lindex $parms $c]
}
}
# SUB
if {[llength $MVS($who.ig.sub)] > $MVS(max_ignores)} {
SendToUser $who "IGNORE SUB LIST FULL"
} else {
if {[lsearch -exact $MVS($who.ig.sub) [lindex $parms $c]] == -1} {
lappend MVS($who.ig.sub) [lindex $parms $c]
}
}
# URL
if {[llength $MVS($who.ig.url)] > $MVS(max_ignores)} {
SendToUser $who "IGNORE URL LIST FULL"
} else {
if {[lsearch -exact $MVS($who.ig.url) [lindex $parms $c]] == -1} {
lappend MVS($who.ig.url) [lindex $parms $c]
}
}
}
}
}
}
}
"UNIGNORE" {
#
# will accept a list of people.
# Send only one UNIGNORE for each type with a list of people to ignore.
# Maximum in (each) list is configurable.
#
if {[FloodCheck $who]} {return}
set type [lindex $parms 0]
for {set c 1} {$c < [llength $parms]} {incr c} {
if {[string compare [lindex $parms $c] ""]} {
switch -- $type {
"AVATAR" {
if {[lsearch -exact $MVS($who.ig.av) [lindex $parms $c]] != -1} {
set idx [lsearch -exact $MVS($who.ig.av) [lindex $parms $c]]
set MVS($who.ig.av) [lreplace $MVS($who.ig.av) $idx $idx]
}
}
"EFFECT" {
if {[lsearch -exact $MVS($who.ig.effect) [lindex $parms $c]] != -1} {
set idx [lsearch -exact $MVS($who.ig.effect) [lindex $parms $c]]
set MVS($who.ig.effect) [lreplace $MVS($who.ig.effect) $idx $idx]
}
}
"MOVE" {
if {[lsearch -exact $MVS($who.ig.move) [lindex $parms $c]] != -1} {
set idx [lsearch -exact $MVS($who.ig.move) [lindex $parms $c]]
set MVS($who.ig.move) [lreplace $MVS($who.ig.move) $idx $idx]
}
}
"CHAT" {
if {[lsearch -exact $MVS($who.ig.chat) [lindex $parms $c]] != -1} {
set idx [lsearch -exact $MVS($who.ig.chat) [lindex $parms $c]]
set MVS($who.ig.chat) [lreplace $MVS($who.ig.chat) $idx $idx]
}
}
"SUB" {
if {[lsearch -exact $MVS($who.ig.sub) [lindex $parms $c]] != -1} {
set idx [lsearch -exact $MVS($who.ig.sub) [lindex $parms $c]]
set MVS($who.ig.sub) [lreplace $MVS($who.ig.sub) $idx $idx]
}
}
"URL" {
if {[lsearch -exact $MVS($who.ig.url) [lindex $parms $c]] != -1} {
set idx [lsearch -exact $MVS($who.ig.url) [lindex $parms $c]]
set MVS($who.ig.url) [lreplace $MVS($who.ig.url) $idx $idx]
}
}
"ALL" {
# AVATAR
if {[lsearch -exact $MVS($who.ig.av) [lindex $parms $c]] != -1} {
set idx [lsearch -exact $MVS($who.ig.av) [lindex $parms $c]]
set MVS($who.ig.av) [lreplace $MVS($who.ig.av) $idx $idx]
}
# EFFECT
if {[lsearch -exact $MVS($who.ig.effect) [lindex $parms $c]] != -1} {
set idx [lsearch -exact $MVS($who.ig.effect) [lindex $parms $c]]
set MVS($who.ig.effect) [lreplace $MVS($who.ig.effect) $idx $idx]
}
# MOVE
if {[lsearch -exact $MVS($who.ig.move) [lindex $parms $c]] != -1} {
set idx [lsearch -exact $MVS($who.ig.move) [lindex $parms $c]]
set MVS($who.ig.move) [lreplace $MVS($who.ig.move) $idx $idx]
}
# CHAT
if {[lsearch -exact $MVS($who.ig.chat) [lindex $parms $c]] != -1} {
set idx [lsearch -exact $MVS($who.ig.chat) [lindex $parms $c]]
set MVS($who.ig.chat) [lreplace $MVS($who.ig.chat) $idx $idx]
}
# SUB
if {[lsearch -exact $MVS($who.ig.sub) [lindex $parms $c]] != -1} {
set idx [lsearch -exact $MVS($who.ig.sub) [lindex $parms $c]]
set MVS($who.ig.sub) [lreplace $MVS($who.ig.sub) $idx $idx]
}
# URL
if {[lsearch -exact $MVS($who.ig.url) [lindex $parms $c]] != -1} {
set idx [lsearch -exact $MVS($who.ig.url) [lindex $parms $c]]
set MVS($who.ig.url) [lreplace $MVS($who.ig.url) $idx $idx]
}
}
}
}
}
}
"EFFECT" {
if {[FloodCheck $who]} {return}
# Ignorable. We send to each from here.
foreach w $MVS(socks) {
if {[lsearch -exact $MVS($w.ig.effect) $MVS($who.name)] == -1} {
SendToUser $w "EFFECT $MVS($who.name) [lindex $parms 0]"
}
}
}
"USERS" {
if {[FloodCheck $who]} {return}
SendToUser $what "USERS [llength $MVS(socks)]"
}
"SUB" {
if {[lindex $parms 0] == ""} {return}
set stuff [string range $rest [expr [string first " " $rest] +1] end]
if {[string length $stuff] > $MVS(maxmsglen)} {
set stuff [string range $stuff 0 $MVS(maxmsglen)]
}
foreach s $MVS(socks) {
if {![string compare $MVS($s.name) [lindex $parms 0]] || ![string compare [lindex $parms 0] "*"]} {
if {[lsearch -exact $MVS($s.ig.sub) $MVS($who.name)] == -1} {
SendToUser $s "SUB $MVS($who.name) $stuff"
}
}
}
unset stuff
}
"URL" {
if {[FloodCheck $who]} {return}
if {[lindex $parms 0] == ""} {return}
set stuff [string range $rest [expr [string first " " $rest] +1] end]
if {[string length $stuff] > $MVS(maxmsglen)} {
set stuff [string range $stuff 0 $MVS(maxmsglen)]
}
foreach s $MVS(socks) {
if {![string compare $MVS($s.name) [lindex $parms 0]] || ![string compare [lindex $parms 0] "*"]} {
if {[lsearch -exact $MVS($s.ig.sub) $MVS($who.name)] == -1} {
SendToUser $s "URL $MVS($who.name) $stuff"
}
}
}
unset stuff
}
"PONG" {
if {[FloodCheck $who]} {return}
set MVS($who.ping_response) [clock seconds]
}
"RSEND" {
if {[FloodCheck $who]} {return}
if ![SanityCheck [lindex $parms 0]] {return}
SendRoomFile $who [lindex $parms 0]
}
"CHAT" {
if {[FloodCheck $who]} {return}
set cmsg [string range $rest 0 $MVS(maxmsglen)]
if {[string compare $rest ""]} {
# Process hooks.
#
# If 0 is returned then we will ignore the input.
#
set ig 0
foreach hook $MVS(hooks.Chat) {
if {![$MVS(hooks.Chat.$hook) $who $cmsg]} {
set ig 1
}
}
if {!$ig} {
foreach s $MVS(socks) {
if {[lsearch -exact $MVS($s.ig.chat) $MVS($who.name)] == -1} {
SendToUser $s "CHAT $MVS($who.name) $cmsg"
}
}
}
}
}
"SCHAT" {
if {[FloodCheck $who]} {return}
set parms [split $rest " "]
set rest [string range $rest [expr [string first " " $rest] +1] end]
if {[string compare $rest ""]} {
foreach s $MVS(socks) {
if {[lsearch -exact $MVS($s.ig.chat) $MVS($who.name)] == -1} {
SendToUser $s "SCHAT [lindex $parms 0] $MVS($who.name) [string range $rest 0 $MVS(maxmsglen)]"
}
}
}
}
"AVATAR" {
if {[FloodCheck $who]} {return}
if {[TestNum [lindex $parms 1]] || \
[TestNum [lindex $parms 2]] || \
[TestNum [lindex $parms 3]] || \
[TestNum [lindex $parms 4]] || \
[TestNum [lindex $parms 5]]} {
SendToUser $who "BAD AVATAR"
unset cmd rest parms
return
}
set retflag 0
if {[string length [lindex $parms 1]] > 4} {set retflag 1}
if {[string length [lindex $parms 2]] > 4} {set retflag 1}
if {[string length [lindex $parms 3]] > 6} {set retflag 1}
if {[string length [lindex $parms 4]] > 4} {set retflag 1}
if {[string length [lindex $parms 5]] > 4} {set retflag 1}
if {[lindex $parms 3] < 0} {set retflag 1}
if $retflag {
unset cmd rest parms retflag
return
}
Serv_ChangeAvatar $who [lindex $parms 0] [lindex $parms 1] [lindex $parms 2] [lindex $parms 3] [lindex $parms 4] [lindex $parms 5]
}
"WHOIS" {
if {[FloodCheck $who]} {return}
if {[lindex $parms 0] == ""} {return}
foreach s $MVS(socks) {
if {![string compare $MVS($s.name) [lindex $parms 0]] || ![string compare [lindex $parms 0] "*"]} {
SendToUser $who "WHOIS $MVS($s.name) $MVS($s.name)@$MVS($s.address)"
}
}
}
"PRIVMSG" {
if {[FloodCheck $who]} {return}
if {[lindex $parms 0] == ""} {return}
set stuff [string range $rest [expr [string first " " $rest] +1] end]
if {[string length $stuff] > $MVS(maxmsglen)} {
set stuff [string range $stuff 0 $MVS(maxmsglen)]
}
foreach s $MVS(socks) {
if {![string compare $MVS($s.name) [lindex $parms 0]] || ![string compare [lindex $parms 0] "*"]} {
if {[lsearch -exact $MVS($s.ig.chat) $MVS($who.name)] == -1} {
SendToUser $s "PRIVMSG $MVS($who.name) $stuff"
}
}
}
unset stuff
}
"NICK" {
if {[FloodCheck $who]} {return}
if {![string compare $MVS($who.name) [lindex $parms 0]] || ![string compare $MVS($who.name) "*"]} {
unset cmd rest parms
return
}
if ![CheckName [lindex $parms 0]] {
SendToUser $who "NAMEINUSE"
unset cmd rest parms
return
}
foreach sckt $MVS(socks) {
if {![string compare $MVS($sckt.name) [lindex $parms 0]]} {
SendToUser $who "NAMEINUSE"
DisconnectUser $what 1
unset cmd rest parms
return
}
}
SendToAllUsers "NOMORE $MVS($who.name)"
set MVS($who.name) [string range [lindex $parms 0] 0 12]
SendToAllUsers "NEW $MVS($who.name) $MVS($who.x) $MVS($who.y) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
SendAvatarToAll $who $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)
}
"TELL" {
if {[FloodCheck $who]} {return}
# Object Interaction. (tell)
foreach tell $MVS(tell_registry) {
set reg [split $tell " "]
if {[lindex $parms 0] == [lindex $reg 0]} {
[lindex $reg 1] $who
}
}
}
"SUBMIT" {
if {[FloodCheck $who]} {return}
# Object Interaction. (submit)
foreach submit $MVS(submit_registry) {
set reg [split $submit " "]
if {[lindex $parms 0] == [lindex $reg 0]} {
[lindex $reg 1] $who
}
}
}
"ENTRY" {
if {[FloodCheck $who]} {return}
# Object Interaction.
set text [string range $rest [expr [string first " " $rest] +1] end]
if {![string compare $text $rest]} {set text ""}
foreach entry $MVS(entry_registry) {
set reg [split $entry " "]
if {[lindex $parms 0] == [lindex $reg 0]} {
[lindex $reg 1] $who $text
}
}
}
}
unset cmd rest parms
}
#
# Send the AVATAR command.
#
# Usage: SendAvatarToAll who filename nametag_x nametag_y size balloon_x balloon_y
#
# This is centralized here so that ignoring it is easier.
# All it does is send the AVATAR command out. You should be using
# Serv_ChangeAvatar to do this.
#
proc SendAvatarToAll {who what x y size bx by} {
global MVS
foreach w $MVS(socks) {
if {[lsearch -exact $MVS($w.ig.av) $MVS($who.name)] == -1} {
SendToUser $w "AVATAR $MVS($who.name) $what $x $y $size $bx $by"
}
}
}
#
# Change a user's avatar.
#
# Usage: Serv_ChangeAvatar who avatar_name nametag_x nametag_y size
# balloon_x balloon_y
#
# This function is used to change a user's avatar. It will announce the
# change to all connected users.
#
proc Serv_ChangeAvatar {who what x y size bx by} {
global MVS
set MVS($who.avatar) $what
set MVS($who.av_head_x) $x
set MVS($who.av_head_y) $y
set MVS($who.av_baloon_x) $bx
set MVS($who.av_baloon_y) $by
if {![string compare $what "default.gif"]} {
SendAvatarToAll $who $what $MVS($who.av_head_x) $MVS($who.av_head_y) [file size $MVS(icons)/$what] $bx $by
return
}
if ![file exists $MVS(avatars)/$what] {
LogIt "-> $what does not exist"
GetBinaryFile $who $MVS($who.avatar) $size AVATAR 0
} else {
if {[file size $MVS(avatars)/$what] != $size} {
LogIt "-> $what $size != [file size $MVS(avatars)/$what]"
GetBinaryFile $who $MVS($who.avatar) $size AVATAR 0
} else {
if [CheckGif "$MVS(avatars)/$what"] {
SendAvatarToAll $who $what $MVS($who.av_head_x) $MVS($who.av_head_y) [file size $MVS(avatars)/$what] $bx $by
} else {
SendAvatarToAll $who default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6
SendToUser $who "TOOBIG"
set MVS($who.avatar) "default.gif"
}
}
}
}
#
# Check various timeouts and events.
#
# Usage: Serv_CheckTimeouts
#
# This function should be run only ONCE when the server is started. It
# should never be run multiple times within a given instance. Once it is
# run, it will re-spawn iteself later and check again, add infinitium.
# What it does is check timeouts. Download Timeouts, Ping Timeouts and it
# also checks for the existance of a tickler file which, when it exists,
# will cause the server to reload it's config file.
#
proc Serv_CheckTimeouts {} {
global MVS
#
# Check user ping times.
#
set tme [clock seconds]
set disco {}
foreach who $MVS(socks) {
if {[expr $tme - $MVS($who.ping_response)] > 320} {
LogIt "($who) - Ping Timeout!"
lappend disco $who
} else {
if {[expr $tme - $MVS($who.ping)] > 150} {
set MVS($who.ping) [clock seconds]
SendToUser $who "PING"
}
}
}
foreach who $disco {
DisconnectUser $who 1
}
#
# Check active downloads.
#
set tme [clock seconds]
foreach idx $MVS(dcc_list) {
if {[expr $tme - $MVS(DCC.$idx.time)] > $MVS(timeout)} {
if {$MVS(DCC.$idx.server) > 0} {
catch {close $MVS(DCC.$idx.server)}
}
Serv_endDCC Timer $idx 0 "Connection Timed Out $MVS(DCC.$idx.file)"
}
}
#
# Check out ORT Registry timeouts.
#
foreach sck $MVS(registry.servers) {
if {$MVS(registry.$sck.timeout) < [expr [clock seconds] - 180]} {
LogIt "(ORT) Connection to $sck timed out!"
DisconnectOrtRegistry $sck
}
}
#
# Check for tickler file(s)
#
if [file exists "$MVS(tickler)"] {ReloadConfig}
if [file exists "$MVS(mem_tickler)"] {
Serv_DumpMem
catch {
file delete -force "$MVS(mem_tickler)"
}
}
#
# If we're serving, reload this function in 5 seconds.
#
if $MVS(serving) {
after 5000 Serv_CheckTimeouts
}
unset disco tme
}
#
# Error Logging Routine.
#
# Usage: Used internally when an error occurs.
#
# Will print out information on errors
# and continue running (we hope)
#
proc bgerror {stuff} {
global errorInfo
global errorCode
LogIt "-------------------------------------"
LogIt "BGERROR Begin"
LogIt "-------------------------------------"
LogIt "Error Code: $stuff"
LogIt "-------------------------------------"
LogIt $errorInfo
LogIt "-------------------------------------"
LogIt "BGERROR End"
LogIt "-------------------------------------"
}
#
# Check for duplicate downloads.
#
# Usage: MVSerifyAvailable socket filename
#
# This function will check to see if the
# user is already getting the file named.
#
proc MVSerifyAvailable {who what} {
global MVS
foreach idx $MVS(dcc_list) {
if {![string compare $MVS(DCC.$idx.sender) $who] && ![string compare "[file tail $MVS(DCC.$idx.file)]" $what]} {
return 0
}
}
return 1
}
#
#
# Scheduler routine for Serv_DCCSend
#
# Usage: SchedServ_DCCSend index who
#
# Schedules downloads to be sent again if there was not
# enough resources to send it the first time. It is done
# though this routine to prevent hack with filenames
# interrupting the code.
#
# CRUISE - 11/01/2001 - Fixed a bug here, had GBF array for type, not SDCCS
#
proc SchedServ_DCCSend {idx who} {
global MVS
Serv_DCCSend $MVS($who.SDCCS.$idx.who) $MVS($who.SDCCS.$idx.what) $MVS($who.SDCCS.$idx.type) $idx
}
#
# Send a file
#
# Usage: Serv_DCCSend socket filename transfer_type retry_flag
#
# This function will initiate a file transfer. It is used for rooms and
# avatars and object images. This is a passive dcc transfer so things work
# better through modern firewalls.
#
proc Serv_DCCSend {who what type retry} {
global MVS
if ![MVSerifyAvailable $who $what] {
LogIt "($who) -- Already Getting $what"
return
}
switch -exact -- $type {
"AVATAR" {
if {![string compare $what "default.gif"]} {
set file "$MVS(icons)/default.gif"
} else {
set file "$MVS(avatars)/$what"
}
set GETCMD "DCCGETAV"
}
"OBJECT" {
set file "$MVS(images)/$what"
set GETCMD "DCCGETOB"
}
"ROOM" {
set file "$MVS(roomdir)/$what"
set GETCMD "DCCGETROOM"
}
"ORT" {
set file "$MVS(homedir)/images/$what"
set GETCMD "DCCGETAV"
}
default {return}
}
if {[file exists $file]} {
if {![file readable $file]} {
LogIt "($who) (Serv_DCCSend) Cannot read file $file."
return
}
set size [file size $file]
#
# BUG - We're having problems with an error here
# which reads "No Buffer Space Available"
# Lets keep trying with a max timeout.
#
if {!$retry} {
set idx [incr MVS(dcc_num)]
} else {
set idx $retry
}
if {[catch {set sock [socket -server "Serv_acceptSend $idx" 0]}]} {
#
# Secure the variable settings in this array.
# for a retry.
#
set MVS($who.SDCCS.$idx.who) $who
set MVS($who.SDCCS.$idx.what) $what
set MVS($who.SDCCS.$idx.type) $type
if {$retry} {
incr MVS($who.SDCCS.$idx.tries)
} else {
set MVS($who.SDCCS.$idx.tries) 1
}
LogIt "($who) (Serv_DCCSend) Unable to open listening socket. Try number $MVS($who.SDCCS.$idx.tries)"
if {$MVS($who.SDCCS.$idx.tries) > $MVS(max_socket_retries)} {
LogIt "($who) (Serv_DCCSend) Too Many Retries ($MVS($who.SDCCS.$idx.tries)) Giving up!"
unset MVS($who.SDCCS.$idx.who)
unset MVS($who.SDCCS.$idx.what)
unset MVS($who.SDCCS.$idx.type)
unset MVS($who.SDCCS.$idx.tries)
} else {
after $MVS(retry_wait_time) "SchedServ_DCCSend $idx $who"
return
}
} else {
if {$retry} {
LogIt "($who) (Serv_DCCSend) Retry Success!"
unset MVS($who.SDCCS.$idx.who)
unset MVS($who.SDCCS.$idx.what)
unset MVS($who.SDCCS.$idx.type)
unset MVS($who.SDCCS.$idx.tries)
}
}
if {[catch {fconfigure $sock -sockname} port]} {
LogIt "($who) (Serv_DCCSend) Cannot get port for server - $port"
}
lappend MVS(dcc_list) $idx
set MVS(DCC.$idx.sender) $who
set MVS(DCC.$idx.file) "$file"
set MVS(DCC.$idx.fd) -1
set MVS(DCC.$idx.size) $size
set MVS(DCC.$idx.posn) 0
set MVS(DCC.$idx.type) "AVATAR"
set MVS(DCC.$idx.time) [clock seconds]
set MVS(DCC.$idx.server) $sock
set MVS(DCC.$idx.sock) -1
set MVS(DCC.$idx.port) [lindex $port 2]
set MVS(DCC.$idx.remote) "0.0.0.0"
set MVS(DCC.$idx.av_head_x) 0
set MVS(DCC.$idx.av_head_y) 0
set MVS(DCC.$idx.av_baloon_x) 0
set MVS(DCC.$idx.av_baloon_y) 0
SendToUser $who "$GETCMD [lindex $port 2] $what $size"
unset size idx sock
} else {
LogIt "($who) (Serv_DCCSend) File $file does not exist."
}
unset file GETCMD
}
#
# Accept pending outbout transfers.
#
# Usage: Serv_acceptSend index socket host port
#
# This function is not called directly, it is instead called by the
# opening of the server socket. It accepts the connection, closes the
# server socket and starts the sending of the file to the user.
#
proc Serv_acceptSend {index chan hst port} {
global MVS
catch {close $MVS(DCC.$index.server)}
uplevel set MVS(DCC.$index.server) -1
uplevel #0 set MVS(DCC.$index.sock) $chan
set msg ""
if {[catch {open $MVS(DCC.$index.file) RDONLY} infile]} {
Serv_endDCC Send $index 0 "Cannot read $MVS(DCC.$index.file) : $infile"
unset infile
return 0
}
set MVS(DCC.$index.fd) $infile
if {[set posn $MVS(DCC.$index.posn)] != {} && $posn > 0} {
if {[catch {seek $infile $posn start} msg]} {
Serv_endDCC Send $index 0 "Cannot seek $MVS(DCC.$index.file) : $msg"
close $infile
unset infile posn msg
return 0
}
uplevel #0 incr MVS(DCC.$index.size) -$posn
}
if {$MVS(DCC.$index.size) == 0} {
close $infile
Serv_endDCC Send $index 1 "Transfer completed."
unset infile posn msg
return 1
}
set st [clock seconds]
fconfigure $infile -translation binary
if {[catch {set buffer [read $infile $MVS(sendbuffer)]} msg]} {
Serv_endDCC Send $index 0 "Error reading $file : $msg"
close $infile
unset infile posn msg st buffer
return 0
}
global tl
set tl($chan) [string length $buffer]
fconfigure $chan -blocking 0 -buffering none -translation binary
if {[catch {puts -nonewline $chan $buffer} msg]} {
Serv_endDCC Send $index 0 "Write error : $msg"
close $infile
unset infile posn msg st buffer
return 0
}
LogIt "($MVS(DCC.$index.sender)) -- Accepted Serv_DCCSend"
fileevent $chan readable "Serv_dccSendEvent $index $st $infile"
unset infile posn msg st buffer
}
#
# The file send event (read trigger) for sending files.
#
# Usage: Serv_dccSendEvent index start_time file_stream_descriptor
#
# This function is triggered each time the remote client sends a response
# announcing the number of bytes the server has sent to it. It will send
# some more bytes if the client has received all of what we've sent so
# far. It will end the transfer when the client informs us that it has all
# of the data we've sent.
#
proc Serv_dccSendEvent {index st fd} {
global MVS
set sk $MVS(DCC.$index.sock)
uplevel #0 set MVS(DCC.$index.time) [clock seconds]
set msg ""
if {[eof $sk]} {
Serv_endDCC Send $index 0 "Transfer interrupted"
unset sk
return
}
if {[catch {set l [read $sk 4]} msg]} {
Serv_endDCC Send $index 0 "Read error : $msg"
catch {unset sk msg l}
return
}
if {[string length $l] == 0} {
Serv_endDCC Send $index 0 "Sync read error"
catch {unset sk msg l}
return
}
global tl
set cl 0
binary scan $l I1 cl
if {$cl != $tl($sk)} {
catch {unset sk msg cl l}
return
}
LogIt "($MVS(DCC.$index.sender)) Got Check (OK)"
if {![info exists fd]} {
Serv_endDCC Send $index 0 "File descriptor closed or missing (timeout?)"
return
}
if {[catch {
if {[eof $fd]} {
if {[set st [expr {[clock seconds] - $st}]] == 0} {
set st 1
}
catch {unset sk msg cl st l}
Serv_endDCC Send $index 1 "Transfer completed"
return
}
} err]} {
Serv_endDCC Send $index 0 "File descriptor closed or missing: $err"
return
}
LogIt "($MVS(DCC.$index.sender)) Got Check (OK Not EOF)"
if {[catch {set buffer [read $fd $MVS(sendbuffer)]} msg]} {
Serv_endDCC Send $index 0 "Error reading $MVS(DCC.$index.file) : $msg"
catch {unset sk msg cl st buffer l}
return
}
if {[set lng [string length $buffer]] == 0} {
if {[set st [expr {[clock seconds] - $st}]] == 0} {
set st 1
}
catch {unset sk msg cl st buffer lng l}
Serv_endDCC Send $index 1 "Transfer completed."
return
}
incr tl($sk) $lng
LogIt "($MVS(DCC.$index.sender)) -- Sent $lng bytes ($tl($sk) total)"
if {[catch {puts -nonewline $sk $buffer} msg]} {
Serv_endDCC Send $index 0 "Write error : $msg"
catch {unset sk msg cl st buffer lng l}
return
}
if {[set dt [expr {[clock seconds] - $st}]] == 0} {
set elt 0
} {
set elt [expr {($MVS(DCC.$index.size) - $tl($sk)) / ($tl($sk) /([clock seconds] - $st))}]
}
catch {unset sk msg cl st buffer lng dt elt l}
}
#
# Scheduler routine for GetBinaryFile.
#
proc SchedGetBinaryFile {idx who} {
global MVS
GetBinaryFile $MVS($who.GBF.$idx.who) $MVS($who.GBF.$idx.what) $MVS($who.GBF.$idx.size) $MVS($who.GBF.$idx.type) $idx
}
#
# DCC Get Code (Passive)
#
# Usage: GetBinaryFile socket filename file size
#
# This function initializes a passive DCC transfer between a connected
# user and the server. It will set up the listening connection and tell
# the user where to connect to. It will then set up an event to accep the
# connection and transfer the file.
#
# This is our central location for DOWNLOADING files.
#
proc GetBinaryFile {who what size type retry} {
global MVS
if ![SanityCheck "$what"] {
LogIt "(!) $what fails SanityCheck"
return
}
if ![MVSerifyAvailable $who $what] {
LogIt "($who) -- Already GetTing $what from this user"
return
}
set file "$MVS(avatars)/$what"
#
# BUG - We're having problems with an error here
# which reads "No Buffer Space Available"
# Lets keep trying with a max timeout.
#
if {!$retry} {
set idx [incr MVS(dcc_num)]
} else {
set idx $retry
}
if {[catch {set sock [socket -server "acceptGet $idx" 0]}]} {
#
# Secure the variable settings in this array.
# for a retry.
#
set MVS($who.GBF.$idx.who) $who
set MVS($who.GBF.$idx.what) $what
set MVS($who.GBF.$idx.size) $size
set MVS($who.GBF.$idx.type) $type
if {$retry} {
incr MVS($who.GBF.$idx.tries)
} else {
set MVS($who.GBF.$idx.tries) 1
}
LogIt "($who) (GetBinaryFile) Unable to open listening socket. Try number $MVS($who.GBF.$idx.tries)"
if {$MVS($who.GBF.$idx.tries) > $MVS(max_socket_retries)} {
LogIt "($who) (GetBinaryFile) Too Many Retries ($MVS($who.GBF.$idx.tries)) Giving up!"
unset MVS($who.GBF.$idx.who)
unset MVS($who.GBF.$idx.what)
unset MVS($who.GBF.$idx.size)
unset MVS($who.GBF.$idx.type)
unset MVS($who.GBF.$idx.tries)
} else {
after $MVS(retry_wait_time) "SchedGetBinaryFile $idx $who"
return
}
} else {
if {$retry} {
LogIt "($who) (GetBinaryFile) Retry Success!"
unset MVS($who.GBF.$idx.who)
unset MVS($who.GBF.$idx.what)
unset MVS($who.GBF.$idx.size)
unset MVS($who.GBF.$idx.type)
unset MVS($who.GBF.$idx.tries)
}
}
if {[catch {fconfigure $sock -sockname} port]} {
LogIt "($who) (Serv_DCCSend) Cannot get port for server - $port"
}
lappend MVS(dcc_list) $idx
set MVS(DCC.$idx.sender) $who
set MVS(DCC.$idx.file) "$file"
set MVS(DCC.$idx.fd) -1
set MVS(DCC.$idx.size) $size
set MVS(DCC.$idx.type) $type
set MVS(DCC.$idx.posn) 0
set MVS(DCC.$idx.time) [clock seconds]
set MVS(DCC.$idx.server) $sock
set MVS(DCC.$idx.sock) -1
set MVS(DCC.$idx.port) [lindex $port 2]
set MVS(DCC.$idx.remote) $MVS($who.address)
set MVS(DCC.$idx.av_head_x) $MVS($who.av_head_x)
set MVS(DCC.$idx.av_head_y) $MVS($who.av_head_y)
set MVS(DCC.$idx.av_baloon_x) $MVS($who.av_baloon_x)
set MVS(DCC.$idx.av_baloon_y) $MVS($who.av_baloon_y)
SendToUser $who "DCCSENDAV [lindex $port 2] $what"
unset file idx sock port
}
#
#
# Accept pending inbound transfers.
#
# Usage: Serv_acceptGet index socket host port
#
# This function is not called directly, it is instead called by the
# opening of the server socket. It accepts the connection, closes the
# server socket and starts the getting of the file to the user.
#
proc acceptGet {index chan hst port} {
global MVS
catch {close $MVS(DCC.$index.server)}
uplevel set MVS(DCC.$index.server) -1
uplevel #0 set MVS(DCC.$index.sock) $chan
set file $MVS(DCC.$index.file)
set posn $MVS(DCC.$index.posn)
fconfigure $MVS(DCC.$index.sock) -buffering none -blocking 0 -translation binary -buffersize 4096
set flags [list WRONLY CREAT]
set msg ""
if {$posn == 0} { lappend flags TRUNC }
if {![catch {open $file $flags 0600} outfile]} {
set MVS(DCC.$index.fd) $outfile
if {$posn != 0} {
if {[catch {seek $outfile $posn start} msg]} {
close $outfile
Serv_endDCC Get $index 0 "Cannot seek on $file : $msg"
unset file posn flags outfile msg
return 0
}
uplevel #0 incr MVS(DCC.$index.size) -$posn
}
uplevel #0 set tl($MVS(DCC.$index.sock)) 0
fconfigure $outfile -translation binary
fileevent $MVS(DCC.$index.sock) readable "Serv_dccgevent $index [clock seconds] $outfile"
} {
Serv_endDCC Get $index 0 "Cannot write $file : $outfile"
unset file posn flags outfile msg
return 0
}
unset file posn flags outfile msg
return 1
}
#
# The file get event (read trigger) for getting files.
#
# Usage: Serv_dccgevent index start_time file_stream_descriptor
#
# This function is triggered each time the remote client sends a response
# announcing the number of bytes the server has sent to it. It will send
# some more bytes if the client has received all of what we've sent so
# far. It will end the transfer when the client informs us that it has all
# of the data we've sent.
#
# CRUISE - 10/24/2001 - fixed a problem with unsetting sx on failed transfers
# by catching it.
#
proc Serv_dccgevent {index st out} {
global tl MVS
set xc 0
set in $MVS(DCC.$index.sock)
set leng $MVS(DCC.$index.size)
uplevel #0 set MVS(DCC.$index.time) [clock seconds]
set fail_type 0
if {[eof $in]} {
if {$tl($in) < $leng} {
set msg "Transfer Interrupted"
set fail_type 0
} elseif {$tl($in) > $leng} {
set msg "Too much data transferred!!"
set fail_type 0
} else {
set sx s
if {[set st [expr {[clock seconds] - $st}]] == 0} {
set st 1
set sx {}
}
set xc 1
set msg "Transfer completed. [expr {$leng / ($st * 1024.0)}] Kbytes/sec"
set fail_type 1
}
catch {unset sx}
catch {unset st}
} {
if {![catch {set buffer [read $in]} msg]} {
incr tl($in) [set l [string length $buffer]]
LogIt "downloaded $l bytes ($tl($in) total)"
if {[set dt [expr {[clock seconds] - $st}]] == 0 || $tl($in) == 0} {
set elt 0
} {
set elt [expr {($leng - $tl($in)) / ($tl($in) /([clock seconds] - $st))}]
}
if {$leng == 0} {
set xt 0
} {
set xt [expr {($tl($in) * 100.0) / $leng}]
}
if {![catch {puts -nonewline $out $buffer} msg]} {
if {![catch {puts -nonewline $in [binary format I1 $tl($in)]} msg]} {
flush $in
unset xc in leng fail_type dt elt xt
return
}
} else {
set fail_type 0
}
} else {
set fail_type 0
}
}
catch {close $out}
Serv_endDCC Get $index $fail_type $msg
catch {unset xc in leng fail_type l dt elt xt}
}
#
# End a DCC Transfer
#
# Usage: Serv_endDCC transfer_type index fail_type debug_info
#
# This function will end a user's DCC transfer. If it is a failure, it
# will print information about the transfer out to the log, if it is
# successful and the transfer is an incoming avatar, it will announce the
# avatar to all connected users. Once it's done ending the transfer, it
# will cleanup the mess made.
#
proc Serv_endDCC {type index fail_type debug} {
global MVS tl
catch {close $MVS(DCC.$index.sock)}
set idx [lsearch -exact $MVS(dcc_list) $index]
set MVS(dcc_list) [lreplace $MVS(dcc_list) $idx $idx]
if {![string compare $type "Get"] && $fail_type} {
switch -- $MVS(DCC.$index.type) {
"ORT" {
# Wonderful!
LogIt "(ORT) Image transfer ($MVS(DCC.$index.file)) Complete"
}
default {
if [CheckGif "$MVS(DCC.$index.file)"] {
SendAvatarToAll $MVS(DCC.$index.sender) [file tail $MVS(DCC.$index.file)] $MVS(DCC.$index.av_head_x) $MVS(DCC.$index.av_head_y) $MVS(DCC.$index.size) $MVS(DCC.$index.av_baloon_x) $MVS(DCC.$index.av_baloon_y)
} else {
set MVS($MVS(DCC.$index.sender).avatar) "default.gif"
SendAvatarToAll $MVS(DCC.$index.sender) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6
SendToUser $MVS(DCC.$index.sender) "TOOBIG"
}
}
}
}
if !$fail_type {
if {[info exists MVS(DCC.$index.sender]} {
LogIt "($MVS(DCC.$index.sender)) (DCC$type) - $debug"
}
}
#
# Close the file descriptor for this file
# in case it wasn't closed. This should clear
# up our file descriptor leak.
catch {close $MVS(DCC.$index.fd)}
#
# Clean up the memory this download was using.
#
catch {unset MVS(DCC.$index.av_baloon_x)}
catch {unset MVS(DCC.$index.av_baloon_y)}
catch {unset MVS(DCC.$index.av_head_x)}
catch {unset MVS(DCC.$index.av_head_y)}
catch {unset MVS(DCC.$index.port)}
catch {unset MVS(DCC.$index.remote)}
catch {unset MVS(DCC.$index.sock)}
catch {unset MVS(DCC.$index.type)}
catch {unset MVS(DCC.$index.file)}
catch {unset MVS(DCC.$index.fd)}
catch {unset MVS(DCC.$index.posn)}
catch {unset MVS(DCC.$index.sender)}
catch {unset MVS(DCC.$index.server)}
catch {unset MVS(DCC.$index.size)}
catch {unset MVS(DCC.$index.time)}
}
#
# Check gif file size
#
# Usage: CheckGif "filename"
#
# This will read in the GIF File header and determine it's size. It will
# comare the size against the server limits and report back if the file is
# good or bad.
#
proc CheckGif {file} {
global MVS
if {[catch {set infile [open $file r]} err]} {
LogIt "(CheckGif) Unable to open file : $err"
return 0
}
fconfigure $infile -translation binary
set bits [read $infile 10]
close $infile
if {[string range $bits 0 2] != "GIF"} {
LogIt "(CheckGif) FAILED! NOT A GIF"
unset infile bits
return 0
}
binary scan $bits s* var
if {[lindex $var 4] <= $MVS(maxheight) && [lindex $var 3] <= $MVS(maxwidth)} {
LogIt "(CheckGif) PASSED! [lindex $var 3] X [lindex $var 4]"
unset infile bits var
return 1
} else {
LogIt "(CheckGif) FAILED! [lindex $var 3] X [lindex $var 4]"
unset infile bits var
return 0
}
}
#
# Send objects to a user.
#
# Usage: SendObjects socket
#
# This function will send all server objects to a user. It is normally
# used at connect time to initalize an object for a user.
#
proc SendObjects {who} {
global MVS
foreach object [glob -nocomplain "$MVS(sobjects)/*"] {
source $object
}
}
#
# this function reads input from a registry connection to an ORT. It keeps
# track of where it is in the registration process and calles any needed
# support functions based on input from the ORT. Usually, this is a quick
# process as we are usually only updating our information with the ORT.
#
proc ReadFromOrtRegistry {sck} {
global MVS
set input ""
catch {gets $sck input}
if {[eof $sck] == 1 || $input == ""} {
LogIt "(ORT_Reg) - Registration with $MVS(registry.$sck.username) FAILED!"
DisconnectOrtRegistry $sck
return
}
set MVS(registry.$sck.timeout) [clock seconds]
#LogIt "<- (ORT) $input"
set parms [split $input " "]
switch -- [lindex $parms 0] {
"OK" {
# Move along please.
}
"DCCSENDAV" {
if ![SanityCheck [lindex $parms 1]] {
LogIt "(ORT_Reg) - Registration with $MVS(registry.$sck.username) FAILED! (Sanity Check!)"
DisconnectOrtRegistry $sck
return
}
Serv_DCCSend $sck [lindex $parms 1] ORT 0
LogIt "(ORT) Sending Image."
return
}
"GOODBYE" {
if {$MVS(registry.$sck.stage) >= 13} {
LogIt "(ORT_Reg) - Registration with $MVS(registry.$sck.username) Complete."
} else {
LogIt "(ORT_Reg) - Registration with $MVS(registry.$sck.username) FAILED!"
}
DisconnectOrtRegistry $sck
return
}
default {
LogIt "(ORT_Reg) - Registration with $MVS(registry.$sck.username) FAILED!"
DisconnectOrtRegistry $sck
return
}
}
switch $MVS(registry.$sck.stage) {
0 {
puts $sck "LOGIN $MVS(registry.$sck.username)"
incr MVS(registry.$sck.stage)
flush $sck
}
1 {
puts $sck "PASSWORD $MVS(registry.$sck.password)"
incr MVS(registry.$sck.stage)
flush $sck
}
2 {
puts $sck "IMAGE $MVS(ORT_Image) [file size "$MVS(homedir)/images/$MVS(ORT_Image)"]"
incr MVS(registry.$sck.stage)
flush $sck
}
3 {
puts $sck "RATING $MVS(ORT_Rating)"
incr MVS(registry.$sck.stage)
flush $sck
}
4 {
puts $sck "DESCRIPTION $MVS(ORT_Description)"
incr MVS(registry.$sck.stage)
flush $sck
}
5 {
puts $sck "STATE $MVS(ORT_State)"
incr MVS(registry.$sck.stage)
flush $sck
}
6 {
puts $sck "COUNTRY $MVS(ORT_Country)"
incr MVS(registry.$sck.stage)
flush $sck
}
7 {
puts $sck "ADMIN $MVS(ORT_Admin)"
incr MVS(registry.$sck.stage)
flush $sck
}
8 {
puts $sck "ADMINEMAIL $MVS(ORT_AdminEmail)"
incr MVS(registry.$sck.stage)
flush $sck
}
9 {
puts $sck "WEBSITE $MVS(ORT_WebSite)"
incr MVS(registry.$sck.stage)
flush $sck
}
10 {
puts $sck "PORT $MVS(port)"
incr MVS(registry.$sck.stage)
flush $sck
}
11 {
puts $sck "NAME $MVS(roomname)"
incr MVS(registry.$sck.stage)
flush $sck
}
12 {
puts $sck "END"
incr MVS(registry.$sck.stage)
flush $sck
}
}
}
#
#
proc DisconnectOrtRegistry {sck} {
global MVS
catch {close $sck}
set idx [lsearch $MVS(registry.servers) $sck]
set MVS(registry.servers) [lreplace $MVS(registry.servers) $idx $idx]
LogIt "(ORT) Disconnected from Ort Registry"
#
# Clean up the memory this registry was using.
#
catch {unset MVS(registry.$sck.password)}
catch {unset MVS(registry.$sck.stage)}
catch {unset MVS(registry.$sck.timeout)}
catch {unset MVS(registry.$sck.username)}
}
#
# This function will register our server with the ORT systems defined in
# the config file. We must register every few minutes to let the ORT know
# that we are still alive / interested in it.
#
proc RegisterWithORTs {} {
global MVS
set idx 0
if {$MVS(register_ort)} {
set MVS(registry.servers) {}
foreach server $MVS(ORT_Server) {
if {[catch {
set parms [split $server ":"]
set sck [socket -async [lindex $parms 0] [lindex $parms 1]]
fconfigure $sck -blocking 0
set MVS(registry.$sck.stage) 0
set MVS(registry.$sck.username) [lindex $MVS(ORT_Username) $idx]
set MVS(registry.$sck.password) [lindex $MVS(ORT_Password) $idx]
puts $sck "TRANS_REG"
set MVS(registry.$sck.timeout) [clock seconds]
lappend MVS(registry.servers) $sck
fileevent $sck readable "ReadFromOrtRegistry $sck"
flush $sck
} error]} {
LogIt "(ERROR) $error"
} else {
LogIt "(ORT_REG) Registering with $server"
}
incr idx
}
}
after 300000 RegisterWithORTs
if {$idx} {
LogIt "(ORT_Reg) All ORT Registration(s) initiated."
}
}
#
# Serv_DumpMem
#
# This function will dump the contents of the MVS array and is mostly used
# with the TickleMem tickler file to incvoke this function. It allows
# developers to find and remove memory leaks within the main array. A text
# file will be created named Dump.mem containing the keys and values of
# the main array.
#
proc Serv_DumpMem {} {
global MVS tl
set arrays [list MVS tl]
set outfile [open "$MVS(homedir)/Dump.mem" "w"]
#
# debug all the arrays.
#
foreach ar $arrays {
puts $outfile "------------------------------------------------------------------------------"
puts $outfile " OpenVerse Server - THIS IS THE $ar\() ARRAY"
puts $outfile "------------------------------------------------------------------------------"
set toggle 0
set values {}
set keys {}
foreach var [array get $ar] {
if {!$toggle} {
lappend keys $var
set toggle 1
} else {
set toggle 0
}
}
set keys [lsort $keys]
foreach key $keys {
puts $outfile [format "%-39.39s %-39.39s" $key [set $ar\($key)]]
}
}
#
# Open Files
#
set files 0
puts $outfile "------------------------------------------------------------------------------"
puts $outfile " Open FILES"
puts $outfile "------------------------------------------------------------------------------"
for {set c 0} {$c <= 255} {incr c} {
if {![catch {set slist [tell file$c]} err]} {
# This one is open.
puts $outfile "file$c - OPEN - $slist"
incr files
}
}
if {$files} {puts $outfile "$files OPEN FILES"}
#
# Open Socks
#
set socks 0
puts $outfile "------------------------------------------------------------------------------"
puts $outfile " Open SOCKETS"
puts $outfile "------------------------------------------------------------------------------"
for {set c 0} {$c <= 255} {incr c} {
if {![catch {set slist [tell sock$c]} err]} {
# This one is open.
puts $outfile "sock$c - OPEN - $slist"
incr socks
}
}
if {$socks} {puts $outfile "$socks OPEN SOCKETS"}
puts $outfile "[expr $files + $socks] TOTAL OPEN CONNECTIONS"
close $outfile
}
#-------------------------------------------------------------------------
#-------------------------------------------------------------------------
# THIS IS IT, THIS IS WHERE THE SERVER IS OFICIALLY STARTED.
#-------------------------------------------------------------------------
#-------------------------------------------------------------------------
#
# Check to see if we're stand alone or not.
# If we're not stand alone, then we need to add a couple of functions.
# These are for testing variable values mostly.
#
if {!$tcl_interactive} {
set MVS(standalone) 1
set app "$argv0"
catch { set app [file readlink $app] }
set MVS(homedir) "[file dirname $app]"
set MVS(configfile) "$MVS(homedir)/$argv"
unset app
# Sanity Checker.
#
# Usage: SanityCheck "pathname"
#
# Checks a path to be sure it passed sane rules. It will return 1
# if this path passes or else it will return 0 if it does not
# pass.
#
# Only defined if running standalone. (command line daemon)
#
proc SanityCheck {what} {
if {[string first "../" $what] != -1} {
unset what
return 0
}
if {[string first "//" $what] != -1} {
unset what
return 0
}
if {[string first "~/" $what] != -1} {
unset what
return 0
}
if {[string range $what 0 0] == "/"} {
unset what
return 0
} else {
unset what
return 1
}
}
#
# Test a value to be sure it is a number.
#
# Usage: TestNum "12345"
#
# This function will test a value to be sure it is a number. The
# function will return 0 if it is a number and 1 if it is not a
# number.
# only defined if running standalone. (command line daemon)
#
proc TestNum {number} {
global MVS
if {[string length [string trim $number -0123456789]]} {
return 1
} else {
return 0
}
}
} else {
set MVS(standalone) 0
set MVS(homedir) $homedir
set MVS(configfile) "$MVS(homedir)/pserver.cfg"
set argv "Sourced!"
}
#
# Make sure they gave a config file name.
#
if {![string compare $argv ""]} {
LogIt "Usage: server.tcl <Config File>"
exit
}
#
# Load the config.
#
ReloadConfig
#
# Open the listening socket.
#
set MVS(server_socket) [socket -server NewConnect $MVS(port)]
#
# Call our recursing functions.
# These functions call themselves over time to perform routine repetetive
# tasks.
#
Serv_CheckTimeouts
RegisterWithORTs
#
# Thats it! If we are in stand alone mode then use the vwait command to
# create a means for events to trigger wile waiting forever for a variable
# which will never be changed.
#
if $MVS(standalone) {
vwait MVS(waiter)
}
syntax highlighted by Code2HTML, v. 0.9.1