#!/usr/bin/perl # #BF1942Live v3.0 # #Code by Lt.Christy - http://www.force137.com - christy@force137.com # # DEPRECATED - #Qstat Module - http://www.qstat.org # qstat.pm included in file # #################################################################### # Configure Stats #################################################################### ######## #Server IP and Port: For the Port, just add 8433 onto the value of your port. If you use the default #port of 14567 then you would put in 23000 ######## my $server = '207.44.182.44:23000'; ######## #Border Color of the Stats ######## my $bordercolor = '#000000'; ######## #Top and Bottom Cell Colors ######## my $topbottomcell = '#000000'; ######## #Page Background Color ######## my $backgroundcolor = '#ffffff'; ######## #Server Admin Name, will show as red on the playerlist, or Use serveradmintag to highlight #anyone with that tag, must escape regexp chars ([,.{( and so on) ######## my $serveradmin = 'LA_MERC_Onji'; my $serveradmintag = 'LA_MERC'; ######## #Page Refresh Rate in Seconds ######## my $refreshrate = '8'; ######## #Font Color ######## my $fontcolor = '#000000'; ######## #Number of Ping to be know as a Lagger, Anything above this number will be marked ######## my $lagger = '250'; ######## #Your Webpage/Serverpage URL ######## my $weburl = 'http://www.lamerc.com'; ######## #Mark 1 if using your own Logo in the stats, or 0 if not. Do not make your image wider than 800 #pixels or it will make the table look funny :) ######## my $usetitlepic = '0'; ######## #If Using your own logo, specify location ######## my $titlepic = 'http://www.force137.com/stats/bf1942live/images/bflivelogo.jpg'; ######## #If Using your own logo, specify alignment (left, center, right) ######## my $align = 'left'; ######## #If Using your own logo, specify color behind your Logo ######## my $titlepicbg = '#000000'; ######## #Colors for Laggers, Admin, and Teamkiller ######## my $laggercolor = '#92BDFE'; my $admincolor = '#FB0A04'; my $teamkillercolor = '#F5FE04'; ######## #Colors for Player Count if Server is Full or if Server has an Open Slot ######## my $servernotfullcolor = '#00ff00'; my $serverfullcolor = '#FB0A04'; #################################################################### # End of Configure Stats #################################################################### ### DO NOT EDIT BELOW THIS LINE UNLESS YOU KNOW WHAT YOU ARE DOING ### use strict; use CGI qw(-no_debug); $! = 1; my $q = new CGI; my @sortedplayers = (); my @frags = (); my @sortedfrags = (); my %serverdata = (); my %rules = (); my $now = localtime; my ($generalline,$rulesline,@playerlines); my ($s, $p) = split( /:/, $server ); if ( qstat::query( $s, $p, \@playerlines ) ) { $generalline = shift @playerlines; $rulesline = shift @playerlines; } else { $generalline = "DOWN::DOWN::DOWN"; # use TIMEOUT if we want the "busy" message... } # Split general and rules info into seperate variables my @general = split(/::/,$generalline); $serverdata{"ip"} = $general[1]; $serverdata{"name"} = $general[2]; $serverdata{"map"} = $general[3]; $serverdata{"max"} = $general[4]; $serverdata{"plyrs"}= $general[5]; $serverdata{"ping"} = $general[6]; $serverdata{"tout"} = $general[7]; # Split unknown amount of rules into name/value pairs. for(split '::', $rulesline) { if (my($var_name, $var_value) = split /=/) { $rules{$var_name} = $var_value; } } # Is the server unreachable? if ($serverdata{"name"} eq 'DOWN') { print "Content-type: text/html\r\n\r\n"; print < $serverdata{name} Live View



Server is Down
STATE } elsif ($serverdata{"name"} eq 'TIMEOUT') { print "Content-type: text/html\r\n\r\n"; print < $serverdata{name} Live View



Server is Busy, Please Refresh
STATE } else { # Some default settings: $rules{fraglimit} = $rules{fraglimit} == 0 ? $rules{fraglimit} = 'None' : $rules{fraglimit}; $rules{dmflags} = $rules{dmflags} == 0 ? $rules{dmflags} = 'Default' : $rules{dmflags}; $rules{timelimit} = $rules{timelimit} == 0 ? $rules{timelimit} = 'None' : $rules{timelimit}; $serverdata{limit} = $rules{fraglimit}; $serverdata{limitname} = "Fraglimit"; # Split player info: my (@data,$index); for(0 .. $#playerlines) { @data = split(/::/,$playerlines[$_],3); $frags[$_] = $data[1] . ".$_"; } @sortedfrags = sort {$b <=> $a} @frags; for(0 .. $#sortedfrags) { @data = split(/\./,$sortedfrags[$_]); $index = $data[1]; push (@sortedplayers, $playerlines[$_]); } # Print out what we found: print "Content-type: text/html\r\n\r\n"; print < $serverdata{name} Live View


STATE if ($usetitlepic eq '1') { print < STATE } print < EOF my $idcnt = 0; my $ping = 0; my $frag = 0; my $team = 0; my $name = ''; my $rfrag = 0; my $death = 0; foreach $newplayer (@sortedplayers) { @player = split(/::/,$newplayer); $name = CGI::escapeHTML( $player[0] ); $frag = $player[1]; $ping = $player[2]; $team = $player[3]; $rfrag= $player[4]; $death= $player[5]; $name =~ s/(^.5(?!$))(.*$)/$1.../g; if ($team eq '2') { if ($ping > $lagger) { print < EOF } elsif (($name eq $serveradmin) || ($name =~ /$serveradmintag/)) { print < EOF } elsif ($frag < '0') { print < EOF } else { print < EOF } } } print < EOF my $idcnt = 0; my $ping = 0; my $frag = 0; my $team = 0; my $name = ''; my $rfrag = 0; my $death = 0; foreach $newplayer (@sortedplayers) { @player = split(/::/,$newplayer); $name = CGI::escapeHTML( $player[0] ); $frag = $player[1]; $ping = $player[2]; $team = $player[3]; $rfrag= $player[4]; $death= $player[5]; $name =~ s/(^.5(?!$))(.*$)/$1.../g; if ($team eq '1') { if ($ping > $lagger) { print < EOF } elsif (($name eq $serveradmin) || ($name =~ /$serveradmintag/)) { print < EOF } elsif ($frag < '0') { print < EOF } else { print < EOF } } } print <
 
 $serverdata{name}
STATE if ($serverdata{plyrs} == $serverdata{max}) { print < $serverdata{plyrs} out of $serverdata{max} EOF } elsif (($serverdata{plyrs} < $serverdata{max}) && ($serverdata{plyrs} > 0 )) { print < $serverdata{plyrs} out of $serverdata{max} EOF } else { print < $serverdata{plyrs} out of $serverdata{max} EOF } print < players on map $serverdata{map}
 $now 

Click for Bigger Image
$serverdata{map}
STATE if ($serverdata{plyrs} == 0) { print <No Players Connected EOF } else { my ($newplayer,@player); print <
Allied Team 
Players Score Frags Deaths Ping$name $frag $rfrag $death $ping
$name $frag $rfrag $death $ping
$name $frag $rfrag $death $ping
$name $frag $rfrag $death $ping
 
Axis Team 
Players Score Frags Deaths Ping$name $frag $rfrag $death $ping
$name $frag $rfrag $death $ping
$name $frag $rfrag $death $ping
$name $frag $rfrag $death $ping
 
EOF } print <
Rules Setting
Timelimit $rules{"Time Limit"}
Gametype $rules{gametype}
InfoSite BFCentral.Com
fraglimit $rules{fraglimit}
gamemode $rules{gamemode}
Dedicated $rules{Dedicated}
CPU $rules{CPU}
Allied Team Ratio $rules{"Allied Team Ratio"}
Allow Nose Cam $rules{"Allow Nose Cam"}
Auto Balance Teams $rules{"Auto Balance Teams"}
Free Camera $rules{"Free Camera"}
Game Start Delay $rules{"Game Start Delay"}
Name Tag Distance $rules{"Name Tag Distance"}
Number Of Rounds $rules{"Number Of Rounds"}
Soldier Friendly Fire $rules{"Soldier Friendly Fire"}
Spawn Delay $rules{"Spawn Delay"}
Spawn Wave Time $rules{"Spawn Wave Time"}
Ticket Ratio $rules{"Ticket Ratio"}
Vehicle Friendly Fire $rules{"Vehicle Friendly Fire"}
Server Website Visit Us
BF1942Live Version 3.0
Version: Battlefield 1942 $rules{gamever} Player Color Chart:  Teamkiller/Selfkiller - Admin - Lagging
EOF print "\n"; } #!/usr/bin/perl -w ######################################################################## # $Id: qstat.pm,v 1.4 2003/02/21 16:58:51 jjlupa Exp $ ######################################################################## # # How to get around qstat.exe. This module does direct querying of # a BF1942 host using the gamespy protocol. Note that BF1942 doesn't # really honor the protocol well, and often lies with regards to what # is going on. As such, information returned from here is of marginal # use for logging, but is better than nothing. # # Interested in logging? check out http://lupavista.jamdata.net/bf1942 # # All code (c) Jonathan Lupa (jjlupa@jamdata.net) released under BSD license # ######################################################################## package qstat; ######################################################################## # # INTERFACE: # # bool qstat::query( host_scalar, port_scalar, data_array_ref ); # # if return != 0, data_array_ref is filled out with information simulating # a call to qstat thusly: qstat -R -P -cn -tsw -gps $server -raw :: # ######################################################################## use IO::Socket; use strict; sub query { (@_ == 3 ) || die "USAGE: qstat::query( host_scalar, port_scalar, data_array_ref )"; my( $host, $port, $data_out ) = @_; @$data_out = (); # here is our socket... my $socket = IO::Socket::INET->new( Proto => 'udp', PeerPort => $port, PeerAddr => gethostbyname( $host ) ) || die "socket creation failed: $@"; # GET SERVER STATUS my $msg = "\\status\\"; if ( $socket->send( $msg ) == 0 ) { return 0; } my $reply = undef; my @data = (); my ( $rin, $rout, $eout, $test ); vec( $rin, fileno( $socket ), 1 ) = 1; while ( ! defined( $data[-4]) || $data[-4] ne "final" ) { if ( select( $rout = $rin, undef, $eout = $rin, 1 ) ) { $test = $socket->recv( $reply, 1024 * 8 ); } else { return 0; } # remember to remove the first slash.... $reply =~ s/\\//; push( @data, split( /\\/, $reply ) ); } my( %teams, %scores, %names, %frags, %deaths, %pings, %teamnames, %global ); while ( defined( my $key = shift( @data ) ) ) { my $value = shift( @data ); # TEAMNAME HASHES THE TEAMS NAMES if ( $key =~ /teamname_(\d+)/ ) { my $teamnum = $1 + 1; $teamnames{$teamnum} = $value; } # THESE ARE PLAYER STATS elsif ( $key =~ /score_(\d+)/ ) { $scores{$1} = $value; } elsif ( $key =~ /team_(\d+)/ ) { $teams{$1} = $value; } elsif ( $key =~ /player_(\d+)/ ) { $names{$1} = $value; } elsif ( $key =~ /frags_(\d+)/ ) { $frags{$1} = $value; } elsif ( $key =~ /deaths_(\d+)/ ) { $deaths{$1} = $value; } elsif ( $key =~ /ping_(\d+)/ ) { $pings{$1} = $value; } # THESE ARE THROW AWAY VALUES elsif ( $key eq "queryid" ) { } elsif ( $key eq "final" ) { } # THESE ARE GLOBAL VALUES else { $global{$key}=$value; } } # BUILD LINE 1 # GPS::twinkletwinkle:23000::298th Training Grounds::Gazala::40::38::61::0 my $servername = $global{"hostname"}; if ( scalar( keys( %global ) ) < 10 ) { $servername = "DOWN"; } my $line1 = "GPS::$host:$port" . "::" . $servername . "::" . $global{"mapname"} . "::" . $global{"maxplayers"} . "::" . $global{"numplayers"} . "::" . "60::0"; # who cares about ping push( @$data_out, $line1 ); # BUILD LINE 2 # Line 2 is the server rules my $line2 = ""; foreach ( sort( keys( %global ) ) ) { $line2 = $line2 . "::"; $line2 = $line2 . $_ . "=" . $global{$_}; } foreach ( sort( keys( %teamnames ) ) ) { $line2 = $line2 . "::"; $line2 = $line2 . $_ . "=" . $teamnames{$_}; } push( @$data_out, $line2 ); # BUILD LINE 3+ # These are the players... name::score::ping::team:::::: # I'm adjusting thus: name::score::ping::team::deaths::frags:: foreach( keys( %names ) ) { push( @$data_out, "$names{$_}::$scores{$_}::$pings{$_}::$teams{$_}::$frags{$_}::$deaths{$_}::" ); } return 1; } 1;