Docs/server/rcon.pl

   1 #!/usr/bin/perl
   2
   3 # Copyright (c) 2008 Rudolf "divVerent" Polzer
   4 #
   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
  12 # conditions:
  13 #
  14 # The above copyright notice and this permission notice shall be
  15 # included in all copies or substantial portions of the Software.
  16 #
  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.
  25
  26
  27 # parts copied from rcon2irc
  28
  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 = (14, 4, 9, 8, 12, 11, 13, 14, 15, 15); # 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);
  35 sub color_irc2dp($)
  36 {
  37         my ($message) = @_;
  38         $message =~ s/\^/^^/g;
  39         my $color = 7;
  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;
  43                 if($3)
  44                 {
  45                         $color = 7;
  46                 }
  47                 else
  48                 {
  49                         $color = $color_irc2dp_table[$1];
  50                         $color = $oldcolor if not defined $color;
  51                 }
  52                 ($color == $oldcolor) ? '' : '^' . $color;
  53         }esg;
  54         $message =~ s{[\000-\037]}{}gs; # kill bold etc. for now
  55         return $message;
  56 }
  57
  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',  '{',  '|',  '}',  '~',  '<'
  91 );
  92 sub text_dp2ascii($)
  93 {
  94         my ($message) = @_;
  95         $message = join '', map { $text_qfont_table[ord $_] } split //, $message;
  96 }
  97
  98 sub color_dp2none($)
  99 {
 100         my ($message) = @_;
 101         my $color = -1;
 102         $message =~ s{\^(.)(?=([0-9,]?))}{
 103                 my $c = $1;
 104                 $c eq '^' ? '^' :
 105                 $c =~ /^[0-9]$/ ? '' : "^$c";
 106         }esg;
 107         return text_dp2ascii $message;
 108 }
 109
 110 sub color_dp2irc($)
 111 {
 112         my ($message) = @_;
 113         my $color = -1;
 114         $message =~ s{\^(.)(?=([0-9,]?))}{
 115                 my $c = $1;
 116                 my $f = $2;
 117                 $c eq '^' ? '^' :
 118                 $c =~ /^[0-9]$/ ? do {
 119                         my $oldcolor = $color;
 120                         $c = 0 if $c >= 7; # map 0, 7, 8, 9 to default (no bright white or such stuff)
 121                         $color = $color_dp2irc_table[$c];
 122                         ($color == $oldcolor) ? '' :
 123                         $c == 0 ? "\0001" :
 124                         $f eq ',' ? "\0003$color\0002\0002" :
 125                         $f ne ''  ? sprintf "\0003%02d", $color : "\0003$color";
 126                 } : "^$c";
 127         }esg;
 128         $message = text_dp2ascii $message;
 129         $message =~ s/\0001/\017/g;
 130         $message =~ s/\0002/\002/g;
 131         $message =~ s/\0003/\003/g;
 132         return $message;
 133 }
 134
 135 sub color_dp2ansi($)
 136 {
 137         my ($message) = @_;
 138         my $color = -1;
 139         $message =~ s{\^(.)}{
 140                 my $c = $1;
 141                 $c eq '^' ? '^' :
 142                 $c =~ /^[0-9]$/ ? do {
 143                         my $oldcolor = $color;
 144                         $color = $color_dp2ansi_table[$c];
 145                         ($color eq $oldcolor) ? '' :
 146                         "\000[${color}" # "
 147                 } : "^$c";
 148         }esg;
 149         $message = text_dp2ascii $message;
 150         $message =~ s/\000/\033/g;
 151         return $message;
 152 }
 153
 154 sub color_dpfix($)
 155 {
 156         my ($message) = @_;
 157         # if the message ends with an odd number of ^, kill one
 158         chop $message if $message =~ /(?:^|[^\^])\^(\^\^)*$/;
 159         return $message;
 160 }
 161
 162
 163
 164 # Interfaces:
 165 #   Connection:
 166 #     $conn->sockname() returns a connection type specific representation
 167 #       string of the local address, or undef if not applicable.
 168 #     $conn->send("string") sends something over the connection.
 169 #     $conn->recv() receives a string from the connection, or returns "" if no
 170 #       data is available.
 171 #     $conn->fds() returns all file descriptors used by the connection, so one
 172 #       can use select() on them.
 173 #   Channel:
 174 #     Usually wraps around a connection and implements a command based
 175 #     structure over it. It usually is constructed using new
 176 #     ChannelType($connection, someparameters...)
 177 #     @cmds = $chan->join_commands(@cmds) joins multiple commands to a single
 178 #       command string if the protocol supports it, or does nothing and leaves
 179 #       @cmds unchanged if the protocol does not support that usage (this is
 180 #       meant to save send() invocations).
 181 #     $chan->send($command, $nothrottle) sends a command over the channel. If
 182 #       $nothrottle is sent, the command must not be left out even if the channel
 183 #       is saturated (for example, because of IRC's flood control mechanism).
 184 #     $chan->quote($str) returns a string in a quoted form so it can safely be
 185 #       inserted as a substring into a command, or returns $str as is if not
 186 #       applicable. It is assumed that the result of the quote method is used
 187 #       as part of a quoted string, if the protocol supports that.
 188 #     $chan->recv() returns a list of received commands from the channel, or
 189 #       the empty list if none are available.
 190 #     $conn->fds() returns all file descriptors used by the channel's
 191 #       connections, so one can use select() on them.
 192
 193
 194
 195
 196
 197
 198
 199 # Socket connection.
 200 # Represents a connection over a socket.
 201 # Mainly used to wrap a channel around it for, in this case, line based or rcon-like operation.
 202 package Connection::Socket;
 203 use strict;
 204 use warnings;
 205 use IO::Socket::INET;
 206 use IO::Handle;
 207
 208 # Constructor:
 209 #   my $conn = new Connection::Socket(tcp => "localaddress" => "remoteaddress" => 6667);
 210 # If the remote address does not contain a port number, the numeric port is
 211 # used (it serves as a default port).
 212 sub new($$)
 213 {
 214         my ($class, $proto, $local, $remote, $defaultport) = @_;
 215         my $sock = IO::Socket::INET->new(
 216                 Proto => $proto,
 217                 (length($local) ? (LocalAddr => $local) : ()),
 218                 PeerAddr => $remote,
 219                 PeerPort => $defaultport
 220         ) or die "socket $proto/$local/$remote: $!";
 221         $sock->blocking(0);
 222         my $you = {
 223                 # Mortal fool! Release me from this wretched tomb! I must be set free
 224                 # or I will haunt you forever! I will hide your keys beneath the
 225                 # cushions of your upholstered furniture... and NEVERMORE will you be
 226                 # able to find socks that match!
 227                 sock => $sock,
 228                 # My demonic powers have made me OMNIPOTENT! Bwahahahahahahaha!
 229         };
 230         return
 231                 bless $you, 'Connection::Socket';
 232 }
 233
 234 # $sock->sockname() returns the local address of the socket.
 235 sub sockname($)
 236 {
 237         my ($self) = @_;
 238         my ($port, $addr) = sockaddr_in $self->{sock}->sockname();
 239         return "@{[inet_ntoa $addr]}:$port";
 240 }
 241
 242 # $sock->send($data) sends some data over the socket; on success, 1 is returned.
 243 sub send($$)
 244 {
 245         my ($self, $data) = @_;
 246         return 1
 247                 if not length $data;
 248         if(not eval { $self->{sock}->send($data); })
 249         {
 250                 warn "$@";
 251                 return 0;
 252         }
 253         return 1;
 254 }
 255
 256 # $sock->recv() receives as much as possible from the socket (or at most 32k). Returns "" if no data is available.
 257 sub recv($)
 258 {
 259         my ($self) = @_;
 260         my $data = "";
 261         $self->{sock}->recv($data, 32768, 0);
 262         return $data;
 263 }
 264
 265 # $sock->fds() returns the socket file descriptor.
 266 sub fds($)
 267 {
 268         my ($self) = @_;
 269         return fileno $self->{sock};
 270 }
 271
 272
 273
 274
 275
 276
 277
 278 # QW rcon protocol channel.
 279 # Wraps around a UDP based Connection and sends commands as rcon commands as
 280 # well as receives rcon replies. The quote and join_commands methods are using
 281 # DarkPlaces engine specific rcon protocol extensions.
 282 package Channel::QW;
 283 use strict;
 284 use warnings;
 285
 286 # Constructor:
 287 #   my $chan = new Channel::QW($connection, "password");
 288 sub new($$)
 289 {
 290         my ($class, $conn, $password) = @_;
 291         my $you = {
 292                 connector => $conn,
 293                 password => $password,
 294                 recvbuf => "",
 295         };
 296         return
 297                 bless $you, 'Channel::QW';
 298 }
 299
 300 # Note: multiple commands in one rcon packet is a DarkPlaces extension.
 301 sub join_commands($@)
 302 {
 303         my ($self, @data) = @_;
 304         return join "\0", @data;
 305 }
 306
 307 sub send($$$)
 308 {
 309         my ($self, $line, $nothrottle) = @_;
 310         return $self->{connector}->send("\377\377\377\377rcon $self->{password} $line");
 311 }
 312
 313 # Note: backslash and quotation mark escaping is a DarkPlaces extension.
 314 sub quote($$)
 315 {
 316         my ($self, $data) = @_;
 317         $data =~ s/[\000-\037]//g;
 318         $data =~ s/([\\"])/\\$1/g;
 319         $data =~ s/\$/\$\$/g;
 320         return $data;
 321 }
 322
 323 sub recv($)
 324 {
 325         my ($self) = @_;
 326         for(;;)
 327         {
 328                 length(my $s = $self->{connector}->recv())
 329                         or last;
 330                 next
 331                         if $s !~ /^\377\377\377\377n(.*)$/s;
 332                 $self->{recvbuf} .= $1;
 333         }
 334         my @out = ();
 335         while($self->{recvbuf} =~ s/^(.*?)(?:\r\n?|\n)//)
 336         {
 337                 push @out, $1;
 338         }
 339         return @out;
 340 }
 341
 342 sub fds($)
 343 {
 344         my ($self) = @_;
 345         return $self->{connector}->fds();
 346 }
 347
 348
 349
 350
 351
 352
 353
 354 package main;
 355 use strict;
 356 use warnings;
 357 use IO::Select;
 358
 359 sub default($$)
 360 {
 361         my ($default, $value) = @_;
 362         return $value if defined $value;
 363         return $default;
 364 }
 365
 366 my $server   = default '',  $ENV{rcon_address};
 367 my $password = default '',  $ENV{rcon_password};
 368 my $timeout  = default '5', $ENV{rcon_timeout};
 369 my $colors   = default '0', $ENV{rcon_colorcodes_raw};
 370
 371 if(!length $server)
 372 {
 373         print STDERR "Usage: rcon_address=SERVERIP:PORT rcon_password=PASSWORD $0 rconcommands...\n";
 374         print STDERR "Optional: rcon_timeout=... (default: 5)\n";
 375         print STDERR "          rcon_colorcodes_raw=1 (to disable color codes translation)\n";
 376         exit 0;
 377 }
 378
 379 my $connection = Connection::Socket->new("udp", "", $server, 26000);
 380 my $rcon = Channel::QW->new($connection, $password);
 381
 382 if(!$rcon->send($rcon->join_commands(@ARGV)))
 383 {
 384         die "send: $!";
 385 }
 386
 387 if($timeout)
 388 {
 389         my $sel = IO::Select->new($rcon->fds());
 390         if($sel->can_read($timeout))
 391         {
 392                 for($rcon->recv())
 393                 {
 394                         $_ = (color_dp2ansi $_) . "\033[m" unless $colors;
 395                         print "$_\n"
 396                 }
 397         }
 398 }