mirror of
https://gitlab.com/xonotic/xonotic
synced 2024-12-14 10:55:18 +00:00
598 lines
15 KiB
Perl
Executable File
598 lines
15 KiB
Perl
Executable File
#!/usr/bin/perl
|
|
|
|
# Copyright (c) 2008 Rudolf "divVerent" Polzer
|
|
#
|
|
# Permission is hereby granted, free of charge, to any person
|
|
# obtaining a copy of this software and associated documentation
|
|
# files (the "Software"), to deal in the Software without
|
|
# restriction, including without limitation the rights to use,
|
|
# copy, modify, merge, publish, distribute, sublicense, and/or sell
|
|
# copies of the Software, and to permit persons to whom the
|
|
# Software is furnished to do so, subject to the following
|
|
# conditions:
|
|
#
|
|
# The above copyright notice and this permission notice shall be
|
|
# included in all copies or substantial portions of the Software.
|
|
#
|
|
# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
|
# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
|
|
# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
|
|
# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
|
|
# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
|
|
# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
|
|
# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
|
|
# OTHER DEALINGS IN THE SOFTWARE.
|
|
|
|
# parts copied from rcon2irc
|
|
# MISC STRING UTILITY ROUTINES to convert between DarkPlaces and IRC conventions
|
|
|
|
# convert mIRC color codes to DP color codes
|
|
our $color_utf8_enable = 1;
|
|
our @color_irc2dp_table = (7, 0, 4, 2, 1, 1, 6, 1, 3, 2, 5, 5, 4, 6, 7, 7);
|
|
our @color_dp2irc_table = (-1, 4, 9, 8, 12, 11, 13, -1, -1, -1); # not accurate, but legible
|
|
our @color_dp2ansi_table = ("m", "1;31m", "1;32m", "1;33m", "1;34m", "1;36m", "1;35m", "m", "1m", "1m"); # not accurate, but legible
|
|
our %color_team2dp_table = (5 => 1, 14 => 4, 13 => 3, 10 => 6);
|
|
our %color_team2irc_table = (5 => 4, 14 => 12, 13 => 8, 10 => 13);
|
|
sub color_irc2dp($)
|
|
{
|
|
my ($message) = @_;
|
|
$message =~ s/\^/^^/g;
|
|
my $color = 7;
|
|
$message =~ s{\003(\d\d?)(?:,(\d?\d?))?|(\017)}{
|
|
# $1 is FG, $2 is BG, but let's ignore BG
|
|
my $oldcolor = $color;
|
|
if($3)
|
|
{
|
|
$color = 7;
|
|
}
|
|
else
|
|
{
|
|
$color = $color_irc2dp_table[$1];
|
|
$color = $oldcolor if not defined $color;
|
|
}
|
|
($color == $oldcolor) ? '' : '^' . $color;
|
|
}esg;
|
|
$message =~ s{[\000-\037]}{}gs; # kill bold etc. for now
|
|
return $message;
|
|
}
|
|
|
|
our @text_qfont_table = ( # ripped from DP console.c qfont_table
|
|
'', '#', '#', '#', '#', '.', '#', '#',
|
|
'#', 9, 10, '#', ' ', 13, '.', '.',
|
|
'[', ']', '0', '1', '2', '3', '4', '5',
|
|
'6', '7', '8', '9', '.', '<', '=', '>',
|
|
' ', '!', '"', '#', '$', '%', '&', '\'',
|
|
'(', ')', '*', '+', ',', '-', '.', '/',
|
|
'0', '1', '2', '3', '4', '5', '6', '7',
|
|
'8', '9', ':', ';', '<', '=', '>', '?',
|
|
'@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
|
|
'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
|
|
'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
|
|
'X', 'Y', 'Z', '[', '\\', ']', '^', '_',
|
|
'`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',
|
|
'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
|
|
'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
|
|
'x', 'y', 'z', '{', '|', '}', '~', '<',
|
|
'<', '=', '>', '#', '#', '.', '#', '#',
|
|
'#', '#', ' ', '#', ' ', '>', '.', '.',
|
|
'[', ']', '0', '1', '2', '3', '4', '5',
|
|
'6', '7', '8', '9', '.', '<', '=', '>',
|
|
' ', '!', '"', '#', '$', '%', '&', '\'',
|
|
'(', ')', '*', '+', ',', '-', '.', '/',
|
|
'0', '1', '2', '3', '4', '5', '6', '7',
|
|
'8', '9', ':', ';', '<', '=', '>', '?',
|
|
'@', 'A', 'B', 'C', 'D', 'E', 'F', 'G',
|
|
'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O',
|
|
'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W',
|
|
'X', 'Y', 'Z', '[', '\\', ']', '^', '_',
|
|
'`', 'a', 'b', 'c', 'd', 'e', 'f', 'g',
|
|
'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o',
|
|
'p', 'q', 'r', 's', 't', 'u', 'v', 'w',
|
|
'x', 'y', 'z', '{', '|', '}', '~', '<'
|
|
);
|
|
sub text_qfont_table($)
|
|
{
|
|
my ($char) = @_;
|
|
my $o = ord $char;
|
|
if($color_utf8_enable)
|
|
{
|
|
return (($o & 0xFF00) == 0xE000) ? $text_qfont_table[$o & 0xFF] : $char;
|
|
}
|
|
else
|
|
{
|
|
return $text_qfont_table[$o];
|
|
}
|
|
}
|
|
sub text_dp2ascii($)
|
|
{
|
|
my ($message) = @_;
|
|
$message = join '', map { text_qfont_table $_ } split //, $message;
|
|
}
|
|
|
|
sub color_dp_transform(&$)
|
|
{
|
|
my ($block, $message) = @_;
|
|
$message =~ s{(?:(\^\^)|\^x([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])|\^([0-9])|(.))(?=([0-9,]?))}{
|
|
defined $1 ? $block->(char => '^', $7) :
|
|
defined $2 ? $block->(rgb => [hex $2, hex $3, hex $4], $7) :
|
|
defined $5 ? $block->(color => $5, $7) :
|
|
defined $6 ? $block->(char => $6, $7) :
|
|
die "Invalid match";
|
|
}esg;
|
|
|
|
return $message;
|
|
}
|
|
|
|
sub color_dp2none($)
|
|
{
|
|
my ($message) = @_;
|
|
|
|
return color_dp_transform
|
|
{
|
|
my ($type, $data, $next) = @_;
|
|
$type eq 'char'
|
|
? text_qfont_table $data
|
|
: "";
|
|
}
|
|
$message;
|
|
}
|
|
|
|
sub color_rgb2basic($)
|
|
{
|
|
my ($data) = @_;
|
|
my ($R, $G, $B) = @$data;
|
|
my $min = [sort { $a <=> $b } ($R, $G, $B)]->[0];
|
|
my $max = [sort { $a <=> $b } ($R, $G, $B)]->[-1];
|
|
|
|
my $v = $max / 15;
|
|
my $s = ($max == $min) ? 0 : 1 - $min/$max;
|
|
|
|
if($s < 0.2)
|
|
{
|
|
return 0 if $v < 0.5;
|
|
return 7;
|
|
}
|
|
|
|
my $h;
|
|
if($max == $min)
|
|
{
|
|
$h = 0;
|
|
}
|
|
elsif($max == $R)
|
|
{
|
|
$h = (60 * ($G - $B) / ($max - $min)) % 360;
|
|
}
|
|
elsif($max == $G)
|
|
{
|
|
$h = (60 * ($B - $R) / ($max - $min)) + 120;
|
|
}
|
|
elsif($max == $B)
|
|
{
|
|
$h = (60 * ($R - $G) / ($max - $min)) + 240;
|
|
}
|
|
|
|
return 1 if $h < 36;
|
|
return 3 if $h < 80;
|
|
return 2 if $h < 150;
|
|
return 5 if $h < 200;
|
|
return 4 if $h < 270;
|
|
return 6 if $h < 330;
|
|
return 1;
|
|
}
|
|
|
|
sub color_dp_rgb2basic($)
|
|
{
|
|
my ($message) = @_;
|
|
return color_dp_transform
|
|
{
|
|
my ($type, $data, $next) = @_;
|
|
$type eq 'char' ? ($data eq '^' ? '^^' : $data) :
|
|
$type eq 'color' ? "^$data" :
|
|
$type eq 'rgb' ? "^" . color_rgb2basic $data :
|
|
die "Invalid type";
|
|
}
|
|
$message;
|
|
}
|
|
|
|
sub color_dp2irc($)
|
|
{
|
|
my ($message) = @_;
|
|
my $color = -1;
|
|
return color_dp_transform
|
|
{
|
|
my ($type, $data, $next) = @_;
|
|
|
|
if($type eq 'rgb')
|
|
{
|
|
$type = 'color';
|
|
$data = color_rgb2basic $data;
|
|
}
|
|
|
|
$type eq 'char' ? text_qfont_table $data :
|
|
$type eq 'color' ? do {
|
|
my $oldcolor = $color;
|
|
$color = $color_dp2irc_table[$data];
|
|
|
|
$color == $oldcolor ? '' :
|
|
$color < 0 ? "\017" :
|
|
(index '0123456789,', $next) >= 0 ? "\003$color\002\002" :
|
|
"\003$color";
|
|
} :
|
|
die "Invalid type";
|
|
}
|
|
$message;
|
|
}
|
|
|
|
sub color_dp2ansi($)
|
|
{
|
|
my ($message) = @_;
|
|
my $color = -1;
|
|
return color_dp_transform
|
|
{
|
|
my ($type, $data, $next) = @_;
|
|
|
|
if($type eq 'rgb')
|
|
{
|
|
$type = 'color';
|
|
$data = color_rgb2basic $data;
|
|
}
|
|
|
|
$type eq 'char' ? text_qfont_table $data :
|
|
$type eq 'color' ? do {
|
|
my $oldcolor = $color;
|
|
$color = $color_dp2ansi_table[$data];
|
|
|
|
$color eq $oldcolor ? '' :
|
|
"\033[${color}"
|
|
} :
|
|
die "Invalid type";
|
|
}
|
|
$message;
|
|
}
|
|
|
|
sub color_dpfix($)
|
|
{
|
|
my ($message) = @_;
|
|
# if the message ends with an odd number of ^, kill one
|
|
chop $message if $message =~ /(?:^|[^\^])\^(\^\^)*$/;
|
|
return $message;
|
|
}
|
|
|
|
|
|
|
|
|
|
# Interfaces:
|
|
# Connection:
|
|
# $conn->sockname() returns a connection type specific representation
|
|
# string of the local address, or undef if not applicable.
|
|
# $conn->send("string") sends something over the connection.
|
|
# $conn->recv() receives a string from the connection, or returns "" if no
|
|
# data is available.
|
|
# $conn->fds() returns all file descriptors used by the connection, so one
|
|
# can use select() on them.
|
|
# Channel:
|
|
# Usually wraps around a connection and implements a command based
|
|
# structure over it. It usually is constructed using new
|
|
# ChannelType($connection, someparameters...)
|
|
# @cmds = $chan->join_commands(@cmds) joins multiple commands to a single
|
|
# command string if the protocol supports it, or does nothing and leaves
|
|
# @cmds unchanged if the protocol does not support that usage (this is
|
|
# meant to save send() invocations).
|
|
# $chan->send($command, $nothrottle) sends a command over the channel. If
|
|
# $nothrottle is sent, the command must not be left out even if the channel
|
|
# is saturated (for example, because of IRC's flood control mechanism).
|
|
# $chan->quote($str) returns a string in a quoted form so it can safely be
|
|
# inserted as a substring into a command, or returns $str as is if not
|
|
# applicable. It is assumed that the result of the quote method is used
|
|
# as part of a quoted string, if the protocol supports that.
|
|
# $chan->recv() returns a list of received commands from the channel, or
|
|
# the empty list if none are available.
|
|
# $conn->fds() returns all file descriptors used by the channel's
|
|
# connections, so one can use select() on them.
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# Socket connection.
|
|
# Represents a connection over a socket.
|
|
# Mainly used to wrap a channel around it for, in this case, line based or rcon-like operation.
|
|
package Connection::Socket;
|
|
use strict;
|
|
use warnings;
|
|
use IO::Socket::INET;
|
|
use IO::Handle;
|
|
|
|
# Constructor:
|
|
# my $conn = new Connection::Socket(tcp => "localaddress" => "remoteaddress" => 6667);
|
|
# If the remote address does not contain a port number, the numeric port is
|
|
# used (it serves as a default port).
|
|
sub new($$)
|
|
{
|
|
my ($class, $proto, $local, $remote, $defaultport) = @_;
|
|
my $sock = IO::Socket::INET->new(
|
|
Proto => $proto,
|
|
(length($local) ? (LocalAddr => $local) : ()),
|
|
PeerAddr => $remote,
|
|
PeerPort => $defaultport
|
|
) or die "socket $proto/$local/$remote/$defaultport: $!";
|
|
binmode $sock;
|
|
$sock->blocking(0);
|
|
my $you = {
|
|
# Mortal fool! Release me from this wretched tomb! I must be set free
|
|
# or I will haunt you forever! I will hide your keys beneath the
|
|
# cushions of your upholstered furniture... and NEVERMORE will you be
|
|
# able to find socks that match!
|
|
sock => $sock,
|
|
# My demonic powers have made me OMNIPOTENT! Bwahahahahahahaha!
|
|
};
|
|
return
|
|
bless $you, 'Connection::Socket';
|
|
}
|
|
|
|
# $sock->sockname() returns the local address of the socket.
|
|
sub sockname($)
|
|
{
|
|
my ($self) = @_;
|
|
my ($port, $addr) = sockaddr_in $self->{sock}->sockname();
|
|
return "@{[inet_ntoa $addr]}:$port";
|
|
}
|
|
|
|
# $sock->send($data) sends some data over the socket; on success, 1 is returned.
|
|
sub send($$)
|
|
{
|
|
my ($self, $data) = @_;
|
|
return 1
|
|
if not length $data;
|
|
if(not eval { $self->{sock}->send($data); })
|
|
{
|
|
warn "$@";
|
|
return 0;
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
# $sock->recv() receives as much as possible from the socket (or at most 32k). Returns "" if no data is available.
|
|
sub recv($)
|
|
{
|
|
my ($self) = @_;
|
|
my $data = "";
|
|
if(defined $self->{sock}->recv($data, 32768, 0))
|
|
{
|
|
return $data;
|
|
}
|
|
elsif($!{EAGAIN})
|
|
{
|
|
return "";
|
|
}
|
|
else
|
|
{
|
|
return undef;
|
|
}
|
|
}
|
|
|
|
# $sock->fds() returns the socket file descriptor.
|
|
sub fds($)
|
|
{
|
|
my ($self) = @_;
|
|
return fileno $self->{sock};
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
# QW rcon protocol channel.
|
|
# Wraps around a UDP based Connection and sends commands as rcon commands as
|
|
# well as receives rcon replies. The quote and join_commands methods are using
|
|
# DarkPlaces engine specific rcon protocol extensions.
|
|
package Channel::QW;
|
|
use strict;
|
|
use warnings;
|
|
use Digest::HMAC;
|
|
use Digest::MD4;
|
|
|
|
# Constructor:
|
|
# my $chan = new Channel::QW($connection, "password");
|
|
sub new($$$)
|
|
{
|
|
my ($class, $conn, $password, $secure, $timeout) = @_;
|
|
my $you = {
|
|
connector => $conn,
|
|
password => $password,
|
|
recvbuf => "",
|
|
secure => $secure,
|
|
timeout => $timeout,
|
|
};
|
|
return
|
|
bless $you, 'Channel::QW';
|
|
}
|
|
|
|
# Note: multiple commands in one rcon packet is a DarkPlaces extension.
|
|
sub join_commands($@)
|
|
{
|
|
my ($self, @data) = @_;
|
|
return join "\0", @data;
|
|
}
|
|
|
|
sub send($$$)
|
|
{
|
|
my ($self, $line, $nothrottle) = @_;
|
|
utf8::encode $line
|
|
if $color_utf8_enable;
|
|
if($self->{secure} > 1)
|
|
{
|
|
$self->{connector}->send("\377\377\377\377getchallenge");
|
|
my $c = $self->recvchallenge();
|
|
return 0 if not defined $c;
|
|
my $key = Digest::HMAC::hmac("$c $line", $self->{password}, \&Digest::MD4::md4);
|
|
return $self->{connector}->send("\377\377\377\377srcon HMAC-MD4 CHALLENGE $key $c $line");
|
|
}
|
|
elsif($self->{secure})
|
|
{
|
|
my $t = sprintf "%ld.%06d", time(), int rand 1000000;
|
|
my $key = Digest::HMAC::hmac("$t $line", $self->{password}, \&Digest::MD4::md4);
|
|
return $self->{connector}->send("\377\377\377\377srcon HMAC-MD4 TIME $key $t $line");
|
|
}
|
|
else
|
|
{
|
|
return $self->{connector}->send("\377\377\377\377rcon $self->{password} $line");
|
|
}
|
|
}
|
|
|
|
# Note: backslash and quotation mark escaping is a DarkPlaces extension.
|
|
sub quote($$)
|
|
{
|
|
my ($self, $data) = @_;
|
|
$data =~ s/[\000-\037]//g;
|
|
$data =~ s/([\\"])/\\$1/g;
|
|
$data =~ s/\$/\$\$/g;
|
|
return $data;
|
|
}
|
|
|
|
sub recvchallenge($)
|
|
{
|
|
my ($self) = @_;
|
|
|
|
my $sel = IO::Select->new($self->fds());
|
|
my $endtime_max = Time::HiRes::time() + $self->{timeout};
|
|
my $endtime = $endtime_max;
|
|
|
|
while((my $dt = $endtime - Time::HiRes::time()) > 0)
|
|
{
|
|
if($sel->can_read($dt))
|
|
{
|
|
for(;;)
|
|
{
|
|
my $s = $self->{connector}->recv();
|
|
die "read error\n"
|
|
if not defined $s;
|
|
length $s
|
|
or last;
|
|
if($s =~ /^\377\377\377\377challenge (.*?)(?:$|\0)/s)
|
|
{
|
|
return $1;
|
|
}
|
|
next
|
|
if $s !~ /^\377\377\377\377n(.*)$/s;
|
|
$self->{recvbuf} .= $1;
|
|
}
|
|
}
|
|
}
|
|
return undef;
|
|
}
|
|
|
|
sub recv($)
|
|
{
|
|
my ($self) = @_;
|
|
for(;;)
|
|
{
|
|
my $s = $self->{connector}->recv();
|
|
die "read error\n"
|
|
if not defined $s;
|
|
length $s
|
|
or last;
|
|
next
|
|
if $s !~ /^\377\377\377\377n(.*)$/s;
|
|
$self->{recvbuf} .= $1;
|
|
}
|
|
my @out = ();
|
|
while($self->{recvbuf} =~ s/^(.*?)(?:\r\n?|\n)//)
|
|
{
|
|
my $s = $1;
|
|
utf8::decode $s
|
|
if $color_utf8_enable;
|
|
push @out, $s;
|
|
}
|
|
return @out;
|
|
}
|
|
|
|
sub fds($)
|
|
{
|
|
my ($self) = @_;
|
|
return $self->{connector}->fds();
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
package main;
|
|
use strict;
|
|
use warnings;
|
|
use IO::Select;
|
|
use Time::HiRes;
|
|
|
|
sub default($$)
|
|
{
|
|
my ($default, $value) = @_;
|
|
return $value if defined $value;
|
|
return $default;
|
|
}
|
|
|
|
my $server = default '', $ENV{rcon_address};
|
|
my $password = default '', $ENV{rcon_password};
|
|
my $secure = default '1', $ENV{rcon_secure};
|
|
my $timeout = default '5', $ENV{rcon_timeout};
|
|
my $timeouti = default '0.2', $ENV{rcon_timeout_inter};
|
|
my $timeoutc = default $timeout, $ENV{rcon_timeout_challenge};
|
|
my $colors = default '0', $ENV{rcon_colorcodes_raw};
|
|
my $utf8 = default '1', $ENV{rcon_utf8_enable};
|
|
|
|
if(!length $server)
|
|
{
|
|
print STDERR "Usage: rcon_address=SERVERIP:PORT rcon_password=PASSWORD $0 rconcommands...\n";
|
|
print STDERR "Optional: rcon_timeout=... (default: 5)\n";
|
|
print STDERR " rcon_timeout_inter=... (default: 0.2)\n";
|
|
print STDERR " rcon_timeout_challenge=... (default: 5)\n";
|
|
print STDERR " rcon_colorcodes_raw=1 (to disable color codes translation)\n";
|
|
print STDERR " rcon_secure=0 (to allow connecting to older servers not supporting secure rcon)\n";
|
|
print STDERR " rcon_utf8_enable=0 (to enable/disable engine UTF8 mode)\n";
|
|
exit 0;
|
|
}
|
|
|
|
$color_utf8_enable = $utf8;
|
|
|
|
if($color_utf8_enable)
|
|
{
|
|
binmode STDOUT, ':utf8';
|
|
binmode STDERR, ':utf8';
|
|
}
|
|
|
|
my $connection = Connection::Socket->new("udp", "", $server, 26000);
|
|
my $rcon = Channel::QW->new($connection, $password, $secure, $timeoutc);
|
|
|
|
if(!$rcon->send($rcon->join_commands(@ARGV)))
|
|
{
|
|
die "send: $!";
|
|
}
|
|
|
|
if($timeout > 0)
|
|
{
|
|
my $sel = IO::Select->new($rcon->fds());
|
|
my $endtime_max = Time::HiRes::time() + $timeout;
|
|
my $endtime = $endtime_max;
|
|
|
|
while((my $dt = $endtime - Time::HiRes::time()) > 0)
|
|
{
|
|
if($sel->can_read($dt))
|
|
{
|
|
for($rcon->recv())
|
|
{
|
|
$_ = (color_dp2ansi $_) . "\033[m" unless $colors;
|
|
print "$_\n"
|
|
}
|
|
$endtime = Time::HiRes::time() + $timeouti;
|
|
$endtime = $endtime_max
|
|
if $endtime > $endtime_max;
|
|
}
|
|
}
|
|
}
|
|
exit 0;
|