1#!/usr/local/bin/perl 2 3our $VERSION = '0.4.2 svn $Revision: 7944 $'; 4 5# Copyright (c) 2008 Rudolf "divVerent" Polzer 6# 7# Permission is hereby granted, free of charge, to any person 8# obtaining a copy of this software and associated documentation 9# files (the "Software"), to deal in the Software without 10# restriction, including without limitation the rights to use, 11# copy, modify, merge, publish, distribute, sublicense, and/or sell 12# copies of the Software, and to permit persons to whom the 13# Software is furnished to do so, subject to the following 14# conditions: 15# 16# The above copyright notice and this permission notice shall be 17# included in all copies or substantial portions of the Software. 18# 19# THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 20# EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES 21# OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND 22# NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT 23# HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, 24# WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING 25# FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR 26# OTHER DEALINGS IN THE SOFTWARE. 27 28# MISC STRING UTILITY ROUTINES to convert between DarkPlaces and IRC conventions 29 30# convert mIRC color codes to DP color codes 31our @color_irc2dp_table = (7, 0, 4, 2, 1, 1, 6, 1, 3, 2, 5, 5, 4, 6, 7, 7); 32our @color_dp2irc_table = (-1, 4, 9, 8, 12, 11, 13, -1, -1, -1); # not accurate, but legible 33our @color_dp2ansi_table = ("m", "1;31m", "1;32m", "1;33m", "1;34m", "1;36m", "1;35m", "m", "1m", "1m"); # not accurate, but legible 34our %color_team2dp_table = (5 => 1, 14 => 4, 13 => 3, 10 => 6); 35our %color_team2irc_table = (5 => 4, 14 => 12, 13 => 8, 10 => 13); 36sub color_irc2dp($) 37{ 38 my ($message) = @_; 39 $message =~ s/\^/^^/g; 40 my $color = 7; 41 $message =~ s{\003(\d\d?)(?:,(\d?\d?))?|(\017)}{ 42 # $1 is FG, $2 is BG, but let's ignore BG 43 my $oldcolor = $color; 44 if($3) 45 { 46 $color = 7; 47 } 48 else 49 { 50 $color = $color_irc2dp_table[$1]; 51 $color = $oldcolor if not defined $color; 52 } 53 ($color == $oldcolor) ? '' : '^' . $color; 54 }esg; 55 $message =~ s{[\000-\037]}{}gs; # kill bold etc. for now 56 return $message; 57} 58 59our @text_qfont_table = ( # ripped from DP console.c qfont_table 60 "\0", '#', '#', '#', '#', '.', '#', '#', 61 '#', 9, 10, '#', ' ', 13, '.', '.', 62 '[', ']', '0', '1', '2', '3', '4', '5', 63 '6', '7', '8', '9', '.', '<', '=', '>', 64 ' ', '!', '"', '#', '$', '%', '&', '\'', 65 '(', ')', '*', '+', ',', '-', '.', '/', 66 '0', '1', '2', '3', '4', '5', '6', '7', 67 '8', '9', ':', ';', '<', '=', '>', '?', 68 '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 69 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 70 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 71 'X', 'Y', 'Z', '[', '\\', ']', '^', '_', 72 '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 73 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 74 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 75 'x', 'y', 'z', '{', '|', '}', '~', '<', 76 '<', '=', '>', '#', '#', '.', '#', '#', 77 '#', '#', ' ', '#', ' ', '>', '.', '.', 78 '[', ']', '0', '1', '2', '3', '4', '5', 79 '6', '7', '8', '9', '.', '<', '=', '>', 80 ' ', '!', '"', '#', '$', '%', '&', '\'', 81 '(', ')', '*', '+', ',', '-', '.', '/', 82 '0', '1', '2', '3', '4', '5', '6', '7', 83 '8', '9', ':', ';', '<', '=', '>', '?', 84 '@', 'A', 'B', 'C', 'D', 'E', 'F', 'G', 85 'H', 'I', 'J', 'K', 'L', 'M', 'N', 'O', 86 'P', 'Q', 'R', 'S', 'T', 'U', 'V', 'W', 87 'X', 'Y', 'Z', '[', '\\', ']', '^', '_', 88 '`', 'a', 'b', 'c', 'd', 'e', 'f', 'g', 89 'h', 'i', 'j', 'k', 'l', 'm', 'n', 'o', 90 'p', 'q', 'r', 's', 't', 'u', 'v', 'w', 91 'x', 'y', 'z', '{', '|', '}', '~', '<' 92); 93sub text_dp2ascii($) 94{ 95 my ($message) = @_; 96 $message = join '', map { $text_qfont_table[ord $_] } split //, $message; 97} 98 99sub color_dp_transform(&$) 100{ 101 my ($block, $message) = @_; 102 103 $message =~ s{(?:(\^\^)|\^x([0-9a-fA-F])([0-9a-fA-F])([0-9a-fA-F])|\^([0-9])|(.))(?=([0-9,]?))}{ 104 defined $1 ? $block->(char => '^', $7) : 105 defined $2 ? $block->(rgb => [hex $2, hex $3, hex $4], $7) : 106 defined $5 ? $block->(color => $5, $7) : 107 defined $6 ? $block->(char => $6, $7) : 108 die "Invalid match"; 109 }esg; 110 111 return $message; 112} 113 114sub color_dp2none($) 115{ 116 my ($message) = @_; 117 118 return color_dp_transform 119 { 120 my ($type, $data, $next) = @_; 121 $type eq 'char' 122 ? $text_qfont_table[ord $data] 123 : ""; 124 } 125 $message; 126} 127 128sub color_rgb2basic($) 129{ 130 my ($data) = @_; 131 my ($R, $G, $B) = @$data; 132 my $min = [sort { $a <=> $b } ($R, $G, $B)]->[0]; 133 my $max = [sort { $a <=> $b } ($R, $G, $B)]->[-1]; 134 135 my $v = $max / 15; 136 my $s = ($max == $min) ? 0 : 1 - $min/$max; 137 138 if($s < 0.2) 139 { 140 return 0 if $v < 0.5; 141 return 7; 142 } 143 144 my $h; 145 if($max == $min) 146 { 147 $h = 0; 148 } 149 elsif($max == $R) 150 { 151 $h = (60 * ($G - $B) / ($max - $min)) % 360; 152 } 153 elsif($max == $G) 154 { 155 $h = (60 * ($B - $R) / ($max - $min)) + 120; 156 } 157 elsif($max == $B) 158 { 159 $h = (60 * ($R - $G) / ($max - $min)) + 240; 160 } 161 162 return 1 if $h < 36; 163 return 3 if $h < 80; 164 return 2 if $h < 150; 165 return 5 if $h < 200; 166 return 4 if $h < 270; 167 return 6 if $h < 330; 168 return 1; 169} 170 171sub color_dp_rgb2basic($) 172{ 173 my ($message) = @_; 174 return color_dp_transform 175 { 176 my ($type, $data, $next) = @_; 177 $type eq 'char' ? ($data eq '^' ? '^^' : $data) : 178 $type eq 'color' ? "^$data" : 179 $type eq 'rgb' ? "^" . color_rgb2basic $data : 180 die "Invalid type"; 181 } 182 $message; 183} 184 185sub color_dp2irc($) 186{ 187 my ($message) = @_; 188 my $color = -1; 189 return color_dp_transform 190 { 191 my ($type, $data, $next) = @_; 192 193 if($type eq 'rgb') 194 { 195 $type = 'color'; 196 $data = color_rgb2basic $data; 197 } 198 199 $type eq 'char' ? $text_qfont_table[ord $data] : 200 $type eq 'color' ? do { 201 my $oldcolor = $color; 202 $color = $color_dp2irc_table[$data]; 203 204 $color == $oldcolor ? '' : 205 $color < 0 ? "\017" : 206 (index '0123456789,', $next) >= 0 ? "\003$color\002\002" : 207 "\003$color"; 208 } : 209 die "Invalid type"; 210 } 211 $message; 212} 213 214sub color_dp2ansi($) 215{ 216 my ($message) = @_; 217 my $color = -1; 218 return color_dp_transform 219 { 220 my ($type, $data, $next) = @_; 221 222 if($type eq 'rgb') 223 { 224 $type = 'color'; 225 $data = color_rgb2basic $data; 226 } 227 228 $type eq 'char' ? $text_qfont_table[ord $data] : 229 $type eq 'color' ? do { 230 my $oldcolor = $color; 231 $color = $color_dp2ansi_table[$data]; 232 233 $color eq $oldcolor ? '' : 234 "\033[${color}" 235 } : 236 die "Invalid type"; 237 } 238 $message; 239} 240 241sub color_dpfix($) 242{ 243 my ($message) = @_; 244 # if the message ends with an odd number of ^, kill one 245 chop $message if $message =~ /(?:^|[^\^])\^(\^\^)*$/; 246 return $message; 247} 248 249 250 251 252# Interfaces: 253# Connection: 254# $conn->sockname() returns a connection type specific representation 255# string of the local address, or undef if not applicable. 256# $conn->send("string") sends something over the connection. 257# $conn->recv() receives a string from the connection, or returns "" if no 258# data is available. 259# $conn->fds() returns all file descriptors used by the connection, so one 260# can use select() on them. 261# Channel: 262# Usually wraps around a connection and implements a command based 263# structure over it. It usually is constructed using new 264# ChannelType($connection, someparameters...) 265# @cmds = $chan->join_commands(@cmds) joins multiple commands to a single 266# command string if the protocol supports it, or does nothing and leaves 267# @cmds unchanged if the protocol does not support that usage (this is 268# meant to save send() invocations). 269# $chan->send($command, $nothrottle) sends a command over the channel. If 270# $nothrottle is sent, the command must not be left out even if the channel 271# is saturated (for example, because of IRC's flood control mechanism). 272# $chan->quote($str) returns a string in a quoted form so it can safely be 273# inserted as a substring into a command, or returns $str as is if not 274# applicable. It is assumed that the result of the quote method is used 275# as part of a quoted string, if the protocol supports that. 276# $chan->recv() returns a list of received commands from the channel, or 277# the empty list if none are available. 278# $conn->fds() returns all file descriptors used by the channel's 279# connections, so one can use select() on them. 280 281 282 283 284 285 286 287# Socket connection. 288# Represents a connection over a socket. 289# Mainly used to wrap a channel around it for, in this case, line based or rcon-like operation. 290package Connection::Socket; 291use strict; 292use warnings; 293use IO::Socket::INET; 294use IO::Handle; 295 296# Constructor: 297# my $conn = new Connection::Socket(tcp => "localaddress" => "remoteaddress" => 6667); 298# If the remote address does not contain a port number, the numeric port is 299# used (it serves as a default port). 300sub new($$) 301{ 302 my ($class, $proto, $local, $remote, $defaultport) = @_; 303 my $sock = IO::Socket::INET->new( 304 Proto => $proto, 305 (length($local) ? (LocalAddr => $local) : ()), 306 PeerAddr => $remote, 307 PeerPort => $defaultport 308 ) or die "socket $proto/$local/$remote/$defaultport: $!"; 309 $sock->blocking(0); 310 my $you = { 311 # Mortal fool! Release me from this wretched tomb! I must be set free 312 # or I will haunt you forever! I will hide your keys beneath the 313 # cushions of your upholstered furniture... and NEVERMORE will you be 314 # able to find socks that match! 315 sock => $sock, 316 # My demonic powers have made me OMNIPOTENT! Bwahahahahahahaha! 317 }; 318 return 319 bless $you, 'Connection::Socket'; 320} 321 322# $sock->sockname() returns the local address of the socket. 323sub sockname($) 324{ 325 my ($self) = @_; 326 my ($port, $addr) = sockaddr_in $self->{sock}->sockname(); 327 return "@{[inet_ntoa $addr]}:$port"; 328} 329 330# $sock->send($data) sends some data over the socket; on success, 1 is returned. 331sub send($$) 332{ 333 my ($self, $data) = @_; 334 return 1 335 if not length $data; 336 if(not eval { $self->{sock}->send($data); }) 337 { 338 warn "$@"; 339 return 0; 340 } 341 return 1; 342} 343 344# $sock->recv() receives as much as possible from the socket (or at most 32k). Returns "" if no data is available. 345sub recv($) 346{ 347 my ($self) = @_; 348 my $data = ""; 349 if(defined $self->{sock}->recv($data, 32768, 0)) 350 { 351 return $data; 352 } 353 elsif($!{EAGAIN}) 354 { 355 return ""; 356 } 357 else 358 { 359 return undef; 360 } 361} 362 363# $sock->fds() returns the socket file descriptor. 364sub fds($) 365{ 366 my ($self) = @_; 367 return fileno $self->{sock}; 368} 369 370 371 372 373 374 375 376# Line-based buffered connectionless FIFO channel. 377# Whatever is sent to it using send() is echoed back when using recv(). 378package Channel::FIFO; 379use strict; 380use warnings; 381 382# Constructor: 383# my $chan = new Channel::FIFO(); 384sub new($) 385{ 386 my ($class) = @_; 387 my $you = { 388 buffer => [] 389 }; 390 return 391 bless $you, 'Channel::FIFO'; 392} 393 394sub join_commands($@) 395{ 396 my ($self, @data) = @_; 397 return @data; 398} 399 400sub send($$$) 401{ 402 my ($self, $line, $nothrottle) = @_; 403 push @{$self->{buffer}}, $line; 404} 405 406sub quote($$) 407{ 408 my ($self, $data) = @_; 409 return $data; 410} 411 412sub recv($) 413{ 414 my ($self) = @_; 415 my $r = $self->{buffer}; 416 $self->{buffer} = []; 417 return @$r; 418} 419 420sub fds($) 421{ 422 my ($self) = @_; 423 return (); 424} 425 426 427 428 429 430 431 432# QW rcon protocol channel. 433# Wraps around a UDP based Connection and sends commands as rcon commands as 434# well as receives rcon replies. The quote and join_commands methods are using 435# DarkPlaces engine specific rcon protocol extensions. 436package Channel::QW; 437use strict; 438use warnings; 439use Digest::HMAC; 440use Digest::MD4; 441 442# Constructor: 443# my $chan = new Channel::QW($connection, "password"); 444sub new($$$) 445{ 446 my ($class, $conn, $password, $secure) = @_; 447 my $you = { 448 connector => $conn, 449 password => $password, 450 recvbuf => "", 451 secure => $secure, 452 }; 453 return 454 bless $you, 'Channel::QW'; 455} 456 457# Note: multiple commands in one rcon packet is a DarkPlaces extension. 458sub join_commands($@) 459{ 460 my ($self, @data) = @_; 461 return join "\0", @data; 462} 463 464sub send($$$) 465{ 466 my ($self, $line, $nothrottle) = @_; 467 if($self->{secure}) 468 { 469 my $t = sprintf "%ld.%06d", time(), int rand 1000000; 470 my $key = Digest::HMAC::hmac("$t $line", $self->{password}, \&Digest::MD4::md4); 471 return $self->{connector}->send("\377\377\377\377srcon HMAC-MD4 TIME $key $t $line"); 472 } 473 else 474 { 475 return $self->{connector}->send("\377\377\377\377rcon $self->{password} $line"); 476 } 477} 478 479# Note: backslash and quotation mark escaping is a DarkPlaces extension. 480sub quote($$) 481{ 482 my ($self, $data) = @_; 483 $data =~ s/[\000-\037]//g; 484 $data =~ s/([\\"])/\\$1/g; 485 $data =~ s/\$/\$\$/g; 486 return $data; 487} 488 489sub recv($) 490{ 491 my ($self) = @_; 492 for(;;) 493 { 494 my $s = $self->{connector}->recv(); 495 die "read error\n" 496 if not defined $s; 497 length $s 498 or last; 499 next 500 if $s !~ /^\377\377\377\377n(.*)$/s; 501 $self->{recvbuf} .= $1; 502 } 503 my @out = (); 504 while($self->{recvbuf} =~ s/^(.*?)(?:\r\n?|\n)//) 505 { 506 push @out, $1; 507 } 508 return @out; 509} 510 511sub fds($) 512{ 513 my ($self) = @_; 514 return $self->{connector}->fds(); 515} 516 517 518 519 520 521 522 523# Line based protocol channel. 524# Wraps around a TCP based Connection and sends commands as text lines 525# (separated by CRLF). When reading responses from the Connection, any type of 526# line ending is accepted. 527# A flood control mechanism is implemented. 528package Channel::Line; 529use strict; 530use warnings; 531use Time::HiRes qw/time/; 532 533# Constructor: 534# my $chan = new Channel::Line($connection); 535sub new($$) 536{ 537 my ($class, $conn) = @_; 538 my $you = { 539 connector => $conn, 540 recvbuf => "", 541 capacity => undef, 542 linepersec => undef, 543 maxlines => undef, 544 lastsend => time() 545 }; 546 return 547 bless $you, 'Channel::Line'; 548} 549 550sub join_commands($@) 551{ 552 my ($self, @data) = @_; 553 return @data; 554} 555 556# Sets new flood control parameters: 557# $chan->throttle(maximum lines per second, maximum burst length allowed to 558# exceed the lines per second limit); 559# RFC 1459 describes these parameters to be 0.5 and 5 for the IRC protocol. 560# If the $nothrottle flag is set while sending, the line is sent anyway even 561# if flooding would take place. 562sub throttle($$$) 563{ 564 my ($self, $linepersec, $maxlines) = @_; 565 $self->{linepersec} = $linepersec; 566 $self->{maxlines} = $maxlines; 567 $self->{capacity} = $maxlines; 568} 569 570sub send($$$) 571{ 572 my ($self, $line, $nothrottle) = @_; 573 my $t = time(); 574 if(defined $self->{capacity}) 575 { 576 $self->{capacity} += ($t - $self->{lastsend}) * $self->{linepersec}; 577 $self->{lastsend} = $t; 578 $self->{capacity} = $self->{maxlines} 579 if $self->{capacity} > $self->{maxlines}; 580 if(!$nothrottle) 581 { 582 return -1 583 if $self->{capacity} < 0; 584 } 585 $self->{capacity} -= 1; 586 } 587 $line =~ s/\r|\n//g; 588 return $self->{connector}->send("$line\r\n"); 589} 590 591sub quote($$) 592{ 593 my ($self, $data) = @_; 594 $data =~ s/\r\n?/\n/g; 595 $data =~ s/\n/*/g; 596 return $data; 597} 598 599sub recv($) 600{ 601 my ($self) = @_; 602 for(;;) 603 { 604 my $s = $self->{connector}->recv(); 605 die "read error\n" 606 if not defined $s; 607 length $s 608 or last; 609 $self->{recvbuf} .= $s; 610 } 611 my @out = (); 612 while($self->{recvbuf} =~ s/^(.*?)(?:\r\n?|\n)//) 613 { 614 push @out, $1; 615 } 616 return @out; 617} 618 619sub fds($) 620{ 621 my ($self) = @_; 622 return $self->{connector}->fds(); 623} 624 625 626 627 628 629 630# main program... a gateway between IRC and DarkPlaces servers 631package main; 632 633use strict; 634use warnings; 635use IO::Select; 636use Digest::SHA; 637use Digest::HMAC; 638use Time::HiRes qw/time/; 639 640our @handlers = (); # list of [channel, expression, sub to handle result] 641our @tasks = (); # list of [time, sub] 642our %channels = (); 643our %store = ( 644 irc_nick => "", 645 playernick_byid_0 => "(console)", 646); 647our %config = ( 648 irc_server => undef, 649 irc_nick => undef, 650 irc_nick_alternates => "", 651 irc_user => undef, 652 irc_channel => undef, 653 irc_ping_delay => 120, 654 irc_trigger => "", 655 656 irc_nickserv_password => "", 657 irc_nickserv_identify => 'PRIVMSG NickServ :IDENTIFY %2$s', 658 irc_nickserv_ghost => 'PRIVMSG NickServ :GHOST %1$s %2$s', 659 irc_nickserv_ghost_attempts => 3, 660 661 irc_quakenet_authname => "", 662 irc_quakenet_password => "", 663 irc_quakenet_getchallenge => 'PRIVMSG Q@CServe.quakenet.org :CHALLENGE', 664 irc_quakenet_challengeauth => 'PRIVMSG Q@CServe.quakenet.org :CHALLENGEAUTH', 665 irc_quakenet_challengeprefix => ':Q!TheQBot@CServe.quakenet.org NOTICE [^:]+ :CHALLENGE', 666 667 irc_announce_slotsfree => 1, 668 irc_announce_mapchange => 'always', 669 670 dp_server => undef, 671 dp_secure => 1, 672 dp_listen => "", 673 dp_password => undef, 674 dp_status_delay => 30, 675 dp_server_from_wan => "", 676 irc_local => "", 677 678 irc_admin_password => "", 679 irc_admin_timeout => 3600, 680 irc_admin_quote_re => "", 681 682 irc_reconnect_delay => 300, 683 684 plugins => "", 685); 686 687 688 689# Nexuiz specific parsing of some server messages 690 691sub nex_slotsstring() 692{ 693 my $slotsstr = ""; 694 if(defined $store{slots_max}) 695 { 696 my $slots = $store{slots_max} - $store{slots_active}; 697 my $slots_s = ($slots == 1) ? '' : 's'; 698 $slotsstr = " ($slots free slot$slots_s)"; 699 my $s = $config{dp_server_from_wan} || $config{dp_server}; 700 $slotsstr .= "; join now: \002nexuiz +connect $s" 701 if $slots >= 1 and not $store{lms_blocked}; 702 } 703 return $slotsstr; 704} 705 706 707 708# Do we have a config file? If yes, read and parse it (syntax: key = value 709# pairs, separated by newlines), if not, complain. 710die "Usage: $0 configfile\n" 711 unless @ARGV == 1; 712 713open my $fh, "<", $ARGV[0] 714 or die "open $ARGV[0]: $!"; 715while(<$fh>) 716{ 717 chomp; 718 /^#/ and next; 719 /^(.*?)\s*=(?:\s*(.*))?$/ or next; 720 warn "Undefined config item: $1" 721 unless exists $config{$1}; 722 $config{$1} = defined $2 ? $2 : ""; 723} 724close $fh; 725my @missing = grep { !defined $config{$_} } keys %config; 726die "The following config items are missing: @missing" 727 if @missing; 728 729 730 731# Create a channel for error messages and other internal status messages... 732 733$channels{system} = new Channel::FIFO(); 734 735# for example, quit messages caused by signals (if SIGTERM or SIGINT is first 736# received, try to shut down cleanly, and if such a signal is received a second 737# time, just exit) 738my $quitting = 0; 739$SIG{INT} = sub { 740 exit 1 if $quitting++; 741 $channels{system}->send("quit SIGINT"); 742}; 743$SIG{TERM} = sub { 744 exit 1 if $quitting++; 745 $channels{system}->send("quit SIGTERM"); 746}; 747 748 749 750# Create the two channels to gateway between... 751 752$channels{irc} = new Channel::Line(new Connection::Socket(tcp => $config{irc_local} => $config{irc_server} => 6667)); 753$channels{dp} = new Channel::QW(my $dpsock = new Connection::Socket(udp => $config{dp_listen} => $config{dp_server} => 26000), $config{dp_password}, $config{dp_secure}); 754$config{dp_listen} = $dpsock->sockname(); 755print "Listening on $config{dp_listen}\n"; 756 757$channels{irc}->throttle(0.5, 5); 758 759 760# Utility routine to write to a channel by name, also outputting what's been written and some status 761sub out($$@) 762{ 763 my $chanstr = shift; 764 my $nothrottle = shift; 765 my $chan = $channels{$chanstr}; 766 if(!$chan) 767 { 768 print "UNDEFINED: $chanstr, ignoring message\n"; 769 return; 770 } 771 @_ = $chan->join_commands(@_); 772 for(@_) 773 { 774 my $result = $chan->send($_, $nothrottle); 775 if($result > 0) 776 { 777 print " $chanstr << $_\n"; 778 } 779 elsif($result < 0) 780 { 781 print "FLOOD: $chanstr << $_\n"; 782 } 783 else 784 { 785 print "ERROR: $chanstr << $_\n"; 786 $channels{system}->send("error $chanstr", 0); 787 } 788 } 789} 790 791 792 793# Schedule a task for later execution by the main loop; usage: schedule sub { 794# task... }, $time; When a scheduled task is run, a reference to the task's own 795# sub is passed as first argument; that way, the task is able to re-schedule 796# itself so it gets periodically executed. 797sub schedule($$) 798{ 799 my ($sub, $time) = @_; 800 push @tasks, [time() + $time, $sub]; 801} 802 803# On IRC error, delete some data store variables of the connection, and 804# reconnect to the IRC server soon (but only if someone is actually playing) 805sub irc_error() 806{ 807 # prevent multiple instances of this timer 808 return if $store{irc_error_active}; 809 $store{irc_error_active} = 1; 810 811 delete $channels{irc}; 812 schedule sub { 813 my ($timer) = @_; 814 if(!defined $store{slots_active}) 815 { 816 # DP is not running, then delay IRC reconnecting 817 #use Data::Dumper; print Dumper \$timer; 818 schedule $timer => 1; 819 return; 820 # this will keep irc_error_active 821 } 822 $channels{irc} = new Channel::Line(new Connection::Socket(tcp => "" => $config{irc_server} => 6667)); 823 delete $store{$_} for grep { /^irc_/ } keys %store; 824 $store{irc_nick} = ""; 825 schedule sub { 826 my ($timer) = @_; 827 out dp => 0, 'sv_cmd bans', 'status 1', 'log_dest_udp'; 828 $store{status_waiting} = -1; 829 } => 1; 830 # this will clear irc_error_active 831 } => $config{irc_reconnect_delay}; 832 return 0; 833} 834 835sub uniq(@) 836{ 837 my @out = (); 838 my %found = (); 839 for(@_) 840 { 841 next if $found{$_}++; 842 push @out, $_; 843 } 844 return @out; 845} 846 847# IRC joining (if this is called as response to a nick name collision, $is433 is set); 848# among other stuff, it performs NickServ or Quakenet authentication. This is to be called 849# until the channel has been joined for every message that may be "interesting" (basically, 850# IRC 001 hello messages, 443 nick collision messages and some notices by services). 851sub irc_joinstage($) 852{ 853 my($is433) = @_; 854 855 return 0 856 if $store{irc_joined_channel}; 857 858 #use Data::Dumper; print Dumper \%store; 859 860 if($is433) 861 { 862 if(length $store{irc_nick}) 863 { 864 # we already have another nick, but couldn't change to the new one 865 # try ghosting and then get the nick again 866 if(length $config{irc_nickserv_password}) 867 { 868 if(++$store{irc_nickserv_ghost_attempts} <= $config{irc_nickserv_ghost_attempts}) 869 { 870 $store{irc_nick_requested} = $config{irc_nick}; 871 out irc => 1, sprintf($config{irc_nickserv_ghost}, $config{irc_nick}, $config{irc_nickserv_password}); 872 schedule sub { 873 out irc => 1, "NICK $config{irc_nick}"; 874 } => 1; 875 return; # we'll get here again for the NICK success message, or for a 433 failure 876 } 877 # otherwise, we failed to ghost and will continue with the wrong 878 # nick... also, no need to try to identify here 879 } 880 # otherwise, we can't handle this and will continue with our wrong nick 881 } 882 else 883 { 884 # we failed to get an initial nickname 885 # change ours a bit and try again 886 887 my @alternates = uniq ($config{irc_nick}, grep { $_ ne "" } split /\s+/, $config{irc_nick_alternates}); 888 my $nextnick = undef; 889 for(0..@alternates-2) 890 { 891 if($store{irc_nick_requested} eq $alternates[$_]) 892 { 893 $nextnick = $alternates[$_+1]; 894 } 895 } 896 if($store{irc_nick_requested} eq $alternates[@alternates-1]) # this will only happen once 897 { 898 $store{irc_nick_requested} = $alternates[0]; 899 # but don't set nextnick, so we edit it 900 } 901 if(defined $nextnick) 902 { 903 $store{irc_nick_requested} = $nextnick; 904 } 905 else 906 { 907 for(;;) 908 { 909 if(length $store{irc_nick_requested} < 9) 910 { 911 $store{irc_nick_requested} .= '_'; 912 } 913 else 914 { 915 substr $store{irc_nick_requested}, int(rand length $store{irc_nick_requested}), 1, chr(97 + int rand 26); 916 } 917 last unless grep { $_ eq $store{irc_nick_requested} } @alternates; 918 } 919 } 920 out irc => 1, "NICK $store{irc_nick_requested}"; 921 return; # when it fails, we'll get here again, and when it succeeds, we will continue 922 } 923 } 924 925 # we got a 001 or a NICK message, so $store{irc_nick} has been updated 926 if(length $config{irc_nickserv_password}) 927 { 928 if($store{irc_nick} eq $config{irc_nick}) 929 { 930 # identify 931 out irc => 1, sprintf($config{irc_nickserv_identify}, $config{irc_nick}, $config{irc_nickserv_password}); 932 } 933 else 934 { 935 # ghost 936 if(++$store{irc_nickserv_ghost_attempts} <= $config{irc_nickserv_ghost_attempts}) 937 { 938 $store{irc_nick_requested} = $config{irc_nick}; 939 out irc => 1, sprintf($config{irc_nickserv_ghost}, $config{irc_nick}, $config{irc_nickserv_password}); 940 schedule sub { 941 out irc => 1, "NICK $config{irc_nick}"; 942 } => 1; 943 return; # we'll get here again for the NICK success message, or for a 433 failure 944 } 945 # otherwise, we failed to ghost and will continue with the wrong 946 # nick... also, no need to try to identify here 947 } 948 } 949 950 # we are on Quakenet. Try to authenticate. 951 if(length $config{irc_quakenet_password} and length $config{irc_quakenet_authname}) 952 { 953 if(defined $store{irc_quakenet_challenge}) 954 { 955 if($store{irc_quakenet_challenge} =~ /^([0-9a-f]*)\b.*\bHMAC-SHA-256\b/) 956 { 957 my $challenge = $1; 958 my $hash1 = Digest::SHA::sha256_hex(substr $config{irc_quakenet_password}, 0, 10); 959 my $key = Digest::SHA::sha256_hex("@{[lc $config{irc_quakenet_authname}]}:$hash1"); 960 my $digest = Digest::HMAC::hmac_hex($challenge, $key, \&Digest::SHA::sha256); 961 out irc => 1, "$config{irc_quakenet_challengeauth} $config{irc_quakenet_authname} $digest HMAC-SHA-256"; 962 } 963 } 964 else 965 { 966 out irc => 1, $config{irc_quakenet_getchallenge}; 967 return; 968 # we get here again when Q asks us 969 } 970 } 971 972 # if we get here, we are on IRC 973 $store{irc_joined_channel} = 1; 974 schedule sub { 975 out irc => 1, "JOIN $config{irc_channel}"; 976 } => 1; 977 return 0; 978} 979 980my $RE_FAIL = qr/$ $/; 981my $RE_SUCCEED = qr//; 982sub cond($) 983{ 984 return $_[0] ? $RE_FAIL : $RE_SUCCEED; 985} 986 987 988# List of all handlers on the various sockets. Additional handlers can be added by a plugin. 989@handlers = ( 990 # detect a server restart and set it up again 991 [ dp => q{ *(?:Warning: Could not expand \$|Unknown command ")(?:rcon2irc_[a-z0-9_]*)[" ]*} => sub { 992 out dp => 0, 993 'alias rcon2irc_eval "$*"', 994 'log_dest_udp', 995 'sv_logscores_console 0', 996 'sv_logscores_bots 1', 997 'sv_eventlog 1', 998 'sv_eventlog_console 1', 999 'alias rcon2irc_say_as "set say_as_restorenick \"$sv_adminnick\"; sv_adminnick \"$1^3\"; say \"^7$2\"; rcon2irc_say_as_restore"', 1000 'alias rcon2irc_say_as_restore "set sv_adminnick \"$say_as_restorenick\""', 1001 'alias rcon2irc_quit "echo \"quitting rcon2irc $1: log_dest_udp is $log_dest_udp\""'; # note: \\\\\\" ->perl \\\" ->console \" 1002 return 0; 1003 } ], 1004 1005 # detect missing entry in log_dest_udp and fix it 1006 [ dp => q{"log_dest_udp" is "([^"]*)" \["[^"]*"\]} => sub { 1007 my ($dest) = @_; 1008 my @dests = split ' ', $dest; 1009 return 0 if grep { $_ eq $config{dp_listen} } @dests; 1010 out dp => 0, 'log_dest_udp "' . join(" ", @dests, $config{dp_listen}) . '"'; 1011 return 0; 1012 } ], 1013 1014 # retrieve list of banned hosts 1015 [ dp => q{#(\d+): (\S+) is still banned for (\S+) seconds} => sub { 1016 return 0 unless $store{status_waiting} < 0; 1017 my ($id, $ip, $time) = @_; 1018 $store{bans_new} = [] if $id == 0; 1019 $store{bans_new}[$id] = { ip => $ip, 'time' => $time }; 1020 return 0; 1021 } ], 1022 1023 # retrieve hostname from status replies 1024 [ dp => q{host: (.*)} => sub { 1025 return 0 unless $store{status_waiting} < 0; 1026 my ($name) = @_; 1027 $store{dp_hostname} = $name; 1028 $store{bans} = $store{bans_new}; 1029 return 0; 1030 } ], 1031 1032 # retrieve version from status replies 1033 [ dp => q{version: (.*)} => sub { 1034 return 0 unless $store{status_waiting} < 0; 1035 my ($version) = @_; 1036 $store{dp_version} = $version; 1037 return 0; 1038 } ], 1039 1040 # retrieve player names 1041 [ dp => q{players: (\d+) active \((\d+) max\)} => sub { 1042 return 0 unless $store{status_waiting} < 0; 1043 my ($active, $max) = @_; 1044 my $full = ($active >= $max); 1045 $store{slots_max} = $max; 1046 $store{slots_active} = $active; 1047 $store{status_waiting} = $active; 1048 $store{playerslots_active_new} = []; 1049 if($store{status_waiting} == 0) 1050 { 1051 $store{playerslots_active} = $store{playerslots_active_new}; 1052 } 1053 if($full != ($store{slots_full} || 0)) 1054 { 1055 $store{slots_full} = $full; 1056 return 0 if $store{lms_blocked}; 1057 return 0 if !$config{irc_announce_slotsfree}; 1058 if($full) 1059 { 1060 out irc => 0, "PRIVMSG $config{irc_channel} :\001ACTION is full!\001"; 1061 } 1062 else 1063 { 1064 my $slotsstr = nex_slotsstring(); 1065 out irc => 0, "PRIVMSG $config{irc_channel} :\001ACTION can be joined again$slotsstr!\001"; 1066 } 1067 } 1068 return 0; 1069 } ], 1070 1071 # retrieve player names 1072 [ dp => q{\^\d(\S+)\s+(\d+)\s+(\d+)\s+(\S+)\s+(-?\d+)\s+\#(\d+)\s+\^\d(.*)} => sub { 1073 return 0 unless $store{status_waiting} > 0; 1074 my ($ip, $pl, $ping, $time, $frags, $no, $name) = ($1, $2, $3, $4, $5, $6, $7); 1075 $store{"playerslot_$no"} = { ip => $ip, pl => $pl, ping => $ping, 'time' => $time, frags => $frags, no => $no, name => $name }; 1076 push @{$store{playerslots_active_new}}, $no; 1077 if(--$store{status_waiting} == 0) 1078 { 1079 $store{playerslots_active} = $store{playerslots_active_new}; 1080 } 1081 return 0; 1082 } ], 1083 1084 # IRC admin commands 1085 [ irc => q{:(([^! ]*)![^ ]*) (?i:PRIVMSG) [^&#%]\S* :(.*)} => sub { 1086 return 0 unless $config{irc_admin_password} ne ''; 1087 1088 my ($hostmask, $nick, $command) = @_; 1089 my $dpnick = color_dpfix $nick; 1090 1091 if($command eq "login $config{irc_admin_password}") 1092 { 1093 $store{logins}{$hostmask} = time() + $config{irc_admin_timeout}; 1094 out irc => 0, "PRIVMSG $nick :my wish is your command"; 1095 return -1; 1096 } 1097 1098 if($command =~ /^login /) 1099 { 1100 out irc => 0, "PRIVMSG $nick :invalid password"; 1101 return -1; 1102 } 1103 1104 if(($store{logins}{$hostmask} || 0) < time()) 1105 { 1106 out irc => 0, "PRIVMSG $nick :authentication required"; 1107 return -1; 1108 } 1109 1110 if($command =~ /^status(?: (.*))?$/) 1111 { 1112 my ($match) = $1; 1113 my $found = 0; 1114 my $foundany = 0; 1115 for my $slot(@{$store{playerslots_active} || []}) 1116 { 1117 my $s = $store{"playerslot_$slot"}; 1118 next unless $s; 1119 if(not defined $match or index(color_dp2none($s->{name}), $match) >= 0) 1120 { 1121 out irc => 0, sprintf 'PRIVMSG %s :%-21s %2i %4i %8s %4i #%-3u %s', $nick, $s->{ip}, $s->{pl}, $s->{ping}, $s->{time}, $s->{frags}, $slot, color_dp2irc $s->{name}; 1122 ++$found; 1123 } 1124 ++$foundany; 1125 } 1126 if(!$found) 1127 { 1128 if(!$foundany) 1129 { 1130 out irc => 0, "PRIVMSG $nick :the server is empty"; 1131 } 1132 else 1133 { 1134 out irc => 0, "PRIVMSG $nick :no nicknames match"; 1135 } 1136 } 1137 return 0; 1138 } 1139 1140 if($command =~ /^kick # (\d+) (.*)$/) 1141 { 1142 my ($id, $reason) = ($1, $2); 1143 my $dpreason = color_irc2dp $reason; 1144 $dpreason =~ s/^(~?)(.*)/$1irc $dpnick: $2/g; 1145 $dpreason =~ s/(["\\])/\\$1/g; 1146 out dp => 0, "kick # $id $dpreason"; 1147 my $slotnik = "playerslot_$id"; 1148 out irc => 0, "PRIVMSG $nick :kicked #$id (@{[color_dp2irc $store{$slotnik}{name}]}\017 @ $store{$slotnik}{ip}) ($reason)"; 1149 return 0; 1150 } 1151 1152 if($command =~ /^kickban # (\d+) (\d+) (\d+) (.*)$/) 1153 { 1154 my ($id, $bantime, $mask, $reason) = ($1, $2, $3, $4); 1155 my $dpreason = color_irc2dp $reason; 1156 $dpreason =~ s/^(~?)(.*)/$1irc $dpnick: $2/g; 1157 $dpreason =~ s/(["\\])/\\$1/g; 1158 out dp => 0, "kickban # $id $bantime $mask $dpreason"; 1159 my $slotnik = "playerslot_$id"; 1160 out irc => 0, "PRIVMSG $nick :kickbanned #$id (@{[color_dp2irc $store{$slotnik}{name}]}\017 @ $store{$slotnik}{ip}), netmask $mask, for $bantime seconds ($reason)"; 1161 return 0; 1162 } 1163 1164 if($command eq "bans") 1165 { 1166 my $banlist = 1167 join ", ", 1168 map { "$_ ($store{bans}[$_]{ip}, $store{bans}[$_]{time}s)" } 1169 0..@{$store{bans} || []}-1; 1170 $banlist = "no bans" 1171 if $banlist eq ""; 1172 out irc => 0, "PRIVMSG $nick :$banlist"; 1173 return 0; 1174 } 1175 1176 if($command =~ /^unban (\d+)$/) 1177 { 1178 my ($id) = ($1); 1179 out dp => 0, "unban $id"; 1180 out irc => 0, "PRIVMSG $nick :removed ban $id ($store{bans}[$id]{ip})"; 1181 return 0; 1182 } 1183 1184 if($command =~ /^mute (\d+)$/) 1185 { 1186 my $id = $1; 1187 out dp => 0, "mute $id"; 1188 my $slotnik = "playerslot_$id"; 1189 out irc => 0, "PRIVMSG $nick :muted $id (@{[color_dp2irc $store{$slotnik}{name}]}\017 @ $store{$slotnik}{ip})"; 1190 return 0; 1191 } 1192 1193 if($command =~ /^unmute (\d+)$/) 1194 { 1195 my ($id) = ($1); 1196 out dp => 0, "unmute $id"; 1197 my $slotnik = "playerslot_$id"; 1198 out irc => 0, "PRIVMSG $nick :unmuted $id (@{[color_dp2irc $store{$slotnik}{name}]}\017 @ $store{$slotnik}{ip})"; 1199 return 0; 1200 } 1201 1202 if($command =~ /^quote (.*)$/) 1203 { 1204 my ($cmd) = ($1); 1205 if($cmd =~ /^(??{$config{irc_admin_quote_re}})$/si) 1206 { 1207 out irc => 0, $cmd; 1208 out irc => 0, "PRIVMSG $nick :executed your command"; 1209 } 1210 else 1211 { 1212 out irc => 0, "PRIVMSG $nick :permission denied"; 1213 } 1214 return 0; 1215 } 1216 1217 out irc => 0, "PRIVMSG $nick :unknown command (supported: status [substring], kick # id reason, kickban # id bantime mask reason, bans, unban banid, mute id, unmute id)"; 1218 1219 return -1; 1220 } ], 1221 1222 # LMS: detect "no more lives" message 1223 [ dp => q{\^4.*\^4 has no more lives left} => sub { 1224 if(!$store{lms_blocked}) 1225 { 1226 $store{lms_blocked} = 1; 1227 if(!$store{slots_full}) 1228 { 1229 schedule sub { 1230 if($store{lms_blocked}) 1231 { 1232 out irc => 0, "PRIVMSG $config{irc_channel} :\001ACTION can't be joined until next round (a player has no more lives left)\001"; 1233 } 1234 } => 1; 1235 } 1236 } 1237 } ], 1238 1239 # detect IRC errors and reconnect 1240 [ irc => q{ERROR .*} => \&irc_error ], 1241 [ irc => q{:[^ ]* 404 .*} => \&irc_error ], # cannot send to channel 1242 [ system => q{error irc} => \&irc_error ], 1243 1244 # IRC nick in use 1245 [ irc => q{:[^ ]* 433 .*} => sub { 1246 return irc_joinstage(433); 1247 } ], 1248 1249 # IRC welcome 1250 [ irc => q{:[^ ]* 001 .*} => sub { 1251 $store{irc_seen_welcome} = 1; 1252 $store{irc_nick} = $store{irc_nick_requested}; 1253 return irc_joinstage(0); 1254 } ], 1255 1256 # IRC my nickname changed 1257 [ irc => q{:(?i:(??{$store{irc_nick}}))![^ ]* (?i:NICK) :(.*)} => sub { 1258 my ($n) = @_; 1259 $store{irc_nick} = $n; 1260 return irc_joinstage(0); 1261 } ], 1262 1263 # Quakenet: challenge from Q 1264 [ irc => q{(??{$config{irc_quakenet_challengeprefix}}) (.*)} => sub { 1265 $store{irc_quakenet_challenge} = $1; 1266 return irc_joinstage(0); 1267 } ], 1268 1269 # shut down everything on SIGINT 1270 [ system => q{quit (.*)} => sub { 1271 my ($cause) = @_; 1272 out irc => 1, "QUIT :$cause"; 1273 $store{quitcookie} = int rand 1000000000; 1274 out dp => 0, "rcon2irc_quit $store{quitcookie}"; 1275 } ], 1276 1277 # remove myself from the log destinations and exit everything 1278 [ dp => q{quitting rcon2irc (??{$store{quitcookie}}): log_dest_udp is (.*) *} => sub { 1279 my ($dest) = @_; 1280 my @dests = grep { $_ ne $config{dp_listen} } split ' ', $dest; 1281 out dp => 0, 'log_dest_udp "' . join(" ", @dests) . '"'; 1282 exit 0; 1283 return 0; 1284 } ], 1285 1286 # IRC PING 1287 [ irc => q{PING (.*)} => sub { 1288 my ($data) = @_; 1289 out irc => 1, "PONG $data"; 1290 return 1; 1291 } ], 1292 1293 # IRC PONG 1294 [ irc => q{:[^ ]* PONG .* :(.*)} => sub { 1295 my ($data) = @_; 1296 return 0 1297 if not defined $store{irc_pingtime}; 1298 return 0 1299 if $data ne $store{irc_pingtime}; 1300 print "* measured IRC line delay: @{[time() - $store{irc_pingtime}]}\n"; 1301 undef $store{irc_pingtime}; 1302 return 0; 1303 } ], 1304 1305 # detect channel join message and note hostname length to get the maximum allowed line length 1306 [ irc => q{(:(?i:(??{$store{irc_nick}}))![^ ]* )(?i:JOIN) :(?i:(??{$config{irc_channel}}))} => sub { 1307 $store{irc_maxlen} = 510 - length($1); 1308 $store{irc_joined_channel} = 1; 1309 print "* detected maximum line length for channel messages: $store{irc_maxlen}\n"; 1310 return 0; 1311 } ], 1312 1313 # chat: Nexuiz server -> IRC channel 1314 [ dp => q{\001(.*?)\^7: (.*)} => sub { 1315 my ($nick, $message) = map { color_dp2irc $_ } @_; 1316 out irc => 0, "PRIVMSG $config{irc_channel} :<$nick\017> $message"; 1317 return 0; 1318 } ], 1319 1320 # chat: Nexuiz server -> IRC channel, nick set 1321 [ dp => q{:join:(\d+):(\d+):([^:]*):(.*)} => sub { 1322 my ($id, $slot, $ip, $nick) = @_; 1323 $store{"playernickraw_byid_$id"} = $nick; 1324 $nick = color_dp2irc $nick; 1325 $store{"playernick_byid_$id"} = $nick; 1326 $store{"playerip_byid_$id"} = $ip; 1327 $store{"playerslot_byid_$id"} = $slot; 1328 $store{"playerid_byslot_$slot"} = $id; 1329 return 0; 1330 } ], 1331 1332 # chat: Nexuiz server -> IRC channel, nick change/set 1333 [ dp => q{:name:(\d+):(.*)} => sub { 1334 my ($id, $nick) = @_; 1335 $store{"playernickraw_byid_$id"} = $nick; 1336 $nick = color_dp2irc $nick; 1337 my $oldnick = $store{"playernick_byid_$id"}; 1338 out irc => 0, "PRIVMSG $config{irc_channel} :* $oldnick\017 is now known as $nick"; 1339 $store{"playernick_byid_$id"} = $nick; 1340 return 0; 1341 } ], 1342 1343 # chat: Nexuiz server -> IRC channel, vote call 1344 [ dp => q{:vote:vcall:(\d+):(.*)} => sub { 1345 my ($id, $command) = @_; 1346 $command = color_dp2irc $command; 1347 my $oldnick = $id ? $store{"playernick_byid_$id"} : "(console)"; 1348 out irc => 0, "PRIVMSG $config{irc_channel} :* $oldnick\017 calls a vote for \"$command\017\""; 1349 return 0; 1350 } ], 1351 1352 # chat: Nexuiz server -> IRC channel, vote stop 1353 [ dp => q{:vote:vstop:(\d+)} => sub { 1354 my ($id) = @_; 1355 my $oldnick = $id ? $store{"playernick_byid_$id"} : "(console)"; 1356 out irc => 0, "PRIVMSG $config{irc_channel} :* $oldnick\017 stopped the vote"; 1357 return 0; 1358 } ], 1359 1360 # chat: Nexuiz server -> IRC channel, master login 1361 [ dp => q{:vote:vlogin:(\d+)} => sub { 1362 my ($id) = @_; 1363 my $oldnick = $id ? $store{"playernick_byid_$id"} : "(console)"; 1364 out irc => 0, "PRIVMSG $config{irc_channel} :* $oldnick\017 logged in as master"; 1365 return 0; 1366 } ], 1367 1368 # chat: Nexuiz server -> IRC channel, master do 1369 [ dp => q{:vote:vdo:(\d+):(.*)} => sub { 1370 my ($id, $command) = @_; 1371 $command = color_dp2irc $command; 1372 my $oldnick = $id ? $store{"playernick_byid_$id"} : "(console)"; 1373 out irc => 0, "PRIVMSG $config{irc_channel} :* $oldnick\017 used his master status to do \"$command\017\""; 1374 return 0; 1375 } ], 1376 1377 # chat: Nexuiz server -> IRC channel, result 1378 [ dp => q{:vote:v(yes|no|timeout):(\d+):(\d+):(\d+):(\d+):(-?\d+)} => sub { 1379 my ($result, $yes, $no, $abstain, $not, $min) = @_; 1380 my $spam = "$yes:$no" . (($min >= 0) ? " ($min needed)" : "") . ", $abstain didn't care, $not didn't vote"; 1381 out irc => 0, "PRIVMSG $config{irc_channel} :* the vote ended with $result: $spam"; 1382 return 0; 1383 } ], 1384 1385 # chat: IRC channel -> Nexuiz server 1386 [ irc => q{:([^! ]*)![^ ]* (?i:PRIVMSG) (?i:(??{$config{irc_channel}})) :(?i:(??{$store{irc_nick}}))(?: |: ?|, ?)(.*)} => sub { 1387 my ($nick, $message) = @_; 1388 $nick = color_dpfix $nick; 1389 # allow the nickname to contain colors in DP format! Therefore, NO color_irc2dp on the nickname! 1390 $message = color_irc2dp $message; 1391 $message =~ s/(["\\])/\\$1/g; 1392 out dp => 0, "rcon2irc_say_as \"$nick on IRC\" \"$message\""; 1393 return 0; 1394 } ], 1395 1396 ( 1397 length $config{irc_trigger} 1398 ? 1399 [ irc => q{:([^! ]*)![^ ]* (?i:PRIVMSG) (?i:(??{$config{irc_channel}})) :(?i:(??{$config{irc_trigger}}))(?: |: ?|, ?)(.*)} => sub { 1400 my ($nick, $message) = @_; 1401 $nick = color_dpfix $nick; 1402 # allow the nickname to contain colors in DP format! Therefore, NO color_irc2dp on the nickname! 1403 $message = color_irc2dp $message; 1404 $message =~ s/(["\\])/\\$1/g; 1405 out dp => 0, "rcon2irc_say_as \"$nick on IRC\" \"$message\""; 1406 return 0; 1407 } ] 1408 : 1409 () 1410 ), 1411 1412 # irc: CTCP VERSION reply 1413 [ irc => q{:([^! ]*)![^ ]* (?i:PRIVMSG) (?i:(??{$store{irc_nick}})) :\001VERSION( .*)?\001} => sub { 1414 my ($nick) = @_; 1415 my $ver = $store{dp_version} or return 0; 1416 $ver .= ", rcon2irc $VERSION"; 1417 out irc => 0, "NOTICE $nick :\001VERSION $ver\001"; 1418 } ], 1419 1420 # on game start, notify the channel 1421 [ dp => q{:gamestart:(.*):[0-9.]*} => sub { 1422 my ($map) = @_; 1423 $store{playing} = 1; 1424 $store{map} = $map; 1425 $store{map_starttime} = time(); 1426 if ($config{irc_announce_mapchange} eq 'always' || ($config{irc_announce_mapchange} eq 'notempty' && $store{slots_active} > 0)) { 1427 my $slotsstr = nex_slotsstring(); 1428 out irc => 0, "PRIVMSG $config{irc_channel} :\00304" . $map . "\017 has begun$slotsstr"; 1429 } 1430 delete $store{lms_blocked}; 1431 return 0; 1432 } ], 1433 1434 # on game over, clear the current map 1435 [ dp => q{:gameover} => sub { 1436 $store{playing} = 0; 1437 return 0; 1438 } ], 1439 1440 # scores: Nexuiz server -> IRC channel (start) 1441 [ dp => q{:scores:(.*):(\d+)} => sub { 1442 my ($map, $time) = @_; 1443 $store{scores} = {}; 1444 $store{scores}{map} = $map; 1445 $store{scores}{time} = $time; 1446 $store{scores}{players} = []; 1447 delete $store{lms_blocked}; 1448 return 0; 1449 } ], 1450 1451 # scores: Nexuiz server -> IRC channel, legacy format 1452 [ dp => q{:player:(-?\d+):(\d+):(\d+):(\d+):(\d+):(.*)} => sub { 1453 my ($frags, $deaths, $time, $team, $id, $name) = @_; 1454 return if not exists $store{scores}; 1455 push @{$store{scores}{players}}, [$frags, $team, $name] 1456 unless $frags <= -666; # no spectators 1457 return 0; 1458 } ], 1459 1460 # scores: Nexuiz server -> IRC channel (CTF), legacy format 1461 [ dp => q{:teamscores:(\d+:-?\d*(?::\d+:-?\d*)*)} => sub { 1462 my ($teams) = @_; 1463 return if not exists $store{scores}; 1464 $store{scores}{teams} = {split /:/, $teams}; 1465 return 0; 1466 } ], 1467 1468 # scores: Nexuiz server -> IRC channel, new format 1469 [ dp => q{:player:see-labels:(-?\d+)[-0-9,]*:(\d+):(\d+):(\d+):(.*)} => sub { 1470 my ($frags, $time, $team, $id, $name) = @_; 1471 return if not exists $store{scores}; 1472 push @{$store{scores}{players}}, [$frags, $team, $name]; 1473 return 0; 1474 } ], 1475 1476 # scores: Nexuiz server -> IRC channel (CTF), new format 1477 [ dp => q{:teamscores:see-labels:(-?\d+)[-0-9,]*:(\d+)} => sub { 1478 my ($frags, $team) = @_; 1479 return if not exists $store{scores}; 1480 $store{scores}{teams}{$team} = $frags; 1481 return 0; 1482 } ], 1483 1484 # scores: Nexuiz server -> IRC channel 1485 [ dp => q{:end} => sub { 1486 return if not exists $store{scores}; 1487 my $s = $store{scores}; 1488 delete $store{scores}; 1489 my $teams_matter = defined $s->{teams}; 1490 1491 my @t = (); 1492 my @p = (); 1493 1494 if($teams_matter) 1495 { 1496 # put players into teams 1497 my %t = (); 1498 for(@{$s->{players}}) 1499 { 1500 my $thisteam = ($t{$_->[1]} ||= {score => 0, team => $_->[1], players => []}); 1501 push @{$thisteam->{players}}, [$_->[0], $_->[1], $_->[2]]; 1502 if($s->{teams}) 1503 { 1504 $thisteam->{score} = $s->{teams}{$_->[1]}; 1505 } 1506 else 1507 { 1508 $thisteam->{score} += $_->[0]; 1509 } 1510 } 1511 1512 # sort by team score 1513 @t = sort { $b->{score} <=> $a->{score} } values %t; 1514 1515 # sort by player score 1516 @p = (); 1517 for(@t) 1518 { 1519 @{$_->{players}} = sort { $b->[0] <=> $a->[0] } @{$_->{players}}; 1520 push @p, @{$_->{players}}; 1521 } 1522 } 1523 else 1524 { 1525 @p = sort { $b->[0] <=> $a->[0] } @{$s->{players}}; 1526 } 1527 1528 # no display for empty server 1529 return 0 1530 if !@p; 1531 1532 # make message fit somehow 1533 for my $maxnamelen(reverse 3..64) 1534 { 1535 my $scores_string = "PRIVMSG $config{irc_channel} :\00304" . $s->{map} . "\017 ended:"; 1536 if($teams_matter) 1537 { 1538 my $sep = ' '; 1539 for(@t) 1540 { 1541 $scores_string .= $sep . "\003" . $color_team2irc_table{$_->{team}}. "\002\002" . $_->{score} . "\017"; 1542 $sep = ':'; 1543 } 1544 } 1545 my $sep = ''; 1546 for(@p) 1547 { 1548 my ($frags, $team, $name) = @$_; 1549 $name = color_dpfix substr($name, 0, $maxnamelen); 1550 if($teams_matter) 1551 { 1552 $name = "\003" . $color_team2irc_table{$team} . " " . color_dp2none $name; 1553 } 1554 else 1555 { 1556 $name = " " . color_dp2irc $name; 1557 } 1558 $scores_string .= "$sep$name\017 $frags"; 1559 $sep = ','; 1560 } 1561 if(length($scores_string) <= ($store{irc_maxlen} || 256)) 1562 { 1563 out irc => 0, $scores_string; 1564 return 0; 1565 } 1566 } 1567 out irc => 0, "PRIVMSG $config{irc_channel} :\001ACTION would have LIKED to put the scores here, but they wouldn't fit :(\001"; 1568 return 0; 1569 } ], 1570 1571 # complain when system load gets too high 1572 [ dp => q{timing: (([0-9.]*)% CPU, ([0-9.]*)% lost, offset avg ([0-9.]*)ms, max ([0-9.]*)ms, sdev ([0-9.]*)ms)} => sub { 1573 my ($all, $cpu, $lost, $avg, $max, $sdev) = @_; 1574 return 0 # don't complain when just on the voting screen 1575 if !$store{playing}; 1576 return 0 # don't complain if it was less than 0.5% 1577 if $lost < 0.5; 1578 return 0 # don't complain if nobody is looking 1579 if $store{slots_active} == 0; 1580 return 0 # don't complain in the first two minutes 1581 if time() - $store{map_starttime} < 120; 1582 return 0 # don't complain if it was already at least half as bad in this round 1583 if $store{map_starttime} == $store{timingerror_map_starttime} and $lost <= 2 * $store{timingerror_lost}; 1584 $store{timingerror_map_starttime} = $store{map_starttime}; 1585 $store{timingerror_lost} = $lost; 1586 out dp => 0, 'rcon2irc_say_as server "There are currently some severe system load problems. The admins have been notified."'; 1587 out irc => 1, "PRIVMSG $config{irc_channel} :\001ACTION has big trouble on $store{map} after @{[int(time() - $store{map_starttime})]}s: $all\001"; 1588 #out irc => 1, "PRIVMSG OpBaI :\001ACTION has big trouble on $store{map} after @{[int(time() - $store{map_starttime})]}s: $all\001"; 1589 return 0; 1590 } ], 1591); 1592 1593 1594 1595# Load plugins and add them to the handler list in the front. 1596for my $p(split ' ', $config{plugins}) 1597{ 1598 my @h = eval { do $p; } 1599 or die "Invalid plugin $p: $@"; 1600 for(reverse @h) 1601 { 1602 ref $_ eq 'ARRAY' or die "Invalid plugin $p: did not return a list of arrays"; 1603 @$_ == 3 or die "Invalid plugin $p: did not return a list of three-element arrays"; 1604 !ref $_->[0] && !ref $_->[1] && ref $_->[2] eq 'CODE' or die "Invalid plugin $p: did not return a list of string-string-sub arrays"; 1605 unshift @handlers, $_; 1606 } 1607} 1608 1609 1610 1611# verify that the server is up by letting it echo back a string that causes 1612# re-initialization of the required aliases 1613out dp => 0, 'echo "Unknown command \"rcon2irc_eval\""'; # assume the server has been restarted 1614 1615 1616 1617# regularily, query the server status and if it still is connected to us using 1618# the log_dest_udp feature. If not, we will detect the response to this rcon 1619# command and re-initialize the server's connection to us (either by log_dest_udp 1620# not containing our own IP:port, or by rcon2irc_eval not being a defined command). 1621schedule sub { 1622 my ($timer) = @_; 1623 out dp => 0, 'sv_cmd bans', 'status 1', 'log_dest_udp', 'rcon2irc_eval set dummy 1'; 1624 $store{status_waiting} = -1; 1625 schedule $timer => (exists $store{dp_hostname} ? $config{dp_status_delay} : 1);; 1626} => 1; 1627 1628 1629 1630# Continue with connecting to IRC as soon as we get our first status reply from 1631# the DP server (which contains the server's hostname that we'll use as 1632# realname for IRC). 1633schedule sub { 1634 my ($timer) = @_; 1635 1636 # log on to IRC when needed 1637 if(exists $store{dp_hostname} && !exists $store{irc_logged_in}) 1638 { 1639 $store{irc_nick_requested} = $config{irc_nick}; 1640 out irc => 1, "NICK $config{irc_nick}", "USER $config{irc_user} localhost localhost :$store{dp_hostname}"; 1641 $store{irc_logged_in} = 1; 1642 undef $store{irc_maxlen}; 1643 undef $store{irc_pingtime}; 1644 } 1645 1646 schedule $timer => 1;; 1647} => 1; 1648 1649 1650 1651# Regularily ping the IRC server to detect if the connection is down. If it is, 1652# schedule an IRC error that will cause reconnection later. 1653schedule sub { 1654 my ($timer) = @_; 1655 1656 if($store{irc_logged_in}) 1657 { 1658 if(defined $store{irc_pingtime}) 1659 { 1660 # IRC connection apparently broke 1661 # so... KILL IT WITH FIRE 1662 $channels{system}->send("error irc", 0); 1663 } 1664 else 1665 { 1666 # everything is fine, send a new ping 1667 $store{irc_pingtime} = time(); 1668 out irc => 1, "PING $store{irc_pingtime}"; 1669 } 1670 } 1671 1672 schedule $timer => $config{irc_ping_delay};; 1673} => 1; 1674 1675 1676 1677# Main loop. 1678for(;;) 1679{ 1680 # Build up an IO::Select object for all our channels. 1681 my $s = IO::Select->new(); 1682 for my $chan(values %channels) 1683 { 1684 $s->add($_) for $chan->fds(); 1685 } 1686 1687 # wait for something to happen on our sockets, or wait 2 seconds without anything happening there 1688 $s->can_read(2); 1689 my @errors = $s->has_exception(0); 1690 1691 # on every channel, look for incoming messages 1692 CHANNEL: 1693 for my $chanstr(keys %channels) 1694 { 1695 my $chan = $channels{$chanstr}; 1696 my @chanfds = $chan->fds(); 1697 1698 for my $chanfd(@chanfds) 1699 { 1700 if(grep { $_ == $chanfd } @errors) 1701 { 1702 # STOP! This channel errored! 1703 $channels{system}->send("error $chanstr", 0); 1704 next CHANNEL; 1705 } 1706 } 1707 1708 eval 1709 { 1710 for my $line($chan->recv()) 1711 { 1712 # found one! Check if it matches the regular expression of one of 1713 # our handlers... 1714 my $handled = 0; 1715 my $private = 0; 1716 for my $h(@handlers) 1717 { 1718 my ($chanstr_wanted, $re, $sub) = @$h; 1719 next 1720 if $chanstr_wanted ne $chanstr; 1721 use re 'eval'; 1722 my @matches = ($line =~ /^$re$/s); 1723 no re 'eval'; 1724 next 1725 unless @matches; 1726 # and if it is a match, handle it. 1727 ++$handled; 1728 my $result = $sub->(@matches); 1729 $private = 1 1730 if $result < 0; 1731 last 1732 if $result; 1733 } 1734 # print the message, together with info on whether it has been handled or not 1735 if($private) 1736 { 1737 print " $chanstr >> (private)\n"; 1738 } 1739 elsif($handled) 1740 { 1741 print " $chanstr >> $line\n"; 1742 } 1743 else 1744 { 1745 print "unhandled: $chanstr >> $line\n"; 1746 } 1747 } 1748 1; 1749 } or do { 1750 if($@ eq "read error\n") 1751 { 1752 $channels{system}->send("error $chanstr", 0); 1753 next CHANNEL; 1754 } 1755 else 1756 { 1757 # re-throw 1758 die $@; 1759 } 1760 }; 1761 } 1762 1763 # handle scheduled tasks... 1764 my @t = @tasks; 1765 my $t = time(); 1766 # by emptying the list of tasks... 1767 @tasks = (); 1768 for(@t) 1769 { 1770 my ($time, $sub) = @$_; 1771 if($t >= $time) 1772 { 1773 # calling them if they are schedled for the "past"... 1774 $sub->($sub); 1775 } 1776 else 1777 { 1778 # or re-adding them to the task list if they still are scheduled for the "future" 1779 push @tasks, [$time, $sub]; 1780 } 1781 } 1782} 1783