#!/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
#
# DRG: Cruise <cruise@openverse.org>
# AMG: Unununium <unununium@openverse.org>
#
# Copyright (C) 1999 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.

set MVS(server_version) "2.0.0"

# UTILITY FUNCTIONS ----------------------------------------------------------

# Central logging facility
#
# Usage: LogIt "Text to log"
#
# This proc writes text to the log.
proc LogIt {text} {
	global MVS

	if $MVS(standalone) {
		# We are running from a command line
		puts "$text$MVS(ansi.reset)"
	} else {
		# We are running from a GUI
		if {[winfo exists .ovserver]} {
			# The window's there, so write to it
			.ovserver.log insert end "$text\n"
			.ovserver.log see end
			# TODO (6) Check for number of lines and trim.
		} else {
			# Uhm, it's gone (???) so just use stdout
			puts $text
		}
	}
	
	unset text
}

# Send text to a connected user
#
# Usage: SendToUser socket "text to send"
#
# This proc sends the provided text to the specified socket.  It should be
# preformatted and ready to go.
proc SendToUser {who what} {
	global MVS

	LogIt "$MVS(ansi.put)($who) -> $what"
	catch {puts $who "$what"}
	
	unset who what
}

# Send text to ALL users
#
# Usage: SendToAllUsers "Text to send"
#
# This proc sends the provided text to all connected users.  The text should
# be preformatted and ready to go.
proc SendToAllUsers {what} {
	global MVS
	
	foreach sock $MVS(socks) {
		if {$MVS($sock.name) != "*"} {
			# Only talk to authenticated sockets
			LogIt "$MVS(ansi.put)($sock) -> $what"
			catch {puts $sock "$what"}
		}
	}
	
	unset what
}

# Check name validity
#
# Usage: CheckName "nick"
#
# This proc checks 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] == "-"} {
		# The name is bad because it's either null, "*", ".", or
		# starts with a "-", so complain
		unset name
		return 0
	} else {
		# 'Tis a fine name
		unset name
		return 1
	}
}

# Check gif image size
#
# Usage: CheckGif "filename"
#
# This proc reads the GIF File header and determines its size.  It compares
# the size against the server limits and reports whether the file is good or
# bad.
proc CheckGif {file} {
	global MVS

	# Read the first ten bytes
	set infile [open $file r]
	fconfigure $infile -translation binary
	set bits [read $infile 10]
	close $infile
	unset infile

	# Check whether or not it's a GIF
	if {[string range $bits 0 2] != "GIF"} {
		LogIt "$MVS(ansi.concern){CheckGif|file=$file} Failed!  Not a GIF"
		unset bits file
		return 0
	}

	# Check the image size against the acceptible maximums
	binary scan $bits s* var
	if {[lindex $var 4] <= $MVS(maxheight) && [lindex $var 3] <= \
			$MVS(maxwidth)} {
		LogIt "{CheckGif|file=$file} Passed!  ([lindex $var 3] x [lindex $var 4])"
		unset var bits file
		return 1
	} else {
		LogIt "$MVS(ansi.concern){CheckGif|file=$file} Failed!  ([lindex $var 3] x [lindex $var 4])"
		unset var bits file
		return 0
	}
}

# Error logging routine
#
# Usage: Used internally when an error occurs
#
# This proc prints out error information as the program continues.
proc bgerror {stuff} {
	global errorInfo errorCode
	
	LogIt "-------------------------------------"
	LogIt "BGERROR Begin"
	LogIt "-------------------------------------"
	LogIt "Error Code: $stuff"
	LogIt "-------------------------------------"
	LogIt $errorInfo
	LogIt "-------------------------------------"
	LogIt "BGERROR End"
	LogIt "-------------------------------------"

	unset stuff
}

# Prefix stripper
#
# Usage: strip message word_count
#
# This proc removes the first word_count words from message and then returns
# the result.
proc strip {msg count} {
	# See if there are enough words
	if {[llength [split $msg " "]] <= $count} {
		unset msg count
		return ""
	}

	# Remove i words from the beginning
	for {set i 0} {$i < $count} {incr i} {
		set msg [string range $msg [expr [string first " " $msg] + 1] \
				end]
	}
	unset i count

	return $msg
}

# Timeout and event checker
#
# Usage: Serv_CheckTimeouts
#
# This proc infinitely recalls itself.  It checks whether various timeouts
# have expired.  It also looks for tickler files which cause the server to
# reload its configuration file(s).
proc Serv_CheckTimeouts {} {
	global MVS

	# Check user ping times
	set tme [clock seconds]
	foreach sock $MVS(socks) {
		if {[expr $tme - $MVS($sock.ping_response)] > 320} {
			# Client hasn't ponged a ping in time
			LogIt "$MVS(ansi.concern)($sock) -- Ping timeout"
			DisconnectUser $sock 1
		} elseif {[expr $tme - $MVS($sock.ping)] > 150} {
			# It's time to ping this user
			set MVS($sock.ping) [clock seconds]
			SendToUser $sock "PING"
		}
	}
	
	# Check active downloads
	set tme [clock seconds]
	foreach idx $MVS(dcc_list) {
		if {[expr $tme - $MVS(DCC.$idx.time)] > $MVS(timeout)} {
			# This transfer has taken too long
			if {$MVS(DCC.$idx.server) > 0} {
				# Kill it!
				catch {close $MVS(DCC.$idx.server)}
			}
			Serv_endDCC Timer $idx 0 "Connection timed out: $MVS(DCC.$idx.file)"
		}
	}
	
	# Check for tickler files
	if [file exists "$MVS(tickler)"] {
		Configure
		catch {file delete -force "$MVS(tickler)"}
	}
	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}

	catch {unset sock idx}
	unset tme
}

# Memory dumper
#
# Usage: Serv_DumpMem
#
# This proc dumps the contents of the server array to Dump.mem.  The presence
# of the TickleMem file invokes 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]

	# Dump all arrays to disk
	set outfile [open "$MVS(homedir)/Dump.mem" "w"]
	foreach ar $arrays {
		puts $outfile "------------------------------------------------------------------------------"
		puts $outfile " OpenVerse Server - THIS IS THE $ar\() ARRAY"
		puts $outfile "------------------------------------------------------------------------------"
		set toggle 0
		set values {}
		set keys {}
		
		# Every other entry is a key
		foreach var [array get $ar] {
			if {!$toggle} {
				lappend keys $var
				set toggle 1
			} else {
				set toggle 0
			}
		}

		# List the keys and their values
		set keys [lsort $keys]
		foreach key $keys {
			puts $outfile [format "%-39.39s %-39.39s" $key \
					[set $ar($key)]]
		}
	}
	close $outfile

	unset arrays outfile toggle values keys
}

# User avatar changer
#
# Usage: Serv_ChangeAvatar who avatar_name nametag_x nametag_y size
#		balloon_x balloon_y
#
# This proc changes user avatars.  It announces the avatar change to all
# conneced users.
proc Serv_ChangeAvatar {who what x y size bx by} {
	global MVS

	# Change avatar-related variables
	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 {$what == "default.gif"} {
		# Change to default avatar
		SendToAllUsers "AVATAR $MVS($who.name) $what $MVS($who.av_head_x) $MVS($who.av_head_y) [file size $MVS(icons)/$what] $bx $by"
		unset who what x y size bx by
		return
	}

	if ![file exists $MVS(avatars)/$what] {
		# Download a new avatar
		LogIt "($who) -- $what does not exist on server"
		GetBinaryFile $who $MVS($who.avatar) $size AVATAR
	} else {
		# Use an existing avatar
		if {[file size $MVS(avatars)/$what] != $size} {
			# It's a new version; download it
			LogIt "($who) -- $what's size of $size != [file size $MVS(avatars)/$what]"
			GetBinaryFile $who $MVS($who.avatar) $size AVATAR
		} else {
			# Check its validity
			if [CheckGif "$MVS(avatars)/$what"] {
				# Good!
				SendToAllUsers "AVATAR $MVS($who.name) $what $MVS($who.av_head_x) $MVS($who.av_head_y) [file size $MVS(avatars)/$what] $bx $by"
			} else {
				# No...
				SendToAllUsers "AVATAR $MVS($who.name) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
				SendToUser $who "TOOBIG"
				set MVS($who.avatar) "default.gif"
			}
		}
	}

	unset who what x y size bx by
}

# Color activator
#
# Usage: ColorSwitch value
#
# This proc turns on colors.  It is supposed to be called from server.cfg.  It
# also can turn them off, if value is set to zero.
proc ColorSwitch {value} {
	global MVS

	if $value {
		# TODO: add colors in GUI
		if $MVS(standalone) {
			# Set up ANSI codes in console
			set MVS(ansi.error) "\033\[1;33;41m"
			set MVS(ansi.concern) "\033\[1;33m"
			set MVS(ansi.put) "\033\[1;32m"
			set MVS(ansi.get) "\033\[1;35m"
			set MVS(ansi.reset) "\033\[0m"
		 }
	} else {
		# No colors
		set MVS(ansi.error) ""
		set MVS(ansi.concern) ""
		set MVS(ansi.put) ""
		set MVS(ansi.get) ""
		set MVS(ansi.reset) ""
	}

	unset value
}

# Server configuration file loader
#
# Usage: ReloadConfig
#
# This proc (re)loads the server configuration file.
proc ReloadConfig {} {
	global MVS

	LogIt "------------ Loading Config File ------------"

	# Server configuration defaults
	set MVS(port) "7000";				# Port
	set MVS(timeout) "120";				# Transfer timeout
	set MVS(roomname) "My Own Room";		# Room title
	set MVS(avatars) "$MVS(homedir)/simages";	# User avatars
	set MVS(images) "$MVS(homedir)/images";		# Servr images
	set MVS(icons) "$MVS(homedir)/icons";		# Icons
	set MVS(roomdir) "$MVS(homedir)/rooms";		# Room images
	set MVS(sobjects) "$MVS(homedir)/sobjects";	# Server objects
	set MVS(splugins) "$MVS(homedir)/splugins";	# Server plugins

	set MVS(tickler) "$MVS(homedir)/TickleMe";	# Tickler file
	set MVS(mem_tickler) "$MVS(homedir)/TickleMem";	# Memory dump flag file
	
	set MVS(maxwidth) "320";			# Max avatar width
	set MVS(maxheight) "200";			# Max avatar height

	set MVS(roomfile) "room.gif";			# Room image
	
	set MVS(sendbuffer) "4096";			# Send buffer size
	set MVS(maxmsglen) "256";			# Max message length
	
	set MVS(exits) {};				# Host IP:port list
	set MVS(locations) {};				# Coords of exits
	
	set MVS(max_same_users) 10;			# Max connections

	# Create missing directies
	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)"}
	if {![file exists $MVS(roomdir)]} {file mkdir "$MVS(roomdir)"}

	# Parse configuration file
	if {$MVS(configfile) != "" && [file exists "$MVS(configfile)"]} {
		source $MVS(configfile)
	}
	
	# Continue processing
	return 1
}

# LOGIN FUNCTIONS ------------------------------------------------------------

# New connection handler
#
# Usage: NewConnect socket address port
#
# This proc handles new connections to the server.  It sets a couple of
# initial variables and then passes control to all procs registered for
# whichever type of authentication is tendered.
proc NewConnect {who address port} {
	global MVS

	if {[lsearch $MVS(socks) $who] == -1} {
		# Not a duplicate socket; allow
		lappend MVS(socks) $who
	} else {
		# Duplicate socket; ignore
		LogIt "$MVS(ansi.error){NewConnect|who=$who|address=$address|port=$port} Duplicate socket"
		close $who
		unset who address port
		return
	}

	# Ensure that no one host has too many connections to this server
	set count 1
	foreach sock $MVS(socks) {
		if {$sock != $who && $MVS($sock.address) == $address} {
			incr count
		}
	}
	if {$count > $MVS(max_same_users)} {
		LogIt "$MVS(ansi.concern){NewConnect|who=$who|address=$address|port=$port} Max connection count exceeded"
		SendToUser $who "TOOMANYCONNECTIONS"
		close $who
		unset who address port count sock
		return
	}

	# So far so good... log it!
	LogIt "($who) -- Connected!  $address:$port"

	# Have AuthRead get the login stuff from the socket
	fconfigure $who -blocking 0 -buffering line
	fileevent $who readable "AuthRead $who"

	# Set server variables to defaults
	set MVS($who.name) "*"
	set MVS($who.address) "$address"
	set MVS($who.port) "$port"
	set MVS($who.ping) "0"
	set MVS($who.ping_response) "[clock seconds]"
	set MVS($who.x) "-1"
	set MVS($who.y) "-1"
	set MVS($who.avatar) "*connecting*"
	set MVS($who.av_head_x) "-1"
	set MVS($who.av_head_y) "-1"
	set MVS($who.downloads) {}

	# Update the user count and the GUI user count display
	incr MVS(users)
	if !$MVS(standalone) {
		.ovserver.buttons.info.v configure -text $MVS(users)
	}

	unset who address port count sock
}

# Login getter
#
# Usage: AuthRead socket
#
# This proc gets the first line of text from a socket and then passes control
# of the socket on to the appropriate hooked proc based on the first word of
# the first line.  It also passes a copy of the first line so that the hooked
# proc can extract more useful information from it.  If the login type is
# unsupported, it 
proc AuthRead {who} {
	global MVS

	# Don't let AuthRead get called again
	fileevent $who readable ""

	# See what the user has to say
	set input ""
	catch {gets $who input}

	# Did the poor dude quit on us?
	if [eof $who] {
		LogIt "$MVS(ansi.concern){AuthRead|who=$who} Unexpected EOF/disconnection"
		DisconnectUser $who 0
		unset who input
		return
	}

	LogIt "$MVS(ansi.get)($who) <- $input"
	
	# Get a list of procs hooked onto this authtype
	set hooks [array names MVS \
			"connect.[lindex [split $input " "] 0].hooks"]
	
	if [llength $hooks] {
		# Yes, this authtype is supported
		set hooks $MVS($hooks)
		foreach hook $hooks {
			# Call each hooked proc in turn
			if ![$hook $who $input] {
				# This hook requested processing to stop
				LogIt "{AuthRead|who=$who} $hook returned 0; stopping"
				break
			}
		}
		unset hook
	} else {
		# Unsupported authtype
		LogIt "$MVS(ansi.concern){AuthRead|who=$who} Unsupported authtype"
		SendToUser $who "AUTH REQD"
		DisconnectUser $who 0
	}

	unset who input hooks
}

# AUTH handler helper
#
# Usage: StandardAuth socket input
#
# This proc does the basic validity checking and bookkeeping for AUTH logins.
# It returns 0 on error and 1 on success.
proc StandardAuth {who input} {
	global MVS
	
	# AUTH name x y avatarFile headX headY fileSize balloonX balloonY

	# Strip first five characters off of input and call it "parms"
	set parms [split [string range $input 5 end] " "]

	# Ensure that the numeric fields really are numeric
	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]] } {
		# Nonnumeric characters in AUTH line; disconnect
		LogIt "$MVS(ansi.concern){HandleConnect.AUTH|who=$who|input=$input} Invalid numeric fields in AUTH line"
		SendToUser $who "AUTH FAILED (invalid numeric fields)"
		DisconnectUser $who 0

		# Allow no further processing
		unset input who parms
		return 0
	}

	# Ensure that no field is too long
	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} {
		LogIt "$MVS(ansi.concern){HandleConnect.AUTH|who=$who|input=$input} Field too long"
		SendToUser $who "AUTH FAILED (invalid field lengths)"
		DisconnectUser $who 0

		# Allow no further processing
		unset input who parms
		return 0
	}

	# Ensure that some fields are positive
	if {[lindex $parms 1] < 0 || \
			[lindex $parms 2] < 0 || \
			[lindex $parms 6] < 0} {
		LogIt "$MVS(ansi.concern){HandleConnect.AUTH|who=$who|input=$input} Negative field"
		SendToUser $who "AUTH FAILED (negative numbers not allowed)"
		DisconnectUser $who 0

		# Allow no further processing
		unset input who parms
		return 0
	}

	# Ensure that nickname is valid
	if ![CheckName [string range [lindex $parms 0] 0 12]] {
		LogIt "$MVS(ansi.concern){HandleConnect.AUTH|who=$who|input=$input} Bad nickname"
		SendToUser $who "BADNAME"
		DisconnectUser $who 0

		# Allow no further processing
		unset input who parms
		return 0
	}

	# Ensure nickname is unique
	foreach sock $MVS(socks) {
		if {$MVS($sock.name) == [string range [lindex $parms 0] 0 12]} {
			LogIt "$MVS(ansi.concern){HandleConnect.AUTH|who=$who|input=$input} Nickname already in use"
			SendToUser $who "NAMEINUSE"
			DisconnectUser $who 0

			# Allow no further processing
			unset input who parms sock
			return 0
		}
	}
	
	# Extricate various bits of info from input line
	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]; # Should be "balloon",
	set MVS($who.av_baloon_y) [lindex $parms 8]; # but Cruise can't speel

	# Pass on control of this socket
	fileevent $who readable "Serv_ReadFrom $who"

	# Send the user some information about the room
	SendToUser $who "ROOMNAME $MVS(roomname)"
	SendToUser $who "ROOM $MVS(roomfile) [file size $MVS(roomdir)/$MVS(roomfile)]"

	unset input who parms sock
	return 1
}

# DISCONNECTION FUNCTIONS -----------------------------------------------------

# User disconnecter
#
# Usage: DisconnectUser socket announce_disconnect
#
# This proc disconnects users from the system and cleans up some variables.  If
# announce_disconnect is set to 1, hooks will be processed.
proc DisconnectUser {who announce} {
	global MVS
	
	# Cancel if this guy isn't listed
	if {[lsearch -exact $MVS(socks) $who] == -1} {
		LogIt "$MVS(ansi.error){DisconnectUser|who=$who|announce=$announce} This guy doesn't exist!"
		unset who announce
		return
	}

	if {$announce && [array names MVS "disconnect.pre.hooks"] != ""} {
		# Call pre-cleanup hooks
		foreach hook $MVS(disconnect.pre.hooks) {
			# Call each hooked proc in turn
			if ![$hook $who] {
				# This hook requested processing to stop
				LogIt "{DisconnectUser|who=$who|announce=$announce} $hook returned 0; stopping"
				break
			}
		}
		catch {unset hook}
	}
	
	LogIt "($who) -- Disconnected!  $MVS($who.address):$MVS($who.port)"

	# Update the user count
	incr MVS(users) -1
	if !$MVS(standalone) {
		.ovserver.buttons.info.v configure -text $MVS(users)
	}

	# Actually close the connection
	catch {close $who}

	# Remove this entry from the list of sockets
	set which [lsearch -exact $MVS(socks) $who]
	set MVS(socks) [lreplace $MVS(socks) $which $which]

	# 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)}

	if {$announce && [array names MVS "disconnect.post.hooks"] != ""} {
		# Call post-cleanup hooks
		foreach hook $MVS(disconnect.post.hooks) {
			# Call each hooked proc in turn
			if ![$hook] {
				# This hook requested processing to stop
				LogIt "{DisconnectUser|who=$who|announce=$announce} $hook returned 0; stopping"
				break
			}
		}
		catch {unset hook}
	}

	unset who announce
}

# CHAT FUNCTIONS --------------------------------------------------------------

# Incoming text reader
# 
# Usage: Serv_ReadFrom socket
#
# This proc reads text from sockets and farms out processing to hooked procs
# depending on the first word of the text.
proc Serv_ReadFrom {who} {
	global MVS
	
	set input ""
	catch {gets $who input}

	# Did the poor dude quit on us?
	if [eof $who] {
		LogIt "{Serv_ReadFrom|who=$who} Unexpected EOF/disconnection"
		DisconnectUser $who 1
		unset who input
		return
	}

	# Nope... processing time!
	LogIt "$MVS(ansi.get)($who) <- $input"

	# See if this command is supported
	set hooks [array names MVS \
			"message.[lindex [split $input " "] 0].hooks"]
	if [llength $hooks] {
		# Yes, this command is supported
		set hooks $MVS($hooks)
		foreach hook $hooks {
			# Call each hooked proc in turn
			if ![$hook $who $input] {
				# This hook requested processing to stop
				LogIt "{Serv_ReadFrom|who=$who} $hook returned 0; stopping"
				break
			}
		}
		unset hook
	} else {
		# Unsupported command
		LogIt "$MVS(ansi.concern){Serv_ReadFrom|who=$who} Unsupported command"
	}

	unset who input hooks
}

# INITIALIZATION FUNCTIONS ---------------------------------------------------

# Server initializer
#
# Usage: Initialize
#
# This proc calls the one-time startup initialization hooks.
proc Initialize {} {
	global MVS

	# Call initialization hooks
	if {[array names MVS "init.start.hooks"] == ""} {return}
	foreach hook $MVS(init.start.hooks) {
		# Call each hooked proc in turn
		if ![$hook] {
			# This hook requested processing to stop
			LogIt "{Initialize} $hook returned 0; stopping"
			break
		}
	}

	catch {unset hook}
}

# Server configurator
#
# Usage: Configure
#
# This proc calls the configuration (ticklish) hooks.
proc Configure {} {
	global MVS

	# Call configuration hooks
	if {[array names MVS "init.tickle.hooks"] == ""} {return}
	foreach hook $MVS(init.tickle.hooks) {
		# Call each hooked proc in turn
		if ![$hook] {
			# This hook requested processing to stop
			LogIt "{Configure} $hook returned 0; stopping"
			break
		}
	}
	
	catch {unset hook}
}

# Plugin loader
#
# Usage: LoadPlugins
#
# This proc sources all the server plugins.
proc LoadPlugins {} {
	global MVS

	foreach dir [lsort -ascii [glob -nocomplain "$MVS(splugins)/*"]] {
		if {[file isdirectory "$dir"] && \
				[file exists "$dir/PlugInit.tcl"]} {
			LogIt "Loading plugin \"$dir\"..."
			set MVS(current_plugin_dir) $dir
			catch {source [file nativename "$dir/PlugInit.tcl"]}
		}
	}
	
	catch {unset dir}
}

# DCC FUNCTIONS --------------------------------------------------------------

# Duplicate download checker
#
# Usage: DuplicateCheck socket filename
#
# This proc returns 0 if the user is already getting the named file.
proc DuplicateCheck {who what} {
	global MVS

	# No transfers, no duplicates!
	if {[llength $MVS(dcc_list)] == 0} {
		unset who what
		return 1
	}

	# Scan through all file transfers
	foreach idx $MVS(dcc_list) {
		# See if it's the same person and the same file
		if {$MVS(DCC.$idx.sender) == $who && \
				[file tail $MVS(DCC.$idx.file)] == $what} {
			# Yup
			unset who what idx
			return 0
		}
	}

	# Nope
	unset who what
	return 1
}

# File sender
#
# Usage: Serv_DCCSend socket filename transfer_type
#
# This proc initiates file transfers.  It sends rooms, avatars, and object
# images.  It is a passive DCC transfer so that it works through firewalls.
proc Serv_DCCSend {who what type} {
	global MVS

	# Don't send more than once!
	if ![DuplicateCheck $who $what] {
		LogIt "$MVS(ansi.concern)($who) -- Already getting $what"
		unset who what type
		return
	}

	# Depending on the type, do different stuff
	switch -exact -- $type {
		"AVATAR" {
			if {$what == "default.gif"} {
				set file "$MVS(icons)/default.gif"
			} else {
				set file "$MVS(avatars)/$what"
			}
			set get_command "DCCGETAV"
		} "OBJECT" {
			set file "$MVS(images)/$what"
			set get_command "DCCGETOB"
		} "ROOM" {
			set file "$MVS(roomdir)/$what"
			set get_command "DCCGETROOM"
		} "ORT" {
			set file "$MVS(homedir)/images/$what"
			set get_command "DCCGETAV"
		} default {
			unset who what type
			return
		}
	}

	# Don't do anything if the file doesn't exist!
	if ![file exists $file] || ![file readable $file] {
		LogIt "$MVS(ansi.concern){Serv_DCCSend|who=$who|what=$what|type=$type} Cannot read file $file"
		unset who what type
		return
	}
	
	# Find the file size
	set size [file size $file]

	# Increment the DCC counter
	set idx [incr MVS(dcc_num)]

	# Open a listening socket
	set sock [socket -server "Serv_acceptSend $idx" 0]

	# Get the port
	if {[catch {fconfigure $sock -sockname} port]} {
		LogIt "$MVS(ansi.concern){Serv_DCCSend|who=$who|what=$what|type=$type} Cannot get port for server ($port)"
	}

	# Set all sorts of DCC variables
	lappend MVS(dcc_list) $idx
	set MVS(DCC.$idx.sender) $who
	set MVS(DCC.$idx.file) "$file"
	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

	# Tell the user to get the file
	SendToUser $who "$get_command [lindex $port 2] $what $size"

	unset size idx sock port file get_command who what type
}

# File send accepter
#
# Usage: Serv_acceptSend index socket host port
#
# This proc is called by the opening of the server socket.  It accepts a
# connection, closes the server socket, and starts sending the file to the
# user.
proc Serv_acceptSend {index chan hst port} {
	global MVS

	# close the server port
	catch {close $MVS(DCC.$index.server)}
	uplevel set MVS(DCC.$index.server) -1
	uplevel #0 set MVS(DCC.$index.sock) $chan
	
	set msg ""

	# Open the file to send
	if {[catch {open $MVS(DCC.$index.file) RDONLY} infile]} {
		Serv_endDCC Send $index 0 "$MVS(ansi.concern){Serv_acceptSend|index=$index|chan=$chan|hst=$hst|port=$port} Cannot read $MVS(DCC.$index.file) ($infile)"
		unset infile index chan hst port msg
		return 0
	}

	# See if the transfer starts at byte zero
	if {[set posn $MVS(DCC.$index.posn)] != "" && $posn > 0} {
		# Don't start at the beginning
		if {[catch {seek $infile $posn start} msg]} {
			# Can't go that far into the file
			Serv_endDCC Send $index 0 "$MVS(ansi.concern){Serv_acceptSend|index=$index|chan=$chan|hst=$hst|port=$port} Cannot seek $MVS(DCC.$index.file) ($msg)"
			close $infile
			unset infile posn msg index chat hst port
			return 0
		}
		# This many bytes less to send
		uplevel #0 incr MVS(DCC.$index.size) -$posn
	} 

	# See if the transfer is done (i.e. posn >= size)
	if {$MVS(DCC.$index.size) == 0} {
		# Done!
		close $infile
		after 50 "Serv_endDCC Send $index 1 \"Transfer completed\""
		unset infile posn msg index chan hst port
		return 1
	}

	# Get start time
	set st [clock seconds]

	# Don't warp the file in any way
	fconfigure $infile -translation binary

	# Read the start of the file
	if {[catch {set buffer [read $infile $MVS(sendbuffer)]} msg]} {
		# Trouble
		Serv_endDCC Send $index 0 "Error reading $file ($msg)"
		close $infile
		unset infile posn msg st buffer index chan hst port
		return 0
	}

	# 
	global tl
	set tl($chan) [string length $buffer]

	# Set up some junk
	fconfigure $chan -blocking 0 -buffering none -translation binary

	# Send the first hunk of the file
	if {[catch {puts -nonewline $chan $buffer} msg]} {
		# Trouble
		Serv_endDCC Send $index 0 "Error writing to $chan ($msg)"
		close $infile
		unset infile posn msg st buffer index hst port tl($chan) chan
		return 0
	}

	# Good!
	LogIt "($MVS(DCC.$index.sender)) -- Accepted Serv_DCCSend"

	# From now on have Serv_dccSendEvent process the channel
	fileevent $chan readable "Serv_dccSendEvent $index $st $infile"

	unset infile posn msg st buffer index hst port chan
}

# File send event trigger
#
# Usage: Serv_dccSendEvent index start_time file_stream_descriptor 
#
# This proc is triggered when the client sends a response announcing the number
# of bytes this server has sent to it.  It sends more data if the client
# successfully received all the data sent to it last time.  It ends the
# transfer when the client receives all the data.
proc Serv_dccSendEvent {index st fd} {
	global MVS tl
	
	# For convenience...
	set sock $MVS(DCC.$index.sock)

	# Adjust the timeout data
	uplevel #0 set MVS(DCC.$index.time) [clock seconds]

	set msg ""

	# Quit if the file transfer has been broken
	if [eof $sock] {
		after 50 "Serv_endDCC Send $index 0 \"Transfer interrupted\""
		close $fd
		unset index st fd msg tl($sock) sock
		return
	}

	# Read the byte count from the client
	if [catch {set l [read $sock 4]} msg] {
		Serv_endDCC Send $index 0 "Read error ($msg)"
		catch {unset l} 
		close $fd
		unset index st fd msg tl($sock) sock
		return
	}

	# Quit if the byte count is null
	if {$l == ""} {
		Serv_endDCC Send $index 0 "Sync read error"
		close $fd
		unset index st fd msg l tl($sock) sock
		return
	}

	# Convert the byte count to an integer
	set cl 0
	binary scan $l "I1" cl

	# If the client returned a different byte count than expected, quit
	if {$cl != $tl($sock)} {
		unset index st fd msg l cl sock
		return
	}

	# See if the transfer is done
	if [eof $fd] {
		LogIt "($MVS(DCC.$index.sender)) -- Got check (OK/EOF)"
		close $fd
		after 50 "Serv_endDCC Send $index 1 \"Transfer completed\""
		unset index st fd msg l cl tl($sock) sock
		return
	}

	# It's not done
	LogIt "($MVS(DCC.$index.sender)) -- Got check (OK/not EOF)"

	# Read some more data
	if [catch {set buffer [read $fd $MVS(sendbuffer)]} msg] {
		# Trouble
		Serv_endDCC Send $index 0 "Error reading $MVS(DCC.$index.file) : $msg"
		close $fd
		unset index st fd msg l cl msg tl($sock) sock
		catch {unset buffer}
		return
	}

	# See how much data was read
	if {[set lng [string length $buffer]] == 0} {
		close $fd
		after 50 "Serv_endDCC Send $index 1 \"Transfer completed\""
		unset index st fd msg l cl msg buffer lng tl($sock) sock
		return
	}

	# Adjust the location indicator
	incr tl($sock) $lng
	LogIt "($MVS(DCC.$index.sender)) -- Sent $lng bytes ($tl($sock) total)"

	# Send some more data
	if [catch {puts -nonewline $sock $buffer} msg] {
		Serv_endDCC Send $index 0 "Write error ($msg)"
		close $fd
		unset index st fd msg l cl msg buffer lng tl($sock) sock
		return
	}
	unset index st fd sock msg l cl buffer lng
	catch {unset msg}
}

# Passive DCC file downloader
#
# Usage: GetBinaryFile socket filename file size
#
# This proc sets up a passive DCC transfer between a user and the server.  It
# sets up a listening port and tells the user where to connect to.  It also
# sets up an event to accept the connection and download the file.
proc GetBinaryFile {who what size type} {
	global MVS
	
	# See if the filename is possible
	if ![SanityCheck "$what"] {
		LogIt "$MVS(ansi.concern)($who) -- $what fails SanityCheck"
		unset who what size type
		return
	}

	# Don't download multiple times
	if ![DuplicateCheck $who $what] {
		LogIt "$MVS(ansi.concern)($who) -- Already getting $what from this user"
		unset who what size type
		return
	}

	# The only thing users ever send is avatars, anyway...
	set file "$MVS(avatars)/$what"	
	
	# Increment the DCC counter
	set idx [incr MVS(dcc_num)]

	# Open a socket to accept the transfer
	set sock [socket -server "acceptGet $idx" 0]

	# Find its port
	if [catch {fconfigure $sock -sockname} port] {
		LogIt "$MVS(ansi.concern){GetBinaryFile|who=$who|what=$what|size=$size|type=$type} Cannot get port for server ($port)"
	}

	# Set up DCC variables
	lappend MVS(dcc_list) $idx
	set MVS(DCC.$idx.sender) $who
	set MVS(DCC.$idx.file) "$file"
	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)

	# Tell the user where to send
	SendToUser $who "DCCSENDAV [lindex $port 2] $what"

	unset who what size type file idx sock port
}

# Incoming file transfer accepter
#
# Usage: Serv_acceptGet index socket host port
#
# This proc is called by the server socket being connected to.  It accepts the
# connection, closes the server socket, and starts downloading the file from
# the user.
proc acceptGet {index chan hst port} {
	global MVS

	# Close the server socket
	catch {close $MVS(DCC.$index.server)}
	uplevel set MVS(DCC.$index.server) -1
	uplevel #0 set MVS(DCC.$index.sock) $chan

	# For convenience...
	set file $MVS(DCC.$index.file)
	set posn $MVS(DCC.$index.posn)

	# Set up the transfer socket
	fconfigure $MVS(DCC.$index.sock) -buffering none -blocking 0 -translation binary -buffersize 4096

	# Write-only and create the file if it doesn't exist
	set flags [list WRONLY CREAT]
	
	set msg ""

	# If starting from the beginning, delete any existing file
	if {$posn == 0} {lappend flags TRUNC}

	# Open the file to write to
	if ![catch {open $file $flags 0600} outfile] {
		# No problem
		if {$posn != 0} {
			# Not starting at beginning; seek to position
			if [catch {seek $outfile $posn start} msg] {
				# Trouble
				close $outfile
				Serv_endDCC Get $index 0 "Cannot seek on $file ($msg)"
				unset index chan hst port file posn flags msg
				return 0
			}
			# Woohoo!  Less bytes to transfer
			uplevel #0 incr MVS(DCC.$index.size) -$posn
		}
		# Start at byte zero
		uplevel #0 set tl($MVS(DCC.$index.sock)) 0

		# Don't mutate file
		fconfigure $outfile -translation binary 

		# When client tries to send data, call this proc
		fileevent $MVS(DCC.$index.sock) readable "Serv_dccGetEvent $index [clock seconds] $outfile"
	} else {
		# Trouble
		Serv_endDCC Get $index 0 "Cannot write $file ($outfile)"
		unset index chan hst port file posn flags msg
        	return 0
	}
	
	unset index chan hst port file posn flags msg
	return 1
}

# File read event trigger
#
# Usage: Serv_dccGetEvent index start_time file_stream_descriptor 
#
# This proc is called when the client sends data to this server.
proc Serv_dccGetEvent {index st out} {
	global tl MVS

	# Download from this source
	set in $MVS(DCC.$index.sock)

	# Download this many bytes total
	set leng $MVS(DCC.$index.size)
	
	# Update the timeout value
	uplevel #0 set MVS(DCC.$index.time) [clock seconds]

	# Fail cleanly or bleed all over the motherboard?
	set fail_type 0

	if [eof $in] {
		# The source socket has been closed
		if {$tl($in) < $leng} {
			# Not all data received
			set msg "Transfer interrupted"
			set fail_type 0
		} elseif {$tl($in) > $leng} {
			# What the fsck...?
			set msg "Too much data transferred!!"
			set fail_type 0
		} else {
			# Just right
			if {[set st [expr {[clock seconds] - $st}]] == 0} {
				set st 1
			}
			set msg "Transfer completed at [expr $leng / ($st * 1024.0)] Kb/sec"
			set fail_type 1
		}
	} else {
		# Read data from the socket
		if ![catch {set buffer [read $in]} msg] {
			# No trouble

			# This much data less to transfer before completion
			incr tl($in) [set l [string length $buffer]]

			# Make a note of it
			LogIt "($in) -- Downloaded $l bytes ($tl($in) total)"

			# Write data to file
			if ![catch {puts -nonewline $out $buffer} msg] {
				# Success; now report to client how much data
				# was transferred
				if ![catch {puts -nonewline $in [binary \
						format "I1" $tl($in)]} msg] {
					# Good!
					flush $in
					unset index st out in leng fail_type \
							buffer
					catch {unset msg}
					return
				} else {
					# Failure responding
					unset buffer
				}
			} else {
				# Failure writing
				unset buffer
				set fail_type 0
			}
		} else {
			# Trouble
			set fail_type 0
			catch {unset buffer}
		}
    	}
	# Close output file
	catch {close $out} 

	# End transfer
	Serv_endDCC Get $index $fail_type $msg

	unset index st out in leng fail_type
}

# DCC transfer killer
#
# Usage: Serv_endDCC transfer_type index fail_type debug_info
#
# This proc ends DCC transfers.  On failures, it logs information about the
# transfer.  On successful avatar downloads, it announces the avatar to the
# connected users.  Finally, it unsets all variables used by the transfer.
proc Serv_endDCC {type index fail_type debug} {
        global MVS tl

	# Log debugging stuff on failured file transfers
        if !$fail_type {
                LogIt "$MVS(ansi.concern)($MVS(DCC.$index.sender)) (DCC$type) - $debug"
        }

	# Close the transfer socket
	catch {close $MVS(DCC.$index.sock)}

	# Cut out this entry from the DCC list
	set idx [lsearch -exact $MVS(dcc_list) $index]
	set MVS(dcc_list) [lreplace $MVS(dcc_list) $idx $idx]

	# If a successful avatar download, announce
	if {$type == "Get" && $fail_type} {
		switch -- $MVS(DCC.$index.type) {
		"ORT" {
			# ORT transfer complete

			# Too bad there's no way to put this with the rest of
			# the ORT code...
			LogIt "(ORT) Image transfer ($MVS(DCC.$index.file)) complete"
		} default {
			# Check image validity
			if [CheckGif "$MVS(DCC.$index.file)"] {
				# It's fine
				SendToAllUsers "AVATAR $MVS($MVS(DCC.$index.sender).name) [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 {
				# Nope
				set MVS($MVS(DCC.$index.sender).avatar) \
						"default.gif"
				SendToAllUsers "AVATAR $MVS($MVS(DCC.$index.sender).name) default.gif 0 20 [file size $MVS(icons)/default.gif] 24 6"
				SendToUser $MVS(DCC.$index.sender) "TOOBIG"
			}
		}}
	}
	
	# 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.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)}

	unset type index fail_type debug idx
}

global MVS tcl_interactive

# Basic configuration 
if !$tcl_interactive {
	# Find the home directory of the server
	set app "$argv0"
	catch {set app [file readlink $app]}
	set MVS(homedir) "[file dirname $app]"
	if {$argv != ""} {
		set MVS(configfile) "$MVS(homedir)/$argv"
	} else {
		set MVS(configfile) ""
	}
	unset app
	set MVS(standalone) 1
} else {
	# Defaults
	set MVS(homedir) "$homedir"
	set MVS(configfile) "$MVS(homedir)/pserver.cfg"
	set MVS(standalone) 0
}

# Default to no colors
ColorSwitch 0

# Read configuration file
ReloadConfig

# Arrange to have configuration reloaded on tickle
lappend MVS(init.tickle.hooks) "ReloadConfig"

# Load the plugins
LoadPlugins

# One-time startup stuff for plugins
Initialize

# Wait until the server crashes or is stopped.
if $MVS(standalone) {vwait MVS(waiter)}