501 lines
14 KiB
Perl
501 lines
14 KiB
Perl
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/^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
|