#!/usr/local/bin/perl

# webqstat.cgi by David Efflandt (efflandt@xnet.com)
# 10/10/97 - Last modified 1/28/99
#
# Displays status of a QuakeWorld or Q2 server in HTML table format.
# Includes team totals and players sorted by frags.
# Should work with any browser that supports tables (no plugin req'd).
# It even displays in lynx.  Suitable for use as server side include.
# Script tested on Linux and Solaris.
#
# Requires qstat 2.0b or newer by Steve Jankowski (steve@activesw.com)
# available as UNIX source and compiled Win32 versions.
# http://www.activesw.com/people/steve/qstat.html
# ftp://ftp.activesw.com/pub/quake

### User Variables ###

# Comment out following line if it displays in an SSI
print "Content-type: text/html\n\n";

# Example to work with different paths depending upon hostname
$hostname = `hostname`;
if ($hostname =~ /efflandt/) {
  $qstat = '/usr/local/games/quake2/qstat';
} else {
  $qstat = '/home/hurricane/efflandt/src/qstat/qstat';
}
# Or comment out the above and use actual path to your qstat:
# $qstat = '/full_path_to/qstat';

# Your town or nearest major city (for time zone)
$city = 'Chicago';

# Display rules? 0 = no, 1 = yes
$rules = 1;

# For standalone CGI, a non-default server can be poled by following
# URL of script with either "?" or "/" and then "server[:port]".
# "server" can be IP or hostname.
#
# Example:	webqstat.cgi?198.147.221.120:27910
#
# For SSI the following could be edited to add servers by linking
# this script to alternative names with dash and option and parsing
# the name for options.  For example webqstat.cgi for one server and
# webqstat-dm.cgi for another.

# Get arguments from program name.
$arg = $0;
$arg =~ s/(\.cgi|\.pl)//;	#strip .cgi|.pl name extension
$arg =~ s!^(.*-)!!;		# chop program name

# Other possible sources of options
$arg = $ARGV[0] if $ARGV[0];
$arg = $ENV{'PATH_INFO'} if $ENV{'PATH_INFO'};
$arg =~ s!/!!;	# strip leading / from path info
$arg = $ENV{'QUERY_STRING'} if $ENV{'QUERY_STRING'};

# Hostname or IP address of server.
# :port required if not QW default (:27500)
if ($arg =~ /^\w+[\.\:]+/) {	# specific server[:port]
  $arg =~ /([\w\.\:]+)/;
  $server = $1

} elsif ($arg eq 'dm') {	# sample option
  $server = '198.147.221.120';	# QW

} else {	# default
  $server = '198.147.221.120:27910';	# Q2
}

# Edit switches only for non-QW/Q2 server
$buffer = `$qstat -R -P -cn -raw "|,|" -qws $server`;

### Uncomment to test table vs. raw & formatted data
# print "<PRE>$buffer</PRE><P>\n";
# $test = `$qstat -P -qws $server`;
# print "<PRE>$test</PRE><P>\n";

### End of User Variables ###

# Browser safe colors
%rgb = (
  White		=> 'FFFFFF',
  Brown		=> 'CC9966',
  Lavender	=> '9966FF',
  Khaki		=> 'CCCC99',
  Red		=> 'FF0000',
  'Lt Brown'	=> 'FFCC99',
  Peach		=> 'FFCC00',
  'Lt Peach'	=> 'FFCCCC',
  Purple	=> 'CC66FF',
  'Dk Purple'	=> 'FF99FF',
  Tan		=> 'FFFFCC',
  Green		=> '00CC99',
  Yellow	=> 'FFFF00',
  Blue		=> '0000FF'
);

# Begin html table with main server data
@lines = split("\n", $buffer);
$_ = shift @lines;
($type,$addr,$server,$map,$max,$players,$response,$retry) = 
  split /\|,\|/, $_; 
$now = scalar localtime();
$response .= "ms";
$map = "none" unless $map;

# Get rules
$rulelist = shift @lines;
if ($type eq "Q2") {
  @rules = split /\|,\|/, $rulelist;
  while ($_ = shift @rules) {
    ($key, $value) = split /=/, $_;
    if ($key =~ /version/i) { $qver = "$value<BR>\n"; }
  }
}

print <<EOF;
<P><CENTER><TABLE BORDER=1 CELLPADDING=3 CELLSPACING=2>
<TR><TH COLSPAN=5 BGCOLOR="#000000"><FONT COLOR="#ffffff">$server
<BR>$qver$city Time: $now</FONT></TH></TR>
<TR><TH>ADDRESS<TH>PLAYERS<TH>MAP<TH COLSPAN=2>RESPONSE
<TR ALIGN=CENTER><TD>$addr<TD>$players / $max
<TD>$map<TD COLSPAN=2>$response / $retry</TD></TR>
EOF

# Organize player data if any
if (@lines) {
  while ($_ = shift @lines) {
    if ($type eq "Q2") {
      ($name,$frags,$ping) = split /\|,\|/, $_;
    } else {
      ($id,$name,$frags,$time,$shirt,$pants,$ping,$skin) =
        split /\|,\|/, $_;
    }
    $name =~ s/[<]/&lt\;/g;
    $name =~ s/[>]/&gt\;/g;
    $name = "noname$nn++" unless $name =~ /[\w]/;
    push @namelist, $name;
    $frags{$pants} += $frags;
    if ($ping < 2000) {
      $ping{$pants} += $ping;
      $pingn{$pants}++;
    }
    $count{$pants}++;
    ++$i;
    %new_folks = (
      frags	=> $frags,
      time	=> $time,
      shirt	=> $shirt,
      pants	=> $pants,
      ping	=> $ping,
      skin	=> $skin
    );
    for $what (keys %new_folks) {
      $player{$name}{$what} = $new_folks{$what};
    }
  }

  # Display team totals if more than one player per team
  $teams = keys %count;
  if ($rule{teamplay} && $players > $teams) {
    print "<TR><TD COLSPAN=5>\n";
    print "<TR><TH>TEAMS<TH>FRAGS<TH>AVE PING<TH COLSPAN=2>COLOR\n";
    sub frags {$frags{$b} <=> $frags{$a};}
    foreach $team (sort frags keys %count) {
      $ping = int $ping{$team}/$pingn{$team};
      $ping .= "ms ave";
      print qq(<TR ALIGN=CENTER><TD><FONT COLOR="\#$rgb{$team}">);
      print qq($count{$team} PLAYERS<TD>$frags{$team}\n);
      print qq(<TD>$ping<TD COLSPAN=2 BGCOLOR="\#$rgb{$team}">);
      print qq(<FONT COLOR="\#$rgb{$team}">$team</FONT>\n);
    }  
  }
  # Display players if any
  print "<TR><TD COLSPAN=5>\n";
  if ($type eq "Q2") {
    print "<TR><TH COLSPAN=2>NAME<TH>FRAGS<TH COLSPAN=2>PING\n";
  } else {
    print "<TR><TH>NAME<TH>FRAGS<TH>TIME";
    print "<TH>SKIN<TH>COLOR\n";
  }

  sub byfrag {$player{$b}{frags} <=> $player{$a}{frags};}
  foreach $name (sort byfrag @namelist) {
    $frags = $player{$name}{frags};
    $time = $player{$name}{time};
    if ($time) {
      $time = $time/60 . "m\@";
    } else {
      $time = "";
    }
    $shirt = $player{$name}{shirt};
    $shirtrgb = $rgb{$shirt};
    $pants = $player{$name}{pants};
    $pantsrgb = $rgb{$pants};
    $ping = $player{$name}{ping};
    if ($ping > 0) {
      $ping .= "ms";
    } else {
      $ping = "cl_nodelta";
    }
    $skin = $player{$name}{skin};
    $skin = "?" unless $skin;
    if ($type eq "Q2") {
      print "<TR ALIGN=CENTER><TD COLSPAN=2>$name<TD>$frags"
        . "<TD COLSPAN=2>$ping\n";
    } else {
      print "<TR ALIGN=CENTER><TD ROWSPAN=2>$name<TD ROWSPAN=2>$frags"
        . "<TD ROWSPAN=2>$time$ping<TD ROWSPAN=2>$skin";
      print qq(<TD BGCOLOR="\#$shirtrgb">);
      print qq(<FONT SIZE=1 COLOR="\#$shirtrgb">$shirt</FONT>);
      print qq(<TR ALIGN=CENTER><TD BGCOLOR="\#$pantsrgb">);
      print qq(<FONT SIZE=1 COLOR="\#$pantsrgb">$pants</FONT></TD>\n);
    }
  }
}
print "</TABLE></CENTER><P>\n";

# Display rule table (optional, see Variables above)
if ($rules) {
  print "<p><center><TABLE BORDER=0 CELLPADDING=3 CELLSPACING=2>";
  print "<tr><td>&nbsp;</td></tr></table></center>\n";

  print "<P><CENTER><TABLE BORDER=1 CELLPADDING=3 CELLSPACING=2>";
  print qq(<TR><TH COLSPAN=2 BGCOLOR="#000000">
    <FONT COLOR="#ffffff">$server</FONT>\n);
  print "<TR><TH>RULE<TH>VALUE\n";
  @rules = split /\|,\|/, $rulelist;
  while ($_ = shift @rules) {
    ($key, $value) = split /=/, $_;
    print "<TR><TD ALIGN=CENTER>$key<TD>$value\n";
  }
  print "</TABLE></CENTER><P>\n";
}