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


line stmt bran cond sub pod time code
1             # Minecraft::RCON - RCON remote console for Minecraft
2             #
3             # 1.x and above by Ryan Thompson
4             #
5             # Original (0.1.x) by Fredrik Vold, no copyrights, no rights reserved.
6             # This is absolutely free software, and you can do with it as you please.
7             # If you do derive your own work from it, however, it'd be nice with some
8             # credits to me somewhere in the comments of that work.
9             #
10             # Based on http:://wiki.vg/RCON documentation
11              
12             package Minecraft::RCON;
13              
14             our $VERSION = '1.02';
15              
16 9     9   955134 use 5.010;
  9         78  
17 9     9   52 use strict;
  9         17  
  9         229  
18 9     9   46 use warnings;
  9         17  
  9         281  
19 9     9   46 no warnings 'uninitialized';
  9         16  
  9         477  
20              
21 9     9   6093 use Term::ANSIColor 3.01;
  9         79141  
  9         663  
22 9     9   1822 use IO::Socket 1.18; # autoflush
  9         67534  
  9         54  
23 9     9   4133 use Carp;
  9         20  
  9         701  
24              
25             use constant {
26             # Packet types
27 9         18428 AUTH => 3, # Minecraft RCON login packet type
28             AUTH_RESPONSE => 2, # Server auth response
29             AUTH_FAIL => -1, # Auth failure (password invalid)
30             COMMAND => 2, # Command packet type
31             RESPONSE_VALUE => 0, # Server response
32 9     9   66 };
  9         19  
33              
34             # Minecraft -> ANSI color map
35             my %COLOR = map { $_->[1] => color($_->[0]) } (
36             [black => '0'], [blue => '1'], [green => '2'],
37             [cyan => '3'], [red => '4'], [magenta => '5'],
38             [yellow => '6'], [white => '7'], [bright_black => '8'],
39             [bright_blue => '9'], [bright_green => 'a'], [bright_cyan => 'b'],
40             [bright_red => 'c'], [bright_magenta => 'd'], [yellow => 'e'],
41             [bright_white => 'f'],
42             [bold => 'l'], [concealed => 'm'], [underline => 'n'],
43             [reverse => 'o'], [reset => 'r'],
44             );
45              
46             # Defaults for new objects. Override in constructor or with accessors.
47             sub _DEFAULTS(%) {
48             (
49 29     29   199 address => '127.0.0.1',
50             port => 25575,
51             password => '',
52             color_mode => 'strip',
53             request_id => 0,
54              
55             # DEPRECATED options
56             strip_color => undef,
57             convert_color => undef,
58              
59             @_, # Subclasses may override
60             );
61             }
62              
63             # DEPRECATED warning text for convenience/consistency
64             my $DEP = 'deprecated and will be removed in a future release.';
65              
66             sub new {
67 29     29 1 43306 my $class = shift;
68 29 100       122 my %opts = 'HASH' eq ref $_[0] ? %{$_[0]} : @_;
  21         86  
69 29         155 my %DEFAULTS = _DEFAULTS();
70              
71             # DEPRECATED -- Warn and transition to new option
72 29 100       102 if ($opts{convert_color}) {
73 1         13 carp "convert_color $DEP\nConverted to color_mode => 'convert'.";
74 1         183 $opts{color_mode} = 'convert';
75             }
76 29 100       69 if ($opts{strip_color}) {
77 1         25 carp "strip_color $DEP\nConverted to color_mode => 'strip'.";
78 1         287 $opts{color_mode} = 'strip';
79             }
80              
81 29         107 my @unknowns = grep { not exists $DEFAULTS{$_} } sort keys %opts;
  28         97  
82 29 100       140 carp "Ignoring unknown option(s): " . join(', ', @unknowns) if @unknowns;
83              
84 29         633 bless { %DEFAULTS, %opts }, $class;
85             }
86              
87             sub connect {
88 18     18 1 1162 my ($s) = @_;
89              
90 18 50       42 return 1 if $s->connected;
91              
92 18 100       65 croak 'Password required' unless length $s->{password};
93              
94             $s->{socket} = IO::Socket::INET->new(
95             PeerAddr => $s->{address},
96             PeerPort => $s->{port},
97 17 100       58 Proto => 'tcp',
98             ) or croak "Connection to $s->{address}:$s->{port} failed: .$!";
99              
100 16         228 my $id = $s->_next_id;
101 16         50 $s->_send_encode(AUTH, $id, $s->{password});
102 16         1286 my ($size,$res_id,$type,$payload) = $s->_recv_decode;
103              
104             # Force a reconnect if we're about to error out
105 16 100 100     79 $s->disconnect unless $type == AUTH_RESPONSE and $id == $res_id;
106              
107 16 100       50 croak 'RCON authentication failed' if $res_id == AUTH_FAIL;
108 15 100       43 croak "Expected AUTH_RESPONSE(2), got $type" if $type != AUTH_RESPONSE;
109 14 100       43 croak "Expected ID $id, got $res_id" if $id != $res_id;
110 13 100       49 croak "Non-blank payload <$payload>" if length $payload;
111              
112 12         55 return 1;
113             }
114              
115 111 100   111 1 476 sub connected { $_[0]->{socket} and $_[0]->{socket}->connected }
116              
117             sub disconnect {
118 46 100   46 1 1444 $_[0]->{socket}->shutdown(2) if $_[0]->connected;
119 46 100       264 delete $_[0]->{socket} if exists $_[0]->{socket};
120 46         742 1;
121             }
122              
123             sub command {
124 10     10 1 699 my ($s, $command, $mode) = @_;
125              
126 10 100       42 croak 'Command required' unless length $command;
127 9 100       23 croak 'Not connected' unless $s->connected;
128              
129 8         47 my $id = $s->_next_id;
130 8         105 my $nonce = 16 + int rand(2 ** 15 - 16); # Avoid 0..15
131 8         26 $s->_send_encode(COMMAND, $id, $command);
132 8         1093 $s->_send_encode($nonce, $id, 'nonce');
133              
134 8         749 my $res = '';
135 8         14 while (1) {
136 19         42 my ($size,$res_id,$type,$payload) = $s->_recv_decode;
137 19 50       51 if ($id != $res_id) {
138 0         0 $s->disconnect;
139 0         0 croak sprintf(
140             "Desync. Expected %d (0x%4x), got %d (0x%4x). Disconnected.",
141             $id, $id, $res_id, $res_id
142             );
143             }
144 19 50       35 croak "size:$size id:$id got type $type, not RESPONSE_VALUE(0)"
145             if $type != RESPONSE_VALUE;
146 19 100       77 last if $payload eq sprintf 'Unknown request %x', $nonce;
147 11         29 $res .= $payload;
148             }
149              
150 8 50       32 $s->color_convert($res, defined $mode ? $mode : $s->{color_mode});
151             }
152              
153             sub color_mode {
154 60     60 1 3111 my ($s, $mode, $code) = @_;
155 60 100       188 return $s->{color_mode} if not defined $mode;
156 49 100       287 croak 'Invalid color mode.'
157             unless $mode =~ /^(strip|convert|ignore)$/;
158              
159 47 100       110 if ($code) {
160 1         3 my $was = $s->{color_mode};
161 1         2 $s->{color_mode} = $mode;
162 1         4 $code->();
163 1         537 $s->{color_mode} = $was;
164             } else {
165 46         123 $s->{color_mode} = $mode;
166             }
167             }
168              
169             sub color_convert {
170 63     63 1 231 my ($s, $text, $mode) = @_;
171 63 100       137 $mode = $s->{color_mode} if not defined $mode;
172 63         192 my $re = qr/\x{00A7}(.)/o;
173              
174 63 100       270 $text =~ s/$re//g if $mode eq 'strip';
175 63 100       205 $text =~ s/$re/$COLOR{$1}/g if $mode eq 'convert';
176 63 100 100     184 $text .= $COLOR{r} if $mode eq 'convert' and $text =~ /\e\[/;
177              
178 63         236 $text;
179             }
180              
181 29     29   26586 sub DESTROY { $_[0]->disconnect }
182              
183             #
184             # DEPRECATED methods
185             #
186              
187             sub convert_color {
188 2     2 1 1201 my ($s, $val) = @_;
189 2         32 carp "convert_color() is $DEP\nUse color_mode('convert') instead";
190 2 100       506 $s->color_mode('convert') if $val;
191              
192 2         7 $s->color_mode eq 'convert';
193             }
194              
195             sub strip_color {
196 2     2 1 891 my ($s, $val) = @_;
197 2         23 carp "strip_color() is $DEP\nUse color_mode('strip') instead";
198 2 100       362 $s->color_mode('strip') if $val;
199              
200 2         5 $s->color_mode eq 'strip';
201             }
202              
203             sub address {
204 2     2 1 1104 carp "address() is $DEP";
205 2 100       368 $_[0]->{address} = $_[1] if defined $_[1];
206 2         6 $_[0]->{address};
207             }
208              
209             sub port {
210 2     2 1 2249 carp "port() is $DEP";
211 2 100       358 $_[0]->{port} = $_[1] if defined $_[1];
212 2         6 $_[0]->{port};
213             }
214              
215             sub password {
216 2     2 1 2190 carp "password() is $DEP";
217 2 100       362 $_[0]->{password} = $_[1] if defined $_[1];
218 2         6 $_[0]->{password};
219             }
220              
221             #
222             # Private helpers
223             #
224              
225             # Increment and return the next request ID, wrapping at 2**31-1
226 32     32   687 sub _next_id { $_[0]->{request_id} = ($_[0]->{request_id} + 1) % 2**31 }
227              
228             # Form and send a packet of the specified type, request_id and payload
229             sub _send_encode {
230 32     32   69 my ($s, $type, $id, $payload) = @_;
231 32 50       189 confess "Request ID `$id' is not an integer" unless $id =~ /^\d+$/;
232 32 50       76 $payload = "" unless defined $payload;
233 32         133 my $data = pack('V!V' => $id, $type) . $payload . "\0\0";
234 32         127 $s->{socket}->send(pack(V => length $data) . $data);
235              
236             }
237              
238             # Grab a single packet.
239             sub _recv_decode {
240 35     35   62 my ($s) = @_;
241 35 50       67 confess "_recv_decode when not connected" unless $s->connected;
242              
243 35         176 local $_; $s->{socket}->recv($_, 4);
  35         103  
244 35         593 my $size = unpack 'V';
245 35         58 $_ = '';
246 35         50 my $frags = 0;
247              
248 35 50       71 croak "Zero length packet" unless $size;
249              
250 35         72 while ($size > length) {
251 35         56 my $buf;
252 35         103 $s->{socket}->recv($buf, $size);
253 35         490 $_ .= $buf;
254 35         82 $frags++;
255             }
256              
257 35 50       77 croak 'Packet too short. ' . length($_) . ' < 10' if 10 > length($_);
258 35 50       169 croak "Received packet missing terminator" unless s/\0\0$//;
259              
260 35         180 $size, unpack 'V!V(A*)';
261             }
262              
263             1;
264              
265             __END__