385 lines
9.7 KiB
Perl
385 lines
9.7 KiB
Perl
|
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
|