hlstatsx/scripts/BASTARDrcon.pm

385 lines
9.7 KiB
Perl
Raw Normal View History

2013-12-26 00:43:29 +01:00
package BASTARDrcon;
#
# BASTARDrcon Perl Module - execute commands on a remote Half-Life 1 server using Rcon.
# A merge of the KKrcon library into HLstatsX
# Copyright (C) 2008-20XX Nicholas Hastings (nshastings@gmail.com)
# KKrcon Perl Module - execute commands on a remote Half-Life server using Rcon.
# http://kkrcon.sourceforge.net
#
# TRcon Perl Module - execute commands on a remote Half-Life2 server using remote console.
# http://www.hlstatsx.com
#
# Copyright (C) 2000, 2001 Rod May
# Enhanced in 2005 by Tobi (Tobi@gameme.de)
#
# 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.
#
use strict;
use sigtrap;
use Socket;
use Sys::Hostname;
use bytes;
##
## Main
##
#
# Constructor
#
sub new
{
my ($class_name, $server_object) = @_;
my ($self) = {};
bless($self, $class_name);
# Initialise properties
$self->{server_object} = $server_object;
$self->{rcon_password} = $server_object->{rcon} or die("BASTARDrcon: a Password is required\n");
$self->{server_host} = $server_object->{address};
$self->{server_port} = int($server_object->{port}) or die("BASTARDrcon: invalid Port \"" . $server_object->{port} . "\"\n");
$self->{socket} = undef;
$self->{error} = "";
# Set up socket parameters
$self->{_ipaddr} = gethostbyname($self->{server_host}) or die("BASTARDrcon: could not resolve Host \"" . $self->{server_host} . "\"\n");
return $self;
}
#
# Execute an Rcon command and return the response
#
sub execute
{
my ($self, $command) = @_;
my $msg;
my $ans;
# version x.1.0.6+ HL1 server
$msg = "\xFF\xFF\xFF\xFFchallenge rcon\n\0";
$ans = $self->_sendrecv($msg);
if ($ans =~ /challenge +rcon +(\d+)/)
{
$msg = "\xFF\xFF\xFF\xFFrcon $1 \"" . $self->{"rcon_password"} . "\" $command\0";
$ans = $self->_sendrecv($msg);
}
elsif (!$self->error())
{
$ans = "";
$self->{"error"} = "No challenge response";
}
if ($ans =~ /bad rcon_password/i)
{
$self->{"error"} = "Bad Password";
}
return $ans;
}
sub _sendrecv
{
my ($self, $msg) = @_;
my $host = $self->{"server_host"};
my $port = $self->{"server_port"};
my $ipaddr = $self->{"_ipaddr"};
my $proto = $self->{"_proto"};
# Open socket
socket($self->{"socket"}, PF_INET, SOCK_DGRAM, $proto) or die("BASTARDrcon(141): socket: $!\n");
my $hispaddr = sockaddr_in($port, $ipaddr);
die("BASTARDrcon: send $ipaddr:$port : $!") unless(defined(send($self->{"socket"}, $msg, 0, $hispaddr)));
my $rin = "";
vec($rin, fileno($self->{"socket"}), 1) = 1;
my $ans = "TIMEOUT";
if (select($rin, undef, undef, 0.5))
{
$ans = "";
$hispaddr = recv($self->{"socket"}, $ans, 8192, 0);
$ans =~ s/\x00+$//; # trailing crap
$ans =~ s/^\xFF\xFF\xFF\xFFl//; # HL response
$ans =~ s/^\xFF\xFF\xFF\xFFn//; # QW response
$ans =~ s/^\xFF\xFF\xFF\xFF//; # Q2/Q3 response
$ans =~ s/^\xFE\xFF\xFF\xFF.....//; # old HL bug/feature
}
# Close socket
close($self->{"socket"});
if ($ans eq "TIMEOUT")
{
$ans = "";
$self->{"error"} = "Rcon timeout";
}
return $ans;
}
#
# Send a package
#
sub send_rcon
{
my ($self, $id, $command, $string1, $string2) = @_;
my $tmp = pack("VVZ*Z*",$id,$command,$string1,$string2);
my $size = length($tmp);
if($size > 4096)
{
$self->{error} = "Command too long to send!";
return 1;
}
$tmp = pack("V", $size) .$tmp;
unless(defined(send($self->{"socket"},$tmp,0)))
{
die("BASTARDrcon: send $!");
}
return 0;
}
#
# Recieve a package
#
sub recieve_rcon
{
my $self = shift;
my ($size, $id, $command, $msg);
my $rin = "";
my $tmp = "";
vec($rin, fileno($self->{"socket"}), 1) = 1;
if(select($rin, undef, undef, 0.5))
{
while(length($size) < 4)
{
$tmp = "";
recv($self->{"socket"}, $tmp, (4-length($size)), 0);
$size .= $tmp;
}
$size = unpack("V", $size);
if($size < 10 || $size > 8192)
{
close($self->{"socket"});
$self->{error} = "illegal size $size ";
return (-1, -1, -1);
}
while(length($id)<4)
{
$tmp = "";
recv($self->{"socket"}, $tmp, (4-length($id)), 0);
$id .= $tmp;
}
$id = unpack("V", $id);
$size = $size - 4;
while(length($command)<4)
{
$tmp ="";
recv($self->{"socket"}, $tmp, (4-length($command)),0);
$command.=$tmp;
}
$command = unpack("V", $command);
$size = $size - 4;
my $msg = "";
while($size >= 1)
{
$tmp = "";
recv($self->{"socket"}, $tmp, $size, 0);
$size -= length($tmp);
$msg .= $tmp;
}
my ($string1,$string2) = unpack("Z*Z*",$msg);
$msg = $string1.$string2;
return ($id, $command, $msg);
}
else
{
return (-1, -1, -1);
}
}
#
# Get error message
#
sub error
{
my ($self) = @_;
return $self->{"error"};
}
#
# Parse "status" command output into player information
#
sub getPlayers
{
my ($self) = @_;
my $status = $self->execute("status");
my @lines = split(/[\r\n]+/, $status);
my %players;
# HL1
# name userid uniqueid frag time ping loss adr
# 1 "psychonic" 1 STEAM_0:1:4153990 0 00:33 13 0 192.168.5.115:27005
foreach my $line (@lines)
{
if ($line =~ /^\#\s*\d+\s+
"(.+)"\s+ # name
(\d+)\s+ # userid
([^\s]+)\s+\d+\s+ # uniqueid
([\d:]+)\s+ # time
(\d+)\s+ # ping
(\d+)\s+ # loss
([^:]+): # addr
(\S+) # port
$/x)
{
my $name = $1;
my $userid = $2;
my $uniqueid = $3;
my $time = $4;
my $ping = $5;
my $loss = $6;
my $state = "";
my $address = $7;
my $port = $8;
$uniqueid =~ s/^STEAM_[0-9]+?\://i;
# &::printEvent("DEBUG", "USERID: '$userid', NAME: '$name', UNIQUEID: '$uniqueid', TIME: '$time', PING: '$ping', LOSS: '$loss', 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");
my @lines = split(/[\r\n]+/, $status);
my $servhostname = "";
my $map = "";
my $max_players = 0;
foreach my $line (@lines)
{
if ($line =~ /^\s*hostname\s*:\s*([\S].*)$/x)
{
$servhostname = $1;
}
elsif ($line =~ /^\s*map\s*:\s*([\S]+).*$/x)
{
$map = $1;
}
elsif ($line =~ /^\s*players\s*:\s*\d+.+\((\d+)\smax.*$/)
{
$max_players = $1;
}
}
return ($servhostname, $map, $max_players, 0);
}
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);
}
#
# 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