File Coverage

blib/lib/Net/RCON/Minecraft.pm
Criterion Covered Total %
statement 90 90 100.0
branch 40 40 100.0
condition 6 6 100.0
subroutine 16 16 100.0
pod 4 4 100.0
total 156 156 100.0


line stmt bran cond sub pod time code
1             # Minecraft implementation of the RCON protocol.
2              
3             package Net::RCON::Minecraft;
4              
5 11     11   830188 use 5.008;
  11         77  
6              
7 11     11   4800 use Mouse;
  11         297359  
  11         50  
8 11     11   4329 use Mouse::Util::TypeConstraints;
  11         27  
  11         44  
9 11     11   6627 use Net::RCON::Minecraft::Response;
  11         1026  
  11         410  
10 11     11   2979 use IO::Socket::IP;
  11         162799  
  11         83  
11 11     11   7830 use IO::Select;
  11         7675  
  11         521  
12 11     11   66 use Carp;
  11         21  
  11         606  
13              
14 11     11   64 no warnings 'uninitialized';
  11         20  
  11         717  
15              
16             our $VERSION = '0.02';
17              
18             use constant {
19             # Packet types
20 11         13504 AUTH => 3, # Minecraft RCON login packet type
21             AUTH_RESPONSE => 2, # Server auth response
22             AUTH_FAIL => -1, # Auth failure (password invalid)
23             COMMAND => 2, # Command packet type
24             RESPONSE_VALUE => 0, # Server response
25 11     11   100 };
  11         18  
26              
27             class_type 'IP' => { class => 'IO::Socket::IP' };
28              
29             has host => ( is => 'ro', default => 'localhost', isa => 'Str' );
30             has port => ( is => 'ro', default => 25575, isa => 'Int' );
31             has password => ( is => 'ro', default => '', isa => 'Str' );
32             has timeout => ( is => 'rw', default => 30, isa => 'Num' );
33             has _select => ( is => 'ro', default => sub { IO::Select->new } );
34             has _socket => ( is => 'rw', default => undef, isa => 'Maybe[IP]' );
35             has _next_id => ( is => 'rw', default => 1, isa => 'Int' );
36              
37             after _next_id => sub { $_[0]->{_next_id} = ($_[0]->{_next_id} + 1) % 2**31 };
38              
39             sub connect {
40 33     33 1 4141 my ($s) = @_;
41              
42 33 100       72 return 1 if $s->connected;
43              
44 32 100       143 croak 'Password required' unless length $s->password;
45              
46 30 100       140 $s->_socket(IO::Socket::IP->new(
47             PeerAddr => $s->host,
48             PeerPort => $s->port,
49             Proto => 'tcp',
50 1         12 )) or croak "Connection to @{[$s->host]}:@{[$s->port]} failed: $!";
  1         29  
51              
52 29         541 $s->_socket->autoflush(1);
53 29         163 $s->_select->remove($s->_select->handles);
54 29         290 $s->_select->add($s->_socket);
55              
56 29         152 my $id = $s->_next_id(1);
57 29         192 $s->_send_encode(AUTH, $id, $s->password);
58 29         69 my ($size,$res_id,$type,$payload) = $s->_read_decode;
59              
60             # Force a reconnect if we're about to error out
61 28 100 100     180 $s->disconnect unless $type == AUTH_RESPONSE and $id == $res_id;
62              
63 28 100       75 croak "RCON authentication failed" if $res_id == AUTH_FAIL;
64 27 100       96 croak "Expected AUTH_RESPONSE(2), got $type" if $type != AUTH_RESPONSE;
65 24 100       71 croak "Expected ID $id, got $res_id" if $id != $res_id;
66 23 100       61 croak "Non-blank payload <$payload>" if length $payload;
67              
68 22         52 return 1;
69             }
70              
71             sub disconnect {
72 13     13 1 348 my $s = shift;
73 13 100 100     69 $s->_socket->shutdown(2) if $s->_socket and $s->_socket->connected;
74 13         113 1;
75             }
76              
77 37 100   37 1 194 sub connected { $_[0]->_socket and $_[0]->_socket->connected }
78              
79             sub command {
80 16     16 1 516 my ($s, $command, $mode) = @_;
81              
82 16 100       78 croak 'Command required' unless length $command;
83 15         42 $s->connect;
84              
85 15         43 my $id = $s->_next_id;
86 15         185 my $nonce = 16 + int rand(2**15 - 16); # Extra insurance
87 15         46 $s->_send_encode(COMMAND, $id, $command);
88 15         41 $s->_send_encode($nonce, $id, 'nonce');
89              
90 15         28 my $raw = '';
91 15         26 while (1) {
92 31         68 my ($size,$res_id,$type,$payload) = $s->_read_decode;
93 31 100       79 if ($id != $res_id) {
94 1         12 $s->disconnect;
95 1         18 croak sprintf(
96             'Desync. Expected %d (0x%04x), got %d (0x%04x). Disconnected.',
97             $id, $id, $res_id, $res_id
98             );
99             }
100 30 100       75 croak "size:$size id:$id got type $type, not RESPONSE_VALUE(0)"
101             if $type != RESPONSE_VALUE;
102 29 100       102 last if $payload eq sprintf 'Unknown request %x', $nonce;
103 16         37 $raw .= $payload;
104             }
105              
106 13         34 $raw =~ s!\r\n!\n!g; # \R would be nice, but requires 5.010
107              
108 13         268 Net::RCON::Minecraft::Response->new(raw => $raw, id => $id);
109             }
110              
111             sub DESTROY { $_[0]->disconnect }
112              
113             #
114             # Private methods -- Not for external use
115             #
116              
117             # Grab a complete response from the Minecraft server and decode it,
118             # returning $id, $type, and $payload
119             sub _read_decode {
120 65     65   2562 my ($s) = @_;
121              
122 65         129 local $_ = $s->_read_with_timeout(4);
123              
124 62         145 my $size = unpack 'V';
125              
126 62 100       149 croak 'Packet too short. Size field = ' . $size . ' (10 is smallest)'
127             if $size < 10;
128              
129 61         120 $_ = $s->_read_with_timeout($size);
130              
131 60 100       316 croak 'Server response missing terminator' unless s/\0\0$//;
132              
133 59         309 $size, unpack 'V!V(A*)';
134             }
135              
136             # Read with timeout. Implemented with select. Guarantees either $len bytes are
137             # read, or we croak() trying. Returns the bytes read.
138             sub _read_with_timeout {
139 126     126   217 my ($s, $len) = @_;
140              
141 126         179 my $ret = '';
142              
143 126         264 while ($len > length $ret) {
144 127 100       389 if ($s->_select->can_read($s->timeout)) {
145 124         668 my $buf = '';
146 124         322 my $read = $s->_socket->sysread($buf, $len - length $ret);
147 124 100       1566 croak "Socket read error: $!" if not defined $read;
148 123         337 $ret .= $buf;
149             } else {
150 3         19 $s->disconnect;
151 3         38 croak "Server timeout. Got " .length($ret)."/".$len." bytes";
152             }
153             }
154              
155 122         240 $ret;
156             }
157              
158             # Form and send a packet of the specified $type, $req_id and $payload
159             sub _send_encode {
160 61     61   229 my ($s, $type, $id, $payload) = @_;
161 61 100       139 $payload = "" unless defined $payload;
162 61         219 my $data = pack('V!V' => $id, $type) . $payload . "\0\0";
163 61         98 eval { $s->_socket->send(pack(V => length $data) . $data) };
  61         234  
164 61 100       5064 croak "Socket write failed: $@" if $@;
165              
166             }
167              
168             __PACKAGE__->meta->make_immutable();