From: jiangwu@sickdog.CS.Berkeley.EDU (Jiang Wu)
Subject: METASERVER tk/tcl interface
Summary: A Tk interface to the METASERVER
Keywords: METASERVER
Organization: University of California, Berkeley
Date: Thu, 23 Jul 1992 21:36:37 GMT


A few days ago, Sam Shen (sls@aero.org) submitted a simple (under 200
lines!) Tk/Tcl script that displays the output of the METASERVER program in
a neat little window with 3 listboxes, a couple scrollbars, and several
buttons.  But you need the tclRawTCP extension to run the script.  I
modified his script so that you don't need the tclRawTCP extension to run
the program any more.

You can obtain Tk/Tcl via ftp anonymous from sprite.berkeley.edu in /tcl
directory.

-- R. Daneel

----------- cut here -----------------------------------
#!/private/bin/wish -f
#

# Thu Jul 23, 2:06 p.m. PDT 1992
# 
# This script is modified so that you can use it WITHOUT the
# tclRawTCP extension.  You can obtain tk2.1/tcl6.3 via ftp from
# sprite.berkeley.edu.
#
# 		- Jiang Wu (jiangwu@postgres.berkeley.edu)
#


# This Tk program displays the output of the METASERVER program.
# If you double click on the server name a netrek will be started for
# that server.
#
# You will need tk2.1 plus the tclRawTCP extension.  Both packages
# can be found on barkley.berkeley.edu in /tcl directory.  A binary
# for SunOS 4.1 sparcs can be ftp'ed from
# soda.berkeley.edu:/pub/incoming/wish+tclRawTCP.sun4, at least
# for now.
#
# Go ahead and do anything you want with this code.
#
#                     -Sam Shen (sls@aero.org)
#
# $Id: netrekmon.tk,v 1.1 1992/07/14 02:24:22 sls Exp $
#
# $Log: netrekmon.tk,v $
# Revision 1.1  1992/07/14  02:24:22  sls
# Initial revision
#

# Where is the temp directory?
set tmpDir /tmp

# Where is metaserver running?
set server sickdog.cs.berkeley.edu
set port 2520

# Where can I find the netrek executable?
set netrek /private/bin/udptrek

# For servers that lie about what host address to use.  Calvin is
# the only one I know that needs this.
set addressMap(calvin.usc.edu) 128.125.62.143

# Beyond here you shouldn't need to modify anthing.

option add borderwidth 2 interactive

label .info -text "METASERVER @ $server, port $port"
wm minsize . 100 100
wm title . "METASERVER Tk2.1 Interface"

pack append . .info "fill expand"

label .time -relief sunken
pack append . .time "fill expand"

frame .buttons -borderwidth 6
button .buttons.update -text "Update" -command UpdateList
button .buttons.quit -text "Quit" -command exit
pack append .buttons .buttons.update "left fill expand" .buttons.quit "left fill expand"
pack append . .buttons "fill expand"

label .status -width 40 -relief sunken
pack append . .status "fill expand"

proc TripleListView {name args} {
    eval "$name.column1.list yview $args"
    eval "$name.column2.list yview $args"
    eval "$name.column3.list yview $args"
}

proc CreateColumn {name yscroll title geometry} {
	frame $name
	label $name.label -text $title -relief raised
	listbox $name.list -yscroll $yscroll -relief raised -geometry $geometry
	pack append $name $name.label "top fill expand" \
		$name.list "bottom fill expand"
}

proc CreateTripleList {name title1 title2 title3} {
    	frame $name -borderwidth 6
	frame $name.column4
	label $name.column4.filler -text ""
    	scrollbar $name.column4.scroll -command "TripleListView $name"
	pack append $name.column4 $name.column4.filler "top fillx" \
		$name.column4.scroll "bottom expand fill"
	CreateColumn $name.column1 "$name.column4.scroll set" $title1 30x20
	CreateColumn $name.column2 "$name.column4.scroll set" $title2 12x20
	CreateColumn $name.column3 "$name.column4.scroll set" $title3 10x20
    	pack append $name $name.column4 "right filly" \
		$name.column1 "left expand fill" \
		$name.column2 "left expand fill" \
		$name.column3 "left expand fill"
}

CreateTripleList .servers "Servers" "Status" "Time"
bind .servers.column1.list <Double-1> \
	{StartNetrek [.servers.column1.list get \
			[.servers.column1.list nearest %y]]}
pack append . .servers "fill expand"

proc getline {fileid} {
	set glresult ""
	for {set tempC [read $fileid 1]} \
	    {($tempC != "") && ($tempC != "\n")} \
	    {set tempC [read $fileid 1]} {
	    append glresult $tempC
	}
	return $glresult
}

proc UpdateList {} {
    	global n server port tmpDir
	.status config -text "Connecting to $server..."
	update
	catch "exec telnet $server $port > $tmpDir/.serverList"
	set of [open $tmpDir/.serverList]

	set readingServers 0
	set n 0
	.servers.column1.list delete 0 end
	.servers.column2.list delete 0 end
	.servers.column3.list delete 0 end	

	while {[eof $of] == 0} {
		set line [getline $of]
    		if {[string first "Server Check period:" $line] == 0} {
			set readingServers 1
			continue
    		}
    		if {$readingServers == 0} {
			continue
	    	}
    		if {[string trim $line] == ""} {
			set readingServers 0
			continue
    		}
    		set splitline [split $line ":"]
    		.servers.column1.list insert end \
			[string trim [lindex $splitline 0]]
		.servers.column2.list insert end \
			[ParsePlayers [string trim [lindex $splitline 1]]]
		.servers.column3.list insert end \
			[lindex $line [expr {[llength $line]-1}]]
    		incr n
	}
	close $of
	exec rm -f $tmpDir/.serverList

	.status config -text "Read $n servers."
	.time config -text "Last update at: [exec date]"
}

proc ParsePlayers {players} {
	if {[string first "Wait Queue" $players] == 0} {
		return "wait queue: [lindex $players 2]"
	}
	if {[string first "Couldn't connect" $players] == 0} {
		return "down"
	}
	return "players: [lindex $players 0]"
}

proc StartNetrek {server} {
	global netrek addressMap
	set tmp [split $server "()"]
	set server [lindex $tmp 0]
	set port [lindex $tmp 1]
	if {[info exists addressMap($server)] == 1} {
		set server $addressMap($server)
	}
	.status config -text "Starting: $netrek -h $server -p $port"
	exec $netrek -h $server -p $port &
}