#!/usr/bin/perl

# quickspy2  by David Efflandt  efflandt@xnet.com
# http://www.xnet.com/~efflandt/
# Created 1/11/98, released 2/5/98
#
# Menu driven Linux console Q2 status (web or file list) and launch.
# Forks FIFO's instead of files for tmp data.
# Rename without '.pl' extension or call it what you want.
#
# 1/18/99 fixed sh error when data contains backtick.
# Also fixed to enable lists from virtual hosts.
# 3/15/98 added high ping error check and alternate $maxping2.
# 2/26/98 added idsoftware list and parsing.
# 2/22/98 added multiple config menu (DM, CTF, etc.).
# 2/18/98 for status meter troubles, see $gage variable below.
# 2/14/98 RedHat 4.2 testing (minor display fix).
# 2/10/98 updated for Solaris and other shells.
# 2/8/98 updated 'guage' vs. 'gauge' in different dialog versions.
# Originally tested on Slackware 3.3 with Linux kernel 2.0.33
# Currently running on RedHat 5.2
#
# Requires:
#
# 'dialog' for console displays (may be standard on Linux and similar
# systems). May not work well in X (X specific programs are available).
#
# 'qstat 2.0b' or newer by Steve Jankowski (steve@activesw.com)
# available as source (Linux, Solaris, etc.) and Win32 binaries.
# http://www.activesw.com/people/steve/qstat.html
# ftp://ftp.activesw.com/pub/quake
#
# Note: Status meter may pause at 100% to recheck timeout servers.

use Cwd;
use English;
use Socket;

### User Variables ###
#
# Full path suggested if using multiple directories

# Set $gage = 1; to try dialog guage instead of text status.
# If that doesn't work, set $gage = 0; (zero) for text status.
# Debian dialog 0.9a (cdialog) --guage fails to close (try Ctrl-C).
# Use $gage = 0; on RedHat 5.x (broken pipe).
$gage = 0;	# 1 = yes, 0 = no gage (text status)

# Name including path (if req'd) of qstat 2.0b or newer
$qstat = './qstat';

# Dir for Q2 or launch script
$q2dir = '/usr/local/games/quake2';

# Q2 commands or scripts for different configurations (DM, CTF, etc.).
# Menu selection if more than one item (comma separated list).
@runq2 = (
	'./runq2',
	'./runctf2',
);

# If using launch script, make sure command line in that script includes 
# $@ or $* or whatever shell requires to pass on parameters from here.

$maxs = 10;				# simultanious server contacts
$maxping = 500;				# for menu and saved lists
$maxping2 = 999;			# only if none < $maxping
$lplist = 'q2quicklp.dat'; 		# low ping list for next time
$savelist = 'q2quick.dat';		# all unique resolved servers
$timeout = 6;				# IP resolving (seconds)
$q2port = ':27910';			# default server port if none
$withq2 = 1;				# 1 = 'Q2 '. | 0 = .":port'

$qstatin = "/tmp/qstatin.$$";		# tmp pipe for qstat input
$qstatout = "/tmp/qstatout.$$";		# tmp pipe for qstat output

# Q2 server sources (E-mail author if any list does not work)
@sources = (
	'Saved quick low ping list',
	'Saved full list of last source',
	'File Menu',
	'Refresh from all sources below',
	# Add any http sources below (comma separated):
	# 'http://inferno.idsoftware.com/q2servers/',
	'http://asp.planetquake.com/q2servers/q2gamespy.txt',
	'http://www.aphrodisiac.net/quake2/',
	'http://www.gameaholic.com/servers/qspy-quake2',
	'http://www.telefragged.com/server_listing/quake2/',
);

# Optional output files for testing
$saveraw = 0;				# yes = 1, no = 0
$rawout = 'q2raw.txt';			# raw qstat ouput for testing
# $outfile = 'q2now.txt';		# uncomment for formatted list

### End User Variables ###

die "Cannot execute: $qstat\n" unless -x $qstat; 

# Dialog guage or gauge?
if ($gage) {
  $in = `dialog 2>&1`;
  if ($in =~ /guage/) {
    $gage = '--guage';
  } elsif ($in =~ /gauge/) {
    $gage = '--gauge';
  } elsif ($in =~ /version/) {
    $gage = 0;
  } else {
    die "'dialog' does not appear to be in your path\n";
  }
}

# Screen & menu size
if(($_ = `stty`) =~ /rows\s+=\s+(\d+);.*columns\s+=\s+(\d+);/) {
  ($rows,$cols) = ($1,$2);
} elsif (($_ = `stty size`) =~ /^(\d+)\s+(\d+)/) {
  ($rows,$cols) = ($1,$2);
} else {
  $rows = $ENV{LINES} if $ENV{LINES};
  $cols = $ENV{COLUMNS} if $ENV{COLUMNS};
}
$rows = 25 unless $rows;
$mrows = $rows - 7;
$cols = 80 unless $cols;

$newlist = $savelp = 1;
while ($_ = $ARGV[0], /^-/) {		# command line switches?
  shift;
  last if /^--$/;
  if (/^-(l|1)/i) { push @ARGV, $lplist; $newlist = $savelp = 0; }
  if (/^-f/i) { push @ARGV, $savelist; $newlist = 0; }
  if (/^-(h|\?)/i) {
    die <<EOF;

	Usage:		$0 [option] | [filelist] ...
			(source menu if no options or files)

	Options:	-h or -? = this help
			-l = use low ping list from last time
			-f = use last full resolved list

EOF
  }
}

if ($ARGV[0]) {			# any files on command line?
  @slist = <>;
  &mainmenu();			# skip source menu
}

until ($?) {	# source menu
  $box = 'dialog --title "Server Source List" '
    . qq(--backtitle "Quickspy2" --menu "Select one" 19 68 12 );

  $i = 0;
  foreach $source (@sources) {
    $box .= qq("$i"  "$source" );
    $i++;
  }

  $newlist = $savelp = 1;
  $in = `$box 3>&1 1>&2 2>&3 3>&-`;
  unless ($?) { # non-zero on Cancel or error
    @slist = ();
    if (!$in) {
      $savelp = 0;
      @slist = &getfile($lplist);
    } elsif ($in eq 1) {
      @slist = &getfile($savelist);
    } elsif ($in eq 2) {
      @slist = &filemenu();
    } elsif ($in eq 3) {
      my $i = $in;
      my $j = @sources;
      print "\n";
      until ($i eq $j - 1) {
        print "Getting list $sources[++$i]\n";
        push @slist, &wwwgrab($sources[$i]);
      }
    } else {
      print "\nGetting list $sources[$in]\n";
      @slist = &wwwgrab($sources[$in]); 
    }
    &mainmenu() if @slist;
  }
}
print "\n";	# clean line for prompt
print "Error code: $?\n" if $? ne 256;
print "Raw qstat data is in $rawout\n" if $saveraw;
print "Server list is in $outfile\n" if $outfile;
print "Low ping source list saved as $lplist\n";
print "Last full resolved list saved as $savelist\n" if $newlist;
exit;

sub getfile {
  my ($file) = @_;
  my @data;
  open(IN, $file) or warn "Can't open list $file: $!\n";
  @data = <IN>;
  close IN;
  if ($file eq $savelist || $file eq $lplist) { 
    $newlist = 0;
  } else {
    $newlist = 1;
  }
  @data;
}

sub wwwgrab {
#########################################################
#       sub wwwgrab based on modified 'wwwgrab' by      #
#       Jeff Ballard (ballard@cae.wisc.edu) 7/2/95      #
#       URL:  http://www.engr.wisc.edu/~ballard/        #
#########################################################
  my @data;
  ($_) = @_;
  /http:\/\/([^\/]*)\/*([^ ]*)/;
  my $site = $1;
  my $file = "/".$2;

  unless ($site) {
    warn "Munged URL address.
        It must be in the form of http://www.any.site/location\n";
  }
   
  $site =~ /^([^:]*):*([^ ]*)/;
  my $host = $1;
  my $port = $2;
  $port = 80 unless $port;

  # Open a socket and get the data
  my ($sockaddr,$there,$response,$tries) = ("Snc4x8");
  $there = pack($sockaddr,2,$port, &getaddress($host));
  my $proto = (getprotobyname ('tcp'))[2];
  if (!socket(S,AF_INET,SOCK_STREAM,$proto))
    { warn "socket error: $!\n"; return; }
  if (!connect(S,$there))
    { warn "connect error: $!\n"; return; }
  select S; $| = 1;
  select STDOUT; $| = 1;
  print S "GET $file\n";
  print S 'Host: ' . "$host\n\n";
  while (<S>) {
    s/[`]/[']/;
    push @data, $_;
  }
  close S;
  @data;
}

sub getaddress {
  my ($host) = @_;
  my (@ary);
  @ary = gethostbyname($host);
  return(unpack("C4",$ary[4]));
}

sub filemenu {
  my ($i, $dir, $file, $in, @files);
  until ($?) {			# Cancel or error
    $dir = cwd();
    opendir DIR, "$dir" or die "directory error: $!\n";
    @files = sort readdir DIR;
    close DIR;

    $box = 'dialog --title "Select a server source list" '
      . qq(--backtitle "Quickspy2" --menu "$dir" 19 46 12 );

    while (shift @files) {	# prune '.'
      last if '.';
      push @files, $_;
    }
    $i = 0;
    foreach $file (@files) {
      $box .= qq("$i"  "$file" );
      $i++;
    }

  # Display file menu and get file# from stderr
    $in = `$box 3>&1 1>&2 2>&3 3>&-`;
    if ($?) {	# non-zero on Cancel or error
      $? = 0 if $? eq 256;
      return;
    } else {   
      if (-d $files[$in]) {
        chdir $files[$in];
      } else {
        unless (-s $files[$in]) {
          print "\nFile $files[$in] is empty.  Try another.\n";
          sleep 4;
          next;
        }
        return &getfile($files[$in]);
      }
    }
  }
}

sub mainmenu {
  @fifo = ();
  my $lines = @slist;
  my $line = 0;
  my $percent;

  if ($newlist) {
    if ($gage) {
      $meter = 'dialog --title "Resolving Hostnames" '
        . qq(--backtitle "Quickspy2" $gage " Please wait..." 7 58 0);
      open(METER, "| $meter") or die "Can't open $meter: $!\n";
      select METER; $| = 1;
    } else {
      print "\nResolving Hostnames\n";
    }
    while (@slist) {
      $in = shift @slist;
      $percent = int ((++$line) * 100 /$lines);
      # Parse and format for qstat
      $port = '';
      if ($in =~ /^Q2\s*([\w-]+\.[\w-.]+)(\:?\d*)[^\w-.]/i) {
        $addr = $1; $port = $2 if $2;
      } elsif ($in =~ /^\s*([\w-]+\.[\w-.]+)(\:?\d*)[^\w-.]/) {
        $addr = $1; $port = $2 if $2;
      } elsif ($in =~ /\>\s*([\w-]+\.[\w-.]+)(\:?\d*)[^\w-.]/i) {
        $addr = $1; $port = $2 if $2;
        next if $addr =~ /^\d+\.\d+$/;
      } else {
        next;
      }
      $addr =~ s/\.+$//;	# fix trailing '.' typo

      # Hostname to IP (timeout for fakes)
      unless ($addr =~ /^\d+\.\d+\.\d+\.\d+/) {
        if ($gage) {
          print "XXX\n$percent\n$addr\nXXX\n";
        } else {
          print "resolving: $addr\n";
        }
        eval {
          local $SIG{ALRM} = sub { die "get IP timed out"; };
          alarm $timeout;
          $addr = gethostbyname $addr;
          alarm 0;
        };
        next if $@;		# timed out
        next unless $addr;	# no IP
        ($a, $b, $c, $d) = unpack('C4', $addr);
        $addr = qq($a.$b.$c.$d);
      }

      if ($withq2) {	# format for saved quick lists
        $port = '' if $port eq $q2port;
        push @fifo, "Q2 $addr$port\n";
      } else {
        $port = $q2port unless $port;
        push @fifo, "$addr$port\n";
      }
    }
    close METER;
    select STDOUT; $| = 1;

    # No duplicates
    undef %saw;
    @saw{@fifo} = ();
    @fifo = keys %saw;

    # Save new full resolved list
    if (@fifo) {
      open(OUT, ">$savelist") or die "Can't open $savelist: $!\n";
      print OUT @fifo;
      close OUT;
    }
  } else {
    @fifo = @slist;
  }

  unless (@fifo) {
    print "\nInvalid or empty server list.  Try another.\n";
    sleep 4;
    $? = 0;
    return;
  }

  # FIFO to feed qstat
  unless (-p $qstatin) {
    unlink $qstatin;
    system('mknod', $qstatin, 'p') && die "Can't mknod $qstatin: $!\n";
  }

  # Fork to feed qstat filtered input
  unless ($fork = fork) {	# we are the fork
    open(FIFO, ">$qstatin") or die "Can't write $qstatin: $!\n";
    select FIFO; $| = 1;    
    print @fifo;
    close FIFO;
    select STDOUT; $| = 1;
    exit 0;
  }

  # FIFO for qstat stdout
  unless (-p $qstatout) {
    unlink $qstatout;
    system('mknod', $qstatout, 'p') && die "Can't mknod $qstatout: $!\n";
  }

  my $sleep_count = 0;

  do {	  # Spawn child to trap qstat stdout
    $pid = open(KID_TO_READ, "-|");
    unless (defined $pid) {
      warn "cannot fork: $!";
      die "bailing out" if $sleep_count++ > 6;
      sleep 10;
    }
  } until defined $pid;

  unless ($pid) {	# we are the child
    $| = 1;
    @fifo = ();
    open(FIFO, "<$qstatout") or die "Can't read $qstatout; $!\n";
    while (<FIFO>) {
      s/[`]/[']/;
      push @fifo, $_;
    }
    close FIFO;
    print @fifo;	# to parent
    exit 0;
  } 

  # Get server data
  $in =
    qq($qstat -progress -u -raw "-,-" -maxsimultaneous $maxs -f $qstatin);

  $meter = 'dialog --title "Contacting Servers" --backtitle "Quickspy2" '
    . "$gage" . ' "  For quicker response next time use -l switch for\n'
    . '  low ping list or -f switch for current full list" 7 58 0';

  # Run qstat and progress guage
  open(IN, "$in 3>&1 1>$qstatout 2>&3 3>&- |")
    or die "Can't open $in: $!\n";

  if ($gage) {
    open(METER, "| $meter") or die "Can't open $meter: $!\n";
    select METER;
  } else {
    print "\nTry '$0 -l' for low ping list\n";
    print "or -f switch for previous full list\n";
    print "\nContacting Servers\n";
  }

  # Progress from qstat
  $percent = 0;
  $| = 1;
  $/ = "\r";			# eol of single line status
  while (<IN>) {		# from qstat
    $line = $_;
    if ($gage) {
      if ($line =~ /^(\d+)\/(\d+) /) {
        $percent = int ($1 * 100 / $2) if $2;
        $percent = "XXX\n100\nRetrying some\nXXX" if $percent > 100;
        print "$percent\n";	# to guage
      }
    } else {
      print "$line";
    }
  }
  $/ = "\n";
  select STDOUT; $| = 1;
  waitpid ($fork, 0);		# clean up $qstatin fork
  close IN;
  close METER;
  unlink $qstatin;

  # Get qstat output from child
  @lines = ();
  while (<KID_TO_READ>) {
    push @lines, $_;
  }
  close KID_TO_READ;
  unlink $qstatout;

  # Copy raw data to $rawout?
  if ($saveraw) {
    open(OUT, ">$rawout") or die "Can't open $rawout: $!\n";
    print OUT @lines;
    close OUT;
  }

  # Break out variables for each server
  local %server;
  @slist = ();
  while (@lines) {
    $_ = shift @lines;
    chomp;
    tr/\r//;
    next unless $_;		# drop blanks
    ($type,$addr,$server,$mapname,$max,$players,$response,$retry) =
      split /-,-/, $_;
    next unless $type eq "Q2";	# some non-Q2 servers show up
    push @slist, $addr;
    %this_addr = (
	type		=> $type,
	addr		=> $addr,
	server		=> $server,
	mapname		=> $mapname,
	max		=> $max,
	players		=> $players,
	response	=> $response,
	retry		=> $retry
    );
    for $what (keys %this_addr) {
      $server{$addr}{$what} = $this_addr{$what};
    }
  }

  # Formatted data if uncommented in optional variables
  if ($outfile) {
    open(OUT, ">$outfile") or die "Can't open $outfile: $!\n";
  }
  # Low ping source list for quicker response next time
  if ($savelp) {
    open(LPLIST, ">$lplist") or die "Can't open $lplist: $!\n";
  }
  # Sort by ping for menu display
  sub byresponse {$server{$a}{response} <=> $server{$b}{response};}
  $menuitems = '';
  @server = ();
  $i = 0;
  my $bestping;
  foreach $addr (sort byresponse @slist) {
    $bestping = $server{$addr}{response};
    if ($bestping > $maxping && $i eq 0) {
      print "\nNo pings < $maxping, trying \$maxping = $maxping2\n";
      $maxping = $maxping2;
      sleep 4;
    }
    last if $bestping > $maxping;
    $host = sprintf "%-30.29s", $addr;
    $line = sprintf "%3.3s", $server{$addr}{response};
    $line .= "ms ";
    $line .= sprintf "%-42.41s", $server{$addr}{server};
    $line .= sprintf "%-10.11s", $server{$addr}{mapname};
    $line .= sprintf "%3.3s", $server{$addr}{players};
    $line .= "/";
    $line .= sprintf "%-4.3s", $server{$addr}{max};
    print OUT "$line\n$host\n\n" if $outfile;
    print LPLIST "$server{$addr}{type} $addr\n" if $savelp;
  # Add servers to menu list and corresponding server array
    $i++;
    $menuitems .= qq("$i" "$line" );
    $server[$i] = $addr;
  }
  close OUT if $outfile;
  close LPLIST if $savelp;

  unless ($menuitems) {
    warn "\nNetwork or qstat problem (best server ping = $bestping).\n";
    die "See \$maxping and \$maxping2 variables.\n";
  }

  $? = 0;
  until ($?) {
    $box = 'dialog --title "Quake 2 Servers" --menu'
      . qq( "Select one for more details" $rows $cols $mrows ). $menuitems;

    $in = `$box 3>&1 1>&2 2>&3 3>&-`;
  # Return on error or get details
    if ($?) {
      $? = 0 if $? eq 256;	# Cancel is OK for source menu
      return;
    } else {
      &details($server[$in]);
    }
  }
}

sub details {
# Updated server details including players and rules
  my ($addr) = @_;
  my ($name, $frags, $ping, $what);
  # Default Q2 port if none specified
  $addr .= ':27910' unless $addr =~ /[:]/;
  my $in = `$qstat -P -R -raw "-,-" -qws $addr`;
  my @lines = split /\n/, $in;
  $_ = shift @lines; 
  ($type,$addr,$server,$map,$max,$players,$response,$retry) =
    split /-,-/, $_;
  my $rules = shift @lines;
  my $box = 'dialog --title "Quake 2 Server Details" '
  	. qq(--menu "Do you want to join this server?" $rows $cols $mrows )
  	. qq("-" "$server" "-" "$addr   map $map   players $players/$max)
	. qq(   ping $response ms" "-" " " );  

# Player list
  if (@lines) {
    while ($_ = shift @lines) {
      ($name,$frags,$ping) = split /-,-/, $_;
      $box .= '"-" "';
      $box .= sprintf "%-34.34s", $name;
      $box .= sprintf "%7.4s", $frags;
      $box .= sprintf "%15.12s", $ping;
      $box .= 'ms" ';
    }
    $box .= '"-" " " ';  
  }

# Rules list
  my @rules = split /-,-/, $rules;
  while ($_ = shift @rules) {
    local ($key, $value) = split /=/, $_;
    $box .= '"-" "';
    $box .= sprintf "%-18.18s", $key;
    $box .= qq( = $value" );
  }   

# Display details with option to join server
  `$box 3>&1 1>&2 2>&3 3>&-`;
  if ($?) {
    $? = 0 if $? eq 256;
    return;
  }

  if ($runq2[1]) {
    $box = 'dialog --title "Run Configuration" --backtitle "Quickspy2" '
      . qq(--menu "Cancel returns to server list" 15 68 8 );

    $i = 0;
    foreach $in (@runq2) {
      $box .= qq("$i"  "$in" );
      $i++;
    }

    $in = `$box 3>&1 1>&2 2>&3 3>&-`;
    if ($?) {	# non-zero on Cancel or error
      $? = 0 if $? eq 256;
      return;
    }
  } else {
    $in = 0;
  }
  chdir $q2dir;
  exec "$runq2[$in] +connect $addr";
  die "Can't exec $runq2[$in]: $!\n";
}