# TCL TinyTalk routines, the ones written in TCL. Only doargs and
# exception are truly essential, but the others are handy.

# Handle exceptions. Suspend ourselves; be nice on network shutdowns,
# and just barf otherwise.
proc exception {signame} {
	global logfile_status logfile_file errorInfo system_name

	case $signame in sigtstp {
		# Before suspending, close the logfile.
		if {$logfile_status} { logclose }
		suspend
		if {$logfile_status} { logopen $logfile_file }
	} networkeof {
		lineout disconnected from remote machine
		if {$logfile_status} { logclose; logopen $logfile_file }
		if {[length $system_name] > 0} {
			lineout attempting a reconnect
			reconnect $system_name
		}
	} lineinputerror {
		lineout TCL Error: $errorInfo
	} match {
		lineout match TCL Error: $errorInfo
	} sigint {
		# Allow us to quickly close down patternmatching, or
		# exit if that's already been done. 
		if {![matchstatus 0]} {
			if {$logfile_status} { logclose }
			closedown user interrupt
		} { lineout Matches stopped }
	} default {
		if {$logfile_status} { logclose }
		closedown got exception $signame
	}
}

# Action classes
global gag_class hilite_class
set gag_class 2
set hilite_class 3

# Hilite and gag things. We can do them either on regexp patterns or
# people; reg<thing> does regexps, <thing> does people. There is no
# noreg<thing>, since the user can just use removematch action.
# Remember to escape any special characters in the name of people. It
# is not strictly true that the name given to /hilite or /gag must be
# a person; it can actually be a limited regexp that will be wrapped
# in a larger one. The "person" will only match in circumstances where
# you'd find a name.
# I should also note that regexps, and thus /hilites & /gags, are case
# sensitive, unlike in TinyTalk.

# Given a name, generate the pattern that will match anything they
# emit or appear as, regardless of trailing spaces.
# BUGS: Doesn't work if you see a trailing object number for them on a
#       look (wizards/tinkers see it in TinyMUDs; anyone sees it in
#       MUCK if they're LINK_OK).
proc matchname {name} {
	return [format "^%s( |\n$)" $name]
}

proc hilite {who} {
	global hilite_class
	addmatch 0 [matchname $who] {set hilite_line 1} $hilite_class
}
proc reghilite {re} {
	global hilite_class
	addmatch 0 $re {set hilite_line 1} $hilite_class
}
proc nohilite {who} {
	removematch action [matchname $who]
}
# This can be dangerous to your health with lots of hilites.
proc listhilites {} {
	global hilite_class
	listmatch $hilite_class
}
# This is gross. It does an infinite loop that removes the first
# hilite each time; when there aren't any left, removematch will fail
# with an error, which propagates up through the for until it's
# stopped by the catch. Fun for the whole family, eh?
proc purgehilites {} {
	global hilite_class
	catch {for {} {1} {} {removematch class $hilite_class}}
}
proc gag {who} {
	global gag_class
	addmatch 0 [matchname $who] {set drop_line 1} $gag_class
}
proc reggag {re} {
	global gag_class
	addmatch 0 $re {set drop_line 1} $gag_class
}
proc nogag {who} {
	removematch action [matchname $who]
}
proc listgags {} {
	global gag_class
	listmatch $gag_class
}
# see the purgehilites comment.
proc purgegags {} {
	global gag_class
	catch {for {} {1} {} {removematch class $gag_class}}
}

# Add a world to our list of known worlds
# Takes the name, the host, the port number, and a command to invoke
# when a connection is successfully made.
set world_list " "
proc addworld {what host port cmd} {
	global world_list
	set world_list [concat $world_list [list $what $host $port $cmd]]
}
	
# Open up a connection to a world in the world list and invoke the
# startup command once we've connected.
proc initconnection {which} {
	global world_list passwd world character

	set world [index $world_list $which]
	set host [index $world_list [expr $which+1]]
	set port [index $world_list [expr $which+2]]
	set command [index $world_list [expr $which+3]]
	if {![openconnection $host $port]} {
		closedown failed to open connection with $host
	} {
		# Better get that login command right!
		eval $command
	}
}

# world WORLD; change to the indicated WORLD.
proc world {world} {
	global world_list system_name

	set which [searchlist $world_list $world 4]
	if {$which == -1} {
		lineout There is no world called $world defined.
	} {
		# Okey dokey, change worlds. We change the obvious way.
		closeconnection
		set system_name $world
		initconnection $which
	}
}

# Attempt to reconnect to our world, when we're disconnected.
proc reconnect {arg} {
	global world_list
	case [length $arg] in 1 {
		# A world name
		set which [searchlist $world_list [index $arg 0] 4]
		initconnection $which
	} 2 {
		# host/port
		if {![openconnection [index $arg 0] [index $arg 1]]} {
			closedown failed to connect to [index $arg 0]
		}
	} 0 {
		echo No world to reconnect to: exiting
	} default {
		lineout I don't understand $arg
	}
}

# Quit, for real. Closes the connection.
proc quit {} {
	global system_name
	lineout Exiting from $system_name
	set system_name ""
	closeconnection
}
# A quit (nicer) specifically for MUDs.
proc mudquit {} {global system_name; set system_name ""; send "QUIT"}

global system_name
set system_name ""

# Parse our arguments and go for it.
# No arguments means connect to the default world; one arguments means
# connect to that world; two arguments means connect to the host/port
# combination specified as the two arguments.
proc doargs {args} {
	global world_list logfile_status logfile_file system_name

	# We must open the logfile here to catch initial pre-login
	# messages.
	if {$logfile_status} { logopen $logfile_file }

	case [length $args] in 1 {
		# Connect to the default.
		if {[length $world_list] == 0} {
			closedown No default world
		}
		set system_name [index $world_list 0]
		initconnection 0
	} 2 {
		set which [searchlist $world_list [index $args 1] 4]
		if {$which == -1} {
			closedown No world called [index $args 1]
		}
		set system_name [index $args 1]
		initconnection $which
	} 3 {
		# A whole new world! Whee!
		set system_name [list [index $args 1] [index $args 2]]
		if {![openconnection [index $args 1] [index $args 2]]} {
			closedown failed to connect to [index $args 1]
		}
	} default {
		echo {usage: tcltt [world] | [host port]}
		closedown bad arguments
	}
}

# A nice utility routine. In order to make it nice and fuzzily
# user-friendly, it strips the first level of quoting, so you can say
# things like sendf "@teleport me =" $somewhere.
proc sendf {args} {
	eval [format "send \[concat %s\]" $args]
}

# Repeat a TCL command N times.
proc repeat {count cmd} {
	for {set i 0} {$i < $count} {set i [expr $i+1]} {
		eval $cmd
	}
}

# Cyberportal support, primarily for UnterMUD
proc armcyber {} {
	global cyberport
	set cyberport [addmatch -10 {^#### Please reconnect to ([^@]+)@([^ ]+) \(([^)]+)\) port ([0-9]+) ####.$} {unterreconnect}]
}
proc nobamf {} {global cyberport; removematch id $cyberport}

proc unterreconnect {} {
	global myname passwd unterhost unterport system_name mudname
	global drop_line

	set unterhost [matchsub 3]
	set unterport [matchsub 4]

	# Bail out of current MUD.
	send "QUIT"
	lineout "Transferring to" [matchsub 1]
	closeconnection

	if {![openconnection $unterhost $unterport]} {
		set unterhost [matchsub 2]
		if {![openconnection $unterhost $unterport]} {
			# OOPS! Do autoreconnect to old MUD? Best we can do.
			if {[length $system_name] > 0} {
				lineout attempting a reconnect
				reconnect $system_name
			}
			return
		}
	}

	# Go for autologin
	send [format "c %s %s" $myname $passwd]
	set system_name [list $unterhost $unterport]
	set drop_line 1
}

proc getunter {mudname myname} {
	return [exec sh -c [format "cat $HOME/.%s.%s" $mudname $myname]]
}
proc setunter {host port mudname myname} {
	exec sh -c [format "echo %s %s > $HOME/.%s.%s" $host $port $mudname $myname]
}