3 # Copyright (c) 2008 Rudolf "divVerent" Polzer
5 # Permission is hereby granted, free of charge, to any person
6 # obtaining a copy of this software and associated documentation
7 # files (the "Software"), to deal in the Software without
8 # restriction, including without limitation the rights to use,
9 # copy, modify, merge, publish, distribute, sublicense, and/or sell
10 # copies of the Software, and to permit persons to whom the
11 # Software is furnished to do so, subject to the following
14 # The above copyright notice and this permission notice shall be
15 # included in all copies or substantial portions of the Software.
17 # THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
18 # EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
19 # OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
20 # NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
21 # HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
22 # WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
23 # FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
24 # OTHER DEALINGS IN THE SOFTWARE.
26 # parts copied from rcon2irc
27 # MISC STRING UTILITY ROUTINES to convert between DarkPlaces and IRC conventions
29 # convert mIRC color codes to DP color codes
30 our @color_irc2dp_table = (7, 0, 4, 2, 1, 1, 6, 1, 3, 2, 5, 5, 4, 6, 7, 7);
31 our @color_dp2irc_table = (-1, 4, 9, 8, 12, 11, 13, -1, -1, -1); # not accurate, but legible
32 our @color_dp2ansi_table = ("m", "1;31m", "1;32m", "1;33m", "1;34m", "1;36m", "1;35m", "m", "1m", "1m"); # not accurate, but legible
33 our %color_team2dp_table = (5 => 1, 14 => 4, 13 => 3, 10 => 6);
34 our %color_team2irc_table = (5 => 4, 14 => 12, 13 => 8, 10 => 13);
38 $message =~ s/\^/^^/g;
40 $message =~ s{\003(\d\d?)(?:,(\d?\d?))?|(\017)}{
41 # $1 is FG, $2 is BG, but let's ignore BG
42 my $oldcolor = $color;
49 $color = $color_irc2dp_table[$1];
50 $color = $oldcolor if not defined $color;
52 ($color == $oldcolor) ? '' : '^' . $color;
54 $message =~ s{[\000-\037]}{}gs; # kill bold etc. for now
58 our @text_qfont_table = ( # ripped from DP console.c qfont_table
59 "\0", '#', '#', '#', '#', '.', '#', '#',
60 '#', 9, 10, '#', ' ', 13, '.', '.',
61 '[', ']', '0', '1', '2', '3', '4', '5',
62 '6', '7', '8', '9', '.', '<', '=', '>',
63 ' ', '!', '"', '#', '$', '%', '&', '\'',
64 '(', ')', '*', '+', ',', '-', '.', '/',
65 '0', '1', '2', '3', '4', '5', '6', '7',
66 '8', '9', ':', ';', '<', '=', '>', '?',
67 '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
68 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
69 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
70 'X', 'Y', 'Z', '[', '\\', ']', '^', '_',
71 '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',
72 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
73 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
74 'x', 'y', 'z', '{', '|', '}', '~', '<',
75 '<', '=', '>', '#', '#', '.', '#', '#',
76 '#', '#', ' ', '#', ' ', '>', '.', '.',
77 '[', ']', '0', '1', '2', '3', '4', '5',
78 '6', '7', '8', '9', '.', '<', '=', '>',
79 ' ', '!', '"', '#', '$', '%', '&', '\'',
80 '(', ')', '*', '+', ',', '-', '.', '/',
81 '0', '1', '2', '3', '4', '5', '6', '7',
82 '8', '9', ':', ';', '<', '=', '>', '?',
83 '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
84 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
85 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
86 'X', 'Y', 'Z', '[', '\\', ']', '^', '_',
87 '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',
88 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
89 'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
90 'x', 'y', 'z', '{', '|', '}', '~', '<'
95 $message = join '', map { $text_qfont_table[ord $_] } split //, $message;
98 sub color_dp_transform(&$)
100 my ($block, $message) = @_;
102 $message =~ s{(?:(\^\^)|\^x([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])|\^([0-9])|(.))(?=([0-9,]?))}{
103 defined $1 ? $block->(char => '^', $7) :
104 defined $2 ? $block->(rgb => [hex $2, hex $3, hex $4], $7) :
105 defined $5 ? $block->(color => $5, $7) :
106 defined $6 ? $block->(char => $6, $7) :
117 return color_dp_transform
119 my ($type, $data, $next) = @_;
121 ? $text_qfont_table[ord $data]
127 sub color_rgb2basic($)
130 my ($R, $G, $B) = @$data;
131 my $min = [sort { $a <=> $b } ($R, $G, $B)]->[0];
132 my $max = [sort { $a <=> $b } ($R, $G, $B)]->[-1];
135 my $s = ($max == $min) ? 0 : 1 - $min/$max;
139 return 0 if $v < 0.5;
150 $h = (60 * ($G - $B) / ($max - $min)) % 360;
154 $h = (60 * ($B - $R) / ($max - $min)) + 120;
158 $h = (60 * ($R - $G) / ($max - $min)) + 240;
163 return 2 if $h < 150;
164 return 5 if $h < 200;
165 return 4 if $h < 270;
166 return 6 if $h < 330;
170 sub color_dp_rgb2basic($)
173 return color_dp_transform
175 my ($type, $data, $next) = @_;
176 $type eq 'char' ? ($data eq '^' ? '^^' : $data) :
177 $type eq 'color' ? "^$data" :
178 $type eq 'rgb' ? "^" . color_rgb2basic $data :
188 return color_dp_transform
190 my ($type, $data, $next) = @_;
195 $data = color_rgb2basic $data;
198 $type eq 'char' ? $text_qfont_table[ord $data] :
199 $type eq 'color' ? do {
200 my $oldcolor = $color;
201 $color = $color_dp2irc_table[$data];
203 $color == $oldcolor ? '' :
204 $color < 0 ? "\017" :
205 (index '0123456789,', $next) >= 0 ? "\003$color\002\002" :
217 return color_dp_transform
219 my ($type, $data, $next) = @_;
224 $data = color_rgb2basic $data;
227 $type eq 'char' ? $text_qfont_table[ord $data] :
228 $type eq 'color' ? do {
229 my $oldcolor = $color;
230 $color = $color_dp2ansi_table[$data];
232 $color eq $oldcolor ? '' :
243 # if the message ends with an odd number of ^, kill one
244 chop $message if $message =~ /(?:^|[^\^])\^(\^\^)*$/;
253 # $conn->sockname() returns a connection type specific representation
254 # string of the local address, or undef if not applicable.
255 # $conn->send("string") sends something over the connection.
256 # $conn->recv() receives a string from the connection, or returns "" if no
258 # $conn->fds() returns all file descriptors used by the connection, so one
259 # can use select() on them.
261 # Usually wraps around a connection and implements a command based
262 # structure over it. It usually is constructed using new
263 # ChannelType($connection, someparameters...)
264 # @cmds = $chan->join_commands(@cmds) joins multiple commands to a single
265 # command string if the protocol supports it, or does nothing and leaves
266 # @cmds unchanged if the protocol does not support that usage (this is
267 # meant to save send() invocations).
268 # $chan->send($command, $nothrottle) sends a command over the channel. If
269 # $nothrottle is sent, the command must not be left out even if the channel
270 # is saturated (for example, because of IRC's flood control mechanism).
271 # $chan->quote($str) returns a string in a quoted form so it can safely be
272 # inserted as a substring into a command, or returns $str as is if not
273 # applicable. It is assumed that the result of the quote method is used
274 # as part of a quoted string, if the protocol supports that.
275 # $chan->recv() returns a list of received commands from the channel, or
276 # the empty list if none are available.
277 # $conn->fds() returns all file descriptors used by the channel's
278 # connections, so one can use select() on them.
287 # Represents a connection over a socket.
288 # Mainly used to wrap a channel around it for, in this case, line based or rcon-like operation.
289 package Connection::Socket;
292 use IO::Socket::INET;
296 # my $conn = new Connection::Socket(tcp => "localaddress" => "remoteaddress" => 6667);
297 # If the remote address does not contain a port number, the numeric port is
298 # used (it serves as a default port).
301 my ($class, $proto, $local, $remote, $defaultport) = @_;
302 my $sock = IO::Socket::INET->new(
304 (length($local) ? (LocalAddr => $local) : ()),
306 PeerPort => $defaultport
307 ) or die "socket $proto/$local/$remote/$defaultport: $!";
310 # Mortal fool! Release me from this wretched tomb! I must be set free
311 # or I will haunt you forever! I will hide your keys beneath the
312 # cushions of your upholstered furniture... and NEVERMORE will you be
313 # able to find socks that match!
315 # My demonic powers have made me OMNIPOTENT! Bwahahahahahahaha!
318 bless $you, 'Connection::Socket';
321 # $sock->sockname() returns the local address of the socket.
325 my ($port, $addr) = sockaddr_in $self->{sock}->sockname();
326 return "@{[inet_ntoa $addr]}:$port";
329 # $sock->send($data) sends some data over the socket; on success, 1 is returned.
332 my ($self, $data) = @_;
335 if(not eval { $self->{sock}->send($data); })
343 # $sock->recv() receives as much as possible from the socket (or at most 32k). Returns "" if no data is available.
348 if(defined $self->{sock}->recv($data, 32768, 0))
362 # $sock->fds() returns the socket file descriptor.
366 return fileno $self->{sock};
375 # QW rcon protocol channel.
376 # Wraps around a UDP based Connection and sends commands as rcon commands as
377 # well as receives rcon replies. The quote and join_commands methods are using
378 # DarkPlaces engine specific rcon protocol extensions.
386 # my $chan = new Channel::QW($connection, "password");
389 my ($class, $conn, $password, $secure, $timeout) = @_;
392 password => $password,
398 bless $you, 'Channel::QW';
401 # Note: multiple commands in one rcon packet is a DarkPlaces extension.
402 sub join_commands($@)
404 my ($self, @data) = @_;
405 return join "\0", @data;
410 my ($self, $line, $nothrottle) = @_;
411 if($self->{secure} > 1)
413 $self->{connector}->send("\377\377\377\377getchallenge");
414 my $c = $self->recvchallenge();
415 return 0 if not defined $c;
416 my $key = Digest::HMAC::hmac("$c $line", $self->{password}, \&Digest::MD4::md4);
417 return $self->{connector}->send("\377\377\377\377srcon HMAC-MD4 CHALLENGE $key $c $line");
419 elsif($self->{secure})
421 my $t = sprintf "%ld.%06d", time(), int rand 1000000;
422 my $key = Digest::HMAC::hmac("$t $line", $self->{password}, \&Digest::MD4::md4);
423 return $self->{connector}->send("\377\377\377\377srcon HMAC-MD4 TIME $key $t $line");
427 return $self->{connector}->send("\377\377\377\377rcon $self->{password} $line");
431 # Note: backslash and quotation mark escaping is a DarkPlaces extension.
434 my ($self, $data) = @_;
435 $data =~ s/[\000-\037]//g;
436 $data =~ s/([\\"])/\\$1/g;
437 $data =~ s/\$/\$\$/g;
445 my $sel = IO::Select->new($self->fds());
446 my $endtime_max = Time::HiRes::time() + $self->{timeout};
447 my $endtime = $endtime_max;
449 while((my $dt = $endtime - Time::HiRes::time()) > 0)
451 if($sel->can_read($dt))
455 my $s = $self->{connector}->recv();
460 if($s =~ /^\377\377\377\377challenge (.*)$/s)
465 if $s !~ /^\377\377\377\377n(.*)$/s;
466 $self->{recvbuf} .= $1;
478 my $s = $self->{connector}->recv();
484 if $s !~ /^\377\377\377\377n(.*)$/s;
485 $self->{recvbuf} .= $1;
488 while($self->{recvbuf} =~ s/^(.*?)(?:\r\n?|\n)//)
498 return $self->{connector}->fds();
515 my ($default, $value) = @_;
516 return $value if defined $value;
520 my $server = default '', $ENV{rcon_address};
521 my $password = default '', $ENV{rcon_password};
522 my $secure = default '1', $ENV{rcon_secure};
523 my $timeout = default '5', $ENV{rcon_timeout};
524 my $timeouti = default '0.2', $ENV{rcon_timeout_inter};
525 my $timeoutc = default $timeout, $ENV{rcon_timeout_challenge};
526 my $colors = default '0', $ENV{rcon_colorcodes_raw};
530 print STDERR "Usage: rcon_address=SERVERIP:PORT rcon_password=PASSWORD $0 rconcommands...\n";
531 print STDERR "Optional: rcon_timeout=... (default: 5)\n";
532 print STDERR " rcon_timeout_inter=... (default: 0.2)\n";
533 print STDERR " rcon_timeout_challenge=... (default: 5)\n";
534 print STDERR " rcon_colorcodes_raw=1 (to disable color codes translation)\n";
535 print STDERR " rcon_secure=0 (to allow connecting to older servers not supporting secure rcon)\n";
539 my $connection = Connection::Socket->new("udp", "", $server, 26000);
540 my $rcon = Channel::QW->new($connection, $password, $secure, $timeoutc);
542 if(!$rcon->send($rcon->join_commands(@ARGV)))
549 my $sel = IO::Select->new($rcon->fds());
550 my $endtime_max = Time::HiRes::time() + $timeout;
551 my $endtime = $endtime_max;
553 while((my $dt = $endtime - Time::HiRes::time()) > 0)
555 if($sel->can_read($dt))
559 $_ = (color_dp2ansi $_) . "\033[m" unless $colors;
562 $endtime = Time::HiRes::time() + $timeouti;
563 $endtime = $endtime_max
564 if $endtime > $endtime_max;