File Coverage

blib/lib/Minecraft/RCON.pm

Criterion	Covered	Total	%
statement	126	128	98.4
branch	68	78	87.1
condition	6	6	100.0
subroutine	25	25	100.0
pod	12	12	100.0
total	237	249	95.1

# Minecraft::RCON - RCON remote console for Minecraft
#
# 1.x and above by Ryan Thompson
#
# Original (0.1.x) by Fredrik Vold, no copyrights, no rights reserved.
# This is absolutely free software, and you can do with it as you please.
# If you do derive your own work from it, however, it'd be nice with some
# credits to me somewhere in the comments of that work.
#
# Based on http:://wiki.vg/RCON documentation

package Minecraft::RCON;

our $VERSION = '1.04';

use 5.010;
use strict;
use warnings;
no warnings 'uninitialized';

use Term::ANSIColor  3.01;
use IO::Socket       1.18;  # autoflush
use Carp;

use constant {
    # Packet types
    AUTH            =>  3,  # Minecraft RCON login packet type
    AUTH_RESPONSE   =>  2,  # Server auth response
    AUTH_FAIL       => -1,  # Auth failure (password invalid)
    COMMAND         =>  2,  # Command packet type
    RESPONSE_VALUE  =>  0,  # Server response
};

# Minecraft -> ANSI color map
my %COLOR = map { $_->[1] => color($_->[0]) } (
    [black        => '0'], [blue           => '1'], [green        => '2'],
    [cyan         => '3'], [red            => '4'], [magenta      => '5'],
    [yellow       => '6'], [white          => '7'], [bright_black => '8'],
    [bright_blue  => '9'], [bright_green   => 'a'], [bright_cyan  => 'b'],
    [bright_red   => 'c'], [bright_magenta => 'd'], [yellow       => 'e'],
    [bright_white => 'f'],
    [bold         => 'l'], [concealed      => 'm'], [underline    => 'n'],
    [reverse      => 'o'], [reset          => 'r'],
);

# Defaults for new objects. Override in constructor or with accessors.
sub _DEFAULTS(%) {
    (
        address       => '127.0.0.1',
        port          => 25575,
        password      => '',
        color_mode    => 'strip',
        request_id    => 0,

        # DEPRECATED options
        strip_color   => undef,
        convert_color => undef,

        @_, # Subclasses may override
    );
}

# DEPRECATED warning text for convenience/consistency
my $DEP = 'deprecated and will be removed in a future release.';

sub new {
    my $class = shift;
    my %opts = 'HASH' eq ref $_[0] ? %{$_[0]} : @_;
    my %DEFAULTS = _DEFAULTS();

    # DEPRECATED -- Warn and transition to new option
    if ($opts{convert_color}) {
        carp "convert_color $DEP\nConverted to color_mode => 'convert'.";
        $opts{color_mode} = 'convert';
    }
    if ($opts{strip_color}) {
        carp "strip_color $DEP\nConverted to color_mode => 'strip'.";
        $opts{color_mode} = 'strip';
    }

    my @unknowns = grep { not exists $DEFAULTS{$_} } sort keys %opts;
    carp "Ignoring unknown option(s): " . join(', ', @unknowns) if @unknowns;

    bless { %DEFAULTS, %opts }, $class;
}

sub connect {
    my ($s) = @_;

    return 1 if $s->connected;

    croak 'Password required' unless length $s->{password};

    $s->{socket} = IO::Socket::INET->new(
        PeerAddr => $s->{address},
        PeerPort => $s->{port},
        Proto    => 'tcp',
    ) or croak "Connection to $s->{address}:$s->{port} failed: .$!";

    my $id = $s->_next_id;
    $s->_send_encode(AUTH, $id, $s->{password});
    my ($size,$res_id,$type,$payload) = $s->_recv_decode;

    # Force a reconnect if we're about to error out
    $s->disconnect unless $type == AUTH_RESPONSE and $id == $res_id;

    croak 'RCON authentication failed'           if $res_id == AUTH_FAIL;
    croak "Expected AUTH_RESPONSE(2), got $type" if   $type != AUTH_RESPONSE;
    croak "Expected ID $id, got $res_id"         if     $id != $res_id;
    croak "Non-blank payload <$payload>"         if  length $payload;

    return 1;
}

sub connected { $_[0]->{socket} and $_[0]->{socket}->connected }

sub disconnect {
    $_[0]->{socket}->shutdown(2) if $_[0]->connected;
    delete $_[0]->{socket} if exists $_[0]->{socket};
    1;
}

sub command {
    my ($s, $command, $mode) = @_;

    croak 'Command required' unless length $command;
    croak 'Not connected'    unless $s->connected;

    my $id = $s->_next_id;
    my $nonce = 16 + int rand(2 ** 15 - 16); # Avoid 0..15
    $s->_send_encode(COMMAND, $id, $command);
    $s->_send_encode($nonce,  $id, 'nonce');

    my $res = '';
    while (1) {
        my ($size,$res_id,$type,$payload) = $s->_recv_decode;
        if ($id != $res_id) {
            $s->disconnect;
            croak sprintf(
                "Desync. Expected %d (0x%4x), got %d (0x%4x). Disconnected.",
                $id, $id, $res_id, $res_id
            );
        }
        croak "size:$size id:$id got type $type, not RESPONSE_VALUE(0)"
            if $type != RESPONSE_VALUE;
        last if $payload eq sprintf 'Unknown request %x', $nonce;
        $res .= $payload;
    }

    $s->color_convert($res, defined $mode ? $mode : $s->{color_mode});
}

sub color_mode {
    my ($s, $mode, $code) = @_;
    return $s->{color_mode} if not defined $mode;
    croak 'Invalid color mode.'
        unless $mode =~ /^(strip|convert|ignore)$/;

    if ($code) {
        my $was = $s->{color_mode};
        $s->{color_mode} = $mode;
        $code->();
        $s->{color_mode} = $was;
    } else {
        $s->{color_mode} = $mode;
    }
}

sub color_convert {
    my ($s, $text, $mode) = @_;
    $mode = $s->{color_mode} if not defined $mode;
    my $re = qr/\x{00A7}(.)/o;

    $text =~ s/$re//g           if $mode eq 'strip';
    $text =~ s/$re/$COLOR{$1}/g if $mode eq 'convert';
    $text .= $COLOR{r}          if $mode eq 'convert' and $text =~ /\e\[/;

    $text;
}

sub DESTROY { $_[0]->disconnect }

#
# DEPRECATED methods
#

sub convert_color {
    my ($s, $val) = @_;
    carp "convert_color() is $DEP\nUse color_mode('convert') instead";
    $s->color_mode('convert') if $val;

    $s->color_mode eq 'convert';
}

sub strip_color {
    my ($s, $val) = @_;
    carp "strip_color() is $DEP\nUse color_mode('strip') instead";
    $s->color_mode('strip') if $val;

    $s->color_mode eq 'strip';
}

sub address {
    carp "address() is $DEP";
    $_[0]->{address} = $_[1] if defined $_[1];
    $_[0]->{address};
}

sub port {
    carp "port() is $DEP";
    $_[0]->{port} = $_[1] if defined $_[1];
    $_[0]->{port};
}

sub password {
    carp "password() is $DEP";
    $_[0]->{password} = $_[1] if defined $_[1];
    $_[0]->{password};
}

#
# Private helpers
#

# Increment and return the next request ID, wrapping at 2**31-1
sub _next_id { $_[0]->{request_id} = ($_[0]->{request_id} + 1) % 2**31 }

# Form and send a packet of the specified type, request_id and payload
sub _send_encode {
    my ($s, $type, $id, $payload) = @_;
    confess "Request ID `$id' is not an integer" unless $id =~ /^\d+$/;
    $payload = "" unless defined $payload;
    my $data = pack('V!V' => $id, $type) . $payload . "\0\0";
    $s->{socket}->send(pack(V => length $data) . $data);

}

# Grab a single packet.
sub _recv_decode {
    my ($s) = @_;
    confess "_recv_decode when not connected" unless $s->connected;

    local $_; $s->{socket}->recv($_, 4);
    my $size = unpack 'V';
    $_ = '';
    my $frags = 0;

    croak "Zero length packet" unless $size;

    while ($size > length) {
        my $buf;
        $s->{socket}->recv($buf, $size);
        $_ .= $buf;
        $frags++;
    }

    croak 'Packet too short. ' . length($_) . ' < 10' if 10 > length($_);
    croak "Received packet missing terminator" unless s/\0\0$//;

    $size, unpack 'V!V(A*)';
}

1;