package TRcon;
#
# TRcon Perl Module - execute commands on a remote Half-Life2 server using remote console.
#
# HLstatsX Community Edition - Real-time player and clan rankings and statistics
# Copyleft (L) 2008-20XX Nicholas Hastings (nshastings@gmail.com)
# http://www.hlxcommunity.com
#
# HLstatsX Community Edition is a continuation of 
# ELstatsNEO - Real-time player and clan rankings and statistics
# Copyleft (L) 2008-20XX Malte Bayer (steam@neo-soft.org)
# http://ovrsized.neo-soft.org/
# 
# ELstatsNEO is an very improved & enhanced - so called Ultra-Humongus Edition of HLstatsX
# HLstatsX - Real-time player and clan rankings and statistics for Half-Life 2
# http://www.hlstatsx.com/
# Copyright (C) 2005-2007 Tobias Oetzel (Tobi@hlstatsx.com)
#
# HLstatsX is an enhanced version of HLstats made by Simon Garner
# HLstats - Real-time player and clan rankings and statistics for Half-Life
# http://sourceforge.net/projects/hlstats/
# Copyright (C) 2001  Simon Garner
#             
# This program is free software; you can redistribute it and/or
# modify it under the terms of the GNU General Public License
# as published by the Free Software Foundation; either version 2
# of the License, or (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
# 
# For support and installation notes visit http://www.hlxcommunity.com

use strict;
no strict 'vars';

use Sys::Hostname;
use IO::Socket;
use IO::Select;
use bytes;
use Scalar::Util;

do "$::opt_libdir/HLstats_GameConstants.plib";

my $VERSION = "1.00";
my $TIMEOUT = 1.0;

my $SERVERDATA_EXECCOMMAND        = 2;
my $SERVERDATA_AUTH               = 3;
my $SERVERDATA_RESPONSE_VALUE     = 0;
my $SERVERDATA_AUTH_RESPONSE      = 2;
my $REFRESH_SOCKET_COUNTER_LIMIT  = 100;
my $AUTH_PACKET_ID                = 1;
my $SPLIT_END_PACKET_ID           = 2;

#
# Constructor
#

sub new
{
  my ($class_name, $server_object) = @_;
  my ($self) = {};
  bless($self, $class_name);
  
  $self->{"rcon_socket"}            = 0;
  $self->{"server_object"}          = $server_object;
  Scalar::Util::weaken($self->{"server_object"});
  $self->{"auth"}                   = 0;
  $self->{"refresh_socket_counter"} = 0;
  $self->{"packet_id"}              = 10;
  return $self;
}

sub execute
{
  my ($self, $command, $splitted_answer) = @_;
  if ($::g_stdin == 0) {
    my $answer = $self->sendrecv($command, $splitted_answer);
    if ($answer =~ /bad rcon_password/i) {
      &::printEvent("TRCON", "Bad Password");
    }
    return $answer;
  }  
}

sub get_auth_code
{
  my ($self, $id) = @_;
  my $auth = 0;
  
  if ($id == $AUTH_PACKET_ID) {
    &::printEvent("TRCON", "Rcon password accepted");
    $auth = 1;
    $self->{"auth"} = 1;
  } elsif( $id == -1) {
    &::printEvent("TRCON", "Rcon password refused");
    $self->{"auth"} = 0;
    $auth           = 0;
  } else {
    &::printEvent("TRCON", "Bad password response id=$id");
    $self->{"auth"} = 0;
    $auth           = 0;
  }
  return $auth;

}


sub sendrecv
{
  my ($self, $msg, $splitted_answer) = @_;
  
  my $rs_counter = $self->{"refresh_socket_counter"};
  if ($rs_counter % $REFRESH_SOCKET_COUNTER_LIMIT == 0)  {
    if ($self->{"rcon_socket"} > 0) {
      shutdown($self->{"rcon_socket"}, 2);
      $self->{"rcon_socket"} = 0;
    }
    my $server_object = $self->{"server_object"};
    $self->{"rcon_socket"}   =  IO::Socket::INET->new(
                                      		Proto=>"tcp",
                                            PeerAddr=>$server_object->{address}, 
                                            PeerPort=>$server_object->{port}, 
                            	);
    if (!$self->{"rcon_socket"}) {
      &::printEvent("TRCON", "Cannot setup TCP socket on ".$server_object->{address}.":".$server_object->{port}.": $!");
    } 
    $self->{"refresh_socket_counter"} = 0;
    $self->{"auth"} = 0;
  }                          	


  my $r_socket  = $self->{"rcon_socket"};
  my $server    = $self->{"server_object"};

  my $auth      = $self->{"auth"};
  my $response  = "";
  my $packet_id = $self->{"packet_id"};
  
  if (($r_socket) && ($r_socket->connected() )) {
    if ($auth == 0)  {
      &::printEvent("TRCON", "Trying to get rcon access (auth)");
      if ($self->send_rcon($AUTH_PACKET_ID, $SERVERDATA_AUTH, $server->{rcon}, "")) {
        &::printEvent("TRCON", "Couldn't send password");
        return;
      }
      my ($id, $command, $response) = $self->recieve_rcon($AUTH_PACKET_ID);
      if($command == $SERVERDATA_AUTH_RESPONSE) {
        $auth = $self->get_auth_code($id);
      } elsif (($command == $SERVERDATA_RESPONSE_VALUE) && ($id == $AUTH_PACKET_ID)) {  
         #Source servers sends one junk packet during the authentication step, before it responds 
         # with the correct authentication response.  
         &::printEvent("TRCON", "Junk packet from Source Engine");
         my ($id, $command, $response) = $self->recieve_rcon($AUTH_PACKET_ID);
         $auth = $self->get_auth_code($id);
      }  
    }
    
    if ($auth == 1)  {
      $self->{"refresh_socket_counter"}++;
      $self->send_rcon($packet_id, $SERVERDATA_EXECCOMMAND, $msg);
      if ($splitted_answer > 0) {
        $self->send_rcon($SPLIT_END_PACKET_ID, $SERVERDATA_EXECCOMMAND, "");
      }  
      my ($id, $command, $response) = $self->recieve_rcon($packet_id, $splitted_answer);
      $self->{"packet_id"}++;
      if ($self->{"packet_id"} > 32767) {
        $self->{"packet_id"} = 10;
      }
      return $response;
    }
  } else {
    $self->{"refresh_socket_counter"} = 0;
  } 
  return;
  
}

#
# Send a package
#
sub send_rcon
{
  my ($self, $id, $command, $string1, $string2) = @_;
  my $data = pack("VVZ*Z*", $id, $command, $string1, $string2);
  my $size = length($data);
  if($size > 4096) {
    &::printEvent("TRCON", "Command to long to send!");
    return 1;
  }
  $data = pack("V", $size).$data;

  my $r_socket = $self->{"rcon_socket"};
  if ($r_socket && $r_socket->connected() && $r_socket->peeraddr()) {
    $r_socket->send($data, 0);
    return 0;
  } else {
    $self->{"refresh_socket_counter"} = 0;
  }
  return 1;
}

#
#  Recieve a package
#
sub recieve_rcon
{
  my ($self, $packet_id, $splitted_answer) = @_;
  my ($size, $id, $command, $msg);
  my $tmp = "";

  my $r_socket  = $self->{"rcon_socket"};
  my $server    = $self->{"server_object"};
  my $auth      = $self->{"auth"};
  my $packet_id = $self->{"packet_id"};
  
  if (($r_socket) && ($r_socket->connected() )) {
    if(IO::Select->new($r_socket)->can_read($TIMEOUT)) {  # $TIMEOUT seconds timeout
      $r_socket->recv($tmp, 1500);
      $size    = unpack("V",  substr($tmp, 0, 4));
	  if ($size == 0) {
		$self->{"refresh_socket_counter"} = 0;
		return (-1, -1, -1);
	  }
      $id      = unpack("V",  substr($tmp, 4, 4));
      $command = unpack("V",  substr($tmp, 8, 4));
      if ($id == $packet_id)  {
        $tmp     = substr($tmp, 12, length($tmp)-12);
        if ($splitted_answer > 0) {
          my $last_packet_id = $id;
          while ($last_packet_id != $SPLIT_END_PACKET_ID) {
            if(IO::Select->new($r_socket)->can_read($TIMEOUT)) {
              $r_socket->recv($split_data, 1500);
              my $split_size    = unpack("V",  substr($split_data, 0, 4));
              my $split_id      = unpack("V",  substr($split_data, 4, 4));
              my $split_command = unpack("V",  substr($split_data, 8, 4));
              if ($split_id == $last_packet_id) {
                $split_data = substr($split_data, 12, length($split_data)-12);
              }
			  if (!defined($split_id)){
				$last_packet_id = $SPLIT_END_PACKET_ID;
			  } else {
				$last_packet_id = $split_id;
			  }
              $tmp .= $split_data;
            } else {
              &::printNotice("TRCON", "Multiple packet error");
              $last_packet_id = $SPLIT_END_PACKET_ID;
            }
          }
        }
        if (length($tmp) > 0)  {
          $tmp .= "\x00";
          my ($string1, $string2) = unpack("Z*Z*", $tmp);
          $msg = $string1.$string2;
        } else {
          $msg = "";
        }  
      }
      return ($id, $command, $msg);
    } else {
      $self->{"refresh_socket_counter"} = 0;
      return (-1, -1, -1);
    }
  } else {
    $self->{"refresh_socket_counter"} = 0;
    return (-1, -1, -1);
  }
}

#
# Get error message
#

sub error
{
  my ($self) = @_;
  return $self->{"rcon_error"};
}



#
# Parse "status" command output into player information
#

sub getPlayers
{
  my ($self) = @_;
  my $status = $self->execute("status", 1);
  if (!$status)
  {
  	return ("", -1, "", 0);
  }
  
  my @lines = split(/[\r\n]+/, $status);

  my %players;

# HL2 standard
# userid name uniqueid connected ping loss state adr
# 187 ".:[SoV]:.Evil Shadow" STEAM_0:1:6200412 13:48 97 0 active 213.10.196.229:24085

# L4D
# userid name uniqueid connected ping loss state rate adr
#  2 1 "psychonic" STEAM_1:1:4153990 00:45 68 1 active 20000 192.168.5.115:27006

  foreach my $line (@lines)
  {
    if ($line =~ /^\#\s*
                (\d+)\s+		# userid
				(?:\d+\s+|)     # extra number in L4D, not sure what this is??
                "(.+)"\s+		# name
                (.+)\s+		    # uniqueid
                ([\d:]+)\s+		# time
                (\d+)\s+		# ping
                (\d+)\s+		# loss
                ([A-Za-z]+)\s+	# state
				(?:\d+\s+|)		# rate (L4D only)
                ([^:]+):    	# addr
                (\S+)           # port
                $/x)
    {
      my $userid   = $1;
      my $name     = $2;
      my $uniqueid = $3;
      my $time     = $4;
      my $ping     = $5;
      my $loss     = $6;
      my $state    = $7;
      my $address  = $8;
      my $port     = $9;

      $uniqueid =~ s!\[U:1:(\d+)\]!($1 % 2).':'.int($1 / 2)!eg;
      $uniqueid =~ s/^STEAM_[0-9]+?\://i;

      # &::printEvent("DEBUG", "USERID: '$userid', NAME: '$name', UNIQUEID: '$uniqueid', TIME: '$time', PING: '$ping', LOSS: '$loss', STATE: '$state', ADDRESS:'$address', CLI_PORT: '$port'", 1);

      if ($::g_mode eq "NameTrack") {
        $players{$name}    = { 
                             "Name"       => $name,
                             "UserID"     => $userid,
                             "UniqueID"   => $uniqueid,
                             "Time"       => $time,
                             "Ping"       => $ping,
                             "Loss"       => $loss,
                             "State"      => $state,
                             "Address"    => $address,
                             "ClientPort" => $port
                           };
      } elsif ($::g_mode eq "LAN") {
        $players{$address} = { 
                             "Name"       => $name,
                             "UserID"     => $userid,
                             "UniqueID"   => $uniqueid,
                             "Time"       => $time,
                             "Ping"       => $ping,
                             "Loss"       => $loss,
                             "State"      => $state,
                             "Address"    => $address,
                             "ClientPort" => $port
                           };
      } else {
        $players{$uniqueid} = { 
                             "Name"       => $name,
                             "UserID"     => $userid,
                             "UniqueID"   => $uniqueid,
                             "Time"       => $time,
                             "Ping"       => $ping,
                             "Loss"       => $loss,
                             "State"      => $state,
                             "Address"    => $address,
                             "ClientPort" => $port
                            };
      }
      
    }
  }
  return %players;
}

sub getServerData
{
  my ($self) = @_;
  my $status = $self->execute("status", 1);
  
  my $server_object = $self->{server_object};
  my $game = $server_object->{play_game};  

  my @lines = split(/[\r\n]+/, $status);

  my $servhostname         = "";
  my $map         = "";
  my $max_players = 0;
  my $difficulty = 0;

  foreach my $line (@lines)
  {
    if ($line =~ /^\s*hostname\s*:\s*([\S].*)$/)
    {
      $servhostname   = $1;
    }
    elsif ($line =~ /^\s*map\s*:\s*([\S]+).*$/)
    {
      $map   = $1;
    }
    elsif ($line =~ /^\s*players\s*:\s*\d+.+\((\d+)\smax.*$/)
    {
      $max_players = $1;
    }
  }
  if ($game == L4D()) {
	  $difficulty = $self->getDifficulty();
  }
  return ($servhostname, $map, $max_players, $difficulty);
}


sub getVisiblePlayers
{
  my ($self) = @_;
  my $status = $self->execute("sv_visiblemaxplayers");
  
  my @lines = split(/[\r\n]+/, $status);
  

  my $max_players = -1;
  foreach my $line (@lines)
  {
   # "sv_visiblemaxplayers" = "-1"
   #       - Overrides the max players reported to prospective clients
    if ($line =~ /^\s*"sv_visiblemaxplayers"\s*=\s*"([-0-9]+)".*$/x)
    {
      $max_players   = $1;
    }
  }
  return ($max_players);
}

my %l4d_difficulties = (
	'Easy'       => 1,
	'Normal'     => 2,
	'Hard'       => 3,
	'Impossible' => 4
);

sub getDifficulty
{
	#z_difficulty
	#"z_difficulty" = "Normal"
	# game replicated
	# - Difficulty of the current game (Easy, Normal, Hard, Impossible)
	
  my ($self) = @_;
  my $zdifficulty = $self->execute("z_difficulty");
	
  my @lines = split(/[\r\n]+/, $zdifficulty);
  
  foreach my $line (@lines)
  {
    if ($line =~ /^\s*"z_difficulty"\s*=\s*"([A-Za-z]+)".*$/x)
    {
		if (exists($l4d_difficulties{$1}))
		{
			return $l4d_difficulties{$1};
		}
    }
  }
  return 0;
}


#
# Get information about a player by userID
#

sub getPlayer
{
  my ($self, $uniqueid) = @_;
  my %players = $self->getPlayers();
  
  if (defined($players{$uniqueid}))
  {
    return $players{$uniqueid};
  }
  else
  {
    $self->{"error"} = "No such player # $uniqueid";
    return 0;
  }
}

1;
# end