346 lines
7.3 KiB
Perl
Executable file
346 lines
7.3 KiB
Perl
Executable file
# HL2 - Perl extension Half-Life 2 (Source) engine Rcon interface
|
|
#
|
|
# $Id:$
|
|
#
|
|
|
|
package HL2;
|
|
|
|
use strict;
|
|
use warnings;
|
|
use IO::Socket;
|
|
use IO::Select;
|
|
|
|
# release version
|
|
our $VERSION = "0.05";
|
|
|
|
# constants for command type
|
|
sub CMD { 2 }
|
|
sub AUTH { 3 }
|
|
|
|
# create class
|
|
sub new {
|
|
my $class = shift;
|
|
|
|
# create object with defaults
|
|
my $self = {
|
|
hostname => undef,
|
|
port => 27015,
|
|
password => undef,
|
|
timeout => 5,
|
|
connected => 0,
|
|
authenticated => 0,
|
|
socket => undef,
|
|
sequence => 0,
|
|
};
|
|
|
|
# create object
|
|
bless($self, $class);
|
|
|
|
# initialize class instances
|
|
$self->init();
|
|
|
|
# parse constructor args
|
|
while (my ($key, $val) = splice(@_, 0, 2)) {
|
|
$key = lc($key);
|
|
if ($key eq "hostname") { $self->hostname($val) }
|
|
elsif ($key eq "port") { $self->port($val) }
|
|
elsif ($key eq "password") { $self->password($val) }
|
|
elsif ($key eq "timeout") { $self->timeout($val) }
|
|
else { print STDERR "Unknown attribute: $key\n" }
|
|
}
|
|
|
|
return $self;
|
|
}
|
|
|
|
# initialize class instances
|
|
sub init {
|
|
my $self = shift;
|
|
my $class = ref($self);
|
|
|
|
# manipulate symbol table.. gotta love perl
|
|
no strict "refs";
|
|
no warnings;
|
|
foreach my $instance (keys %$self) {
|
|
*{"${class}::${instance}"} = sub {
|
|
my $self = shift;
|
|
my $value = shift;
|
|
my $ref = \$self->{$instance};
|
|
if (defined $value) {
|
|
$$ref = $value;
|
|
return $self;
|
|
} else {
|
|
return $$ref;
|
|
}
|
|
};
|
|
}
|
|
}
|
|
|
|
# run a command and return its response
|
|
sub run {
|
|
my $self = shift;
|
|
my $command = shift;
|
|
|
|
if (!$self->connected()) {
|
|
$self->connect();
|
|
}
|
|
|
|
if (!$self->authenticated()) {
|
|
$self->authenticate();
|
|
}
|
|
|
|
my $socket = $self->socket();
|
|
if($socket->connected)
|
|
{
|
|
print $socket $self->packet(CMD, $command);
|
|
return $self->response();
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
# create tcp socket
|
|
sub connect {
|
|
my $self = shift;
|
|
|
|
my $socket = IO::Socket::INET->new(
|
|
PeerAddr => $self->hostname(),
|
|
PeerPort => $self->port(),
|
|
Timeout => $self->timeout(),
|
|
Proto => "tcp",
|
|
Type => SOCK_STREAM,
|
|
) || die "Failed to connect: $!\n";
|
|
|
|
$self->socket($socket);
|
|
$self->connected(1);
|
|
}
|
|
|
|
# authenticate rcon session
|
|
sub authenticate {
|
|
my $self = shift;
|
|
|
|
# send authentication packet to server
|
|
my $socket = $self->socket();
|
|
print $socket $self->packet(AUTH, $self->password());
|
|
|
|
# auth response sends back an empty packet first
|
|
$self->response();
|
|
$self->response();
|
|
|
|
$self->authenticated(1);
|
|
}
|
|
|
|
######################
|
|
# PROTOCOL FUNCTIONS #
|
|
######################
|
|
|
|
# rcon command protocol:
|
|
# (V)[size] (V)[requestID] (V)[command] (0)[string1] (0)[string2]
|
|
#
|
|
# rcon response protocol:
|
|
# (V)[size] (V)[requestID] (V)[responseID] (0)[string1] (0)[string2]
|
|
#
|
|
# V = a 32-bit unsigned long int, little-endian (VAX/Intel)
|
|
# 0 = null-terminated string
|
|
#
|
|
# NOTE: string2 appears unused, so our functions ignore it
|
|
|
|
# create a packet of type (AUTH or CMD)
|
|
sub packet {
|
|
my $self = shift;
|
|
my $type = shift;
|
|
my $payload = shift;
|
|
|
|
# sequence increments, but auth
|
|
# packet is 2.. no idea why that is,
|
|
# but tcpdump does not lie
|
|
my $sequence;
|
|
if ($type == AUTH) {
|
|
$sequence = 2;
|
|
} else {
|
|
$sequence = $self->sequence();
|
|
|
|
# increment for next use
|
|
$self->sequence($sequence + 1);
|
|
}
|
|
|
|
my $packet = pack("VV", $sequence, $type) . "$payload\x00\x00";
|
|
$packet = pack("V", length($packet)) . $packet;
|
|
|
|
return $packet;
|
|
}
|
|
|
|
# receive packet
|
|
sub response {
|
|
my $self = shift;
|
|
my $payload = $self->read();
|
|
|
|
# remove protocol cruft and null terminators
|
|
$payload =~ s/\x00{2}$//;
|
|
|
|
return $payload;
|
|
}
|
|
|
|
# read length of bytes from socket with timeout
|
|
sub read {
|
|
my $self = shift;
|
|
my $length = shift;
|
|
|
|
my $socket = $self->socket();
|
|
my $timeout = $self->timeout();
|
|
my $select = IO::Select->new($socket);
|
|
|
|
my $reply = "";
|
|
my $buffer;
|
|
|
|
my ($size, $request_id, $command_response, $data);
|
|
|
|
while ($select->can_read(0.5)) {
|
|
$socket->recv($buffer, 4, MSG_PEEK);
|
|
$size = unpack("V", $buffer);
|
|
last if (!defined($size));
|
|
$socket->recv($buffer, $size+4, MSG_WAITALL);
|
|
|
|
($size, $request_id, $command_response, $data) =
|
|
unpack('VVVZ*x', $buffer);
|
|
|
|
$reply .= "$data";
|
|
}
|
|
|
|
return $reply;
|
|
}
|
|
|
|
1;
|
|
|
|
__END__
|
|
|
|
=head1 NAME
|
|
|
|
HL2 - Perl extension Half-Life 2 (Source) engine Rcon interface
|
|
|
|
=head1 SYNOPSIS
|
|
|
|
use HL2;
|
|
my $rcon = HL2->new(
|
|
hostname => "insub.org",
|
|
password => "yourpass",
|
|
timeout => 3,
|
|
);
|
|
|
|
print $rcon->run("status");
|
|
$rcon->run("changelevel de_dust");
|
|
|
|
=head1 DESCRIPTION
|
|
|
|
Use this module to send "rcon" (remote control) commands to a
|
|
Source server, such as Counter-Strike Source.
|
|
|
|
=head1 METHODS
|
|
|
|
=over 4
|
|
|
|
=item $rcon = HL2->new()
|
|
|
|
Create a new rcon object. You can specify the hostname,
|
|
password and/or timeout in the constructor, or use the class
|
|
methods to change them (see SYNOPSIS).
|
|
|
|
=item $rcon->authenticated()
|
|
|
|
Returns true if session has succesfully authenticated.
|
|
|
|
=item $rcon->password()
|
|
|
|
Returns current password, or sets it. Note that setting
|
|
this after authentication will not have any effect unless
|
|
you reconnect with $rcon->authenticated(0).
|
|
|
|
=item $rcon->hostname()
|
|
|
|
Returns current hostname, or sets it.
|
|
|
|
=item $rcon->port()
|
|
|
|
Returns current port, or sets it. Defaults to 27015.
|
|
|
|
=item $rcon->sequence()
|
|
|
|
Returns the current command sequence. This starts
|
|
at 0 and increases with each call.
|
|
|
|
=item $rcon->socket()
|
|
|
|
Returns the IO::Socket object for the session or
|
|
creates a new one if none exists.
|
|
|
|
=item $rcon->timeout()
|
|
|
|
Returns the TCP response timeout, or sets it. Defaults
|
|
to 5.
|
|
|
|
=item $rcon->connect()
|
|
|
|
Connects to remote server.
|
|
|
|
=item $packet = $rcon->packet($type, $payload)
|
|
|
|
Creats a packet to send to the remote server.
|
|
Type should be either CMD or AUTH, e.g.:
|
|
|
|
print $socket $rcon->packet(AUTH, $rcon->password())
|
|
|
|
=item $rcon->authenticate()
|
|
|
|
Authenticates with the rcon server. This is done automatically
|
|
when you try to run a command.
|
|
|
|
=item $response = $rcon->run($command)
|
|
|
|
Runs a command on the remote server and returns its response
|
|
|
|
=item $response = $rcon->response()
|
|
|
|
Reads a response packet from the server. This is called
|
|
authomatically when you use run() so you shouldn't need to
|
|
use this.
|
|
|
|
=back
|
|
|
|
=head1 CAVEATS
|
|
|
|
This module DOES NOT DO ANY COMMAND VALIDATION. You are responsible for
|
|
sending sane commands to the server. If you use this with CGI that allows
|
|
internet users to submit console commands, you MUST taint-check this. Users
|
|
with RCON access can send anything to the console. I highly recommend that you
|
|
restrict what console commands a user can send.
|
|
|
|
=head1 BUGS
|
|
|
|
As of this writing, there are some bugs with the rcon server itself.
|
|
One such bug is that some output goes to the console instead of to
|
|
the rcon client. For example, the command "listid" causes the list
|
|
of banned users to spew to the physical console instead of back to
|
|
the rcon client, making it effectively useless. If you are not getting
|
|
back a response you expected, please verify that it's not going to
|
|
the console (run srcds in screen so you can access it) before submitting
|
|
a bug report to me about it. Or better yet, submit a bug report to Valve.
|
|
|
|
Authentication validation is currently unsupported.
|
|
|
|
=head1 SEE ALSO
|
|
|
|
http://gruntle.org/projects/
|
|
http://insub.org/cs/
|
|
|
|
=head1 AUTHOR
|
|
|
|
Chris Jones, E<lt>cjones@gruntle.orgE<gt>
|
|
|
|
=head1 COPYRIGHT AND LICENSE
|
|
|
|
Copyright (C) 2004 by Chris Jones
|
|
|
|
This library is free software; you can redistribute it and/or modify
|
|
it under the same terms as Perl itself, either Perl version 5.8.5 or,
|
|
at your option, any later version of Perl 5 you may have available.
|
|
|
|
=cut
|