branches/0.5.0/SrSv/IRCd/IO.pm

   1 #       This file is part of SurrealServices.
   2 #
   3 #       SurrealServices is free software; you can redistribute it and/or modify
   4 #       it under the terms of the GNU General Public License as published by
   5 #       the Free Software Foundation; either version 2 of the License, or
   6 #       (at your option) any later version.
   7 #
   8 #       SurrealServices is distributed in the hope that it will be useful,
   9 #       but WITHOUT ANY WARRANTY; without even the implied warranty of
  10 #       MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11 #       GNU General Public License for more details.
  12 #
  13 #       You should have received a copy of the GNU General Public License
  14 #       along with SurrealServices; if not, write to the Free Software
  15 #       Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  16
  17 package SrSv::IRCd::IO;
  18
  19 use strict;
  20
  21 use Exporter 'import';
  22 BEGIN { our @EXPORT_OK = qw(ircd_connect ircd_disconnect ircsendimm ircsend ircd_flush_queue ) }
  23
  24 use constant {
  25         NL => "\015\012",
  26 };
  27
  28 use Errno ':POSIX';
  29 use Event;
  30 use SrSv::Conf 'main';
  31 use SrSv::Process::InParent qw(irc_connect ircsend ircsendimm ircd_flush_queue);
  32 use SrSv::Process::Worker qw(ima_worker);
  33 use SrSv::Debug;
  34 use SrSv::IRCd::State qw($ircline $ircline_real $ircd_ready);
  35 use SrSv::IRCd::Event qw(callfuncs);
  36 use SrSv::Unreal::Tokens qw( :tokens );
  37 use SrSv::IRCd::Parse qw(parse_line);
  38 use SrSv::RunLevel qw(emerg_shutdown);
  39 use SrSv::Log qw( write_log );
  40
  41 our $irc_sock;
  42 our @queue;
  43 our $flood_queue;
  44
  45 sub irc_error($) {
  46         print "IRC connection failed", ($_[0] ? ": $_[0]\n" : ".\n");
  47         emerg_shutdown;
  48 }
  49
  50 {
  51         my $partial;
  52
  53         sub ircrecv {
  54                 my ($in, $r);
  55                 while($r = $irc_sock->sysread(my $part, 4096) > 0) {
  56                         $in .= $part;
  57                 }
  58
  59                 irc_error($!) if($r <= 0 and not $!{EAGAIN});
  60
  61                 my @lines = split(/\015\012/, $in);
  62
  63                 $lines[0] = $partial . $lines[0];
  64                 if($in =~ /\015\012$/s) {
  65                         $partial = '';
  66                 } else {
  67                         $partial = pop @lines;
  68                 }
  69
  70                 foreach my $line (@lines) {
  71                         $ircline_real++ unless $line =~ /^(?:8|PING)/;
  72                         write_log('netdump', '', $line) if main::NETDUMP();
  73                         print ">> $ircline_real $line\n" if DEBUG_ANY;
  74                         foreach my $ev (parse_line($line)) {
  75                                 next unless $ev;
  76
  77                                 callfuncs(@$ev);
  78                         }
  79                 }
  80         }
  81 }
  82
  83 {
  84         my $watcher;
  85
  86         sub ircd_connect($$) {
  87                 my ($remote, $port) = @_;
  88
  89                 print "Connecting..." if DEBUG;
  90                 $irc_sock = IO::Socket::INET->new(
  91                         PeerAddr => $remote,
  92                         PeerPort => $port,
  93                         Proto => 'tcp',
  94                         Blocking => 1,
  95                 ) or die("Could not connect to IRC server ($remote:$port): $!");
  96                 $irc_sock->blocking(0);
  97                 print " done\n" if DEBUG;
  98
  99                 $irc_sock->autoflush(1);
 100
 101                 $watcher = Event->io(
 102                         cb => \&ircrecv,
 103                         fd => $irc_sock,
 104                         nice => -1,
 105                 );
 106         }
 107
 108         sub ircd_disconnect() {
 109                 ircd_flush_queue();
 110                 $watcher->cancel;
 111                 $irc_sock->close;
 112         }
 113 }
 114
 115 sub ircsendimm {
 116         print "ircsendimm()  ima_worker: ", ima_worker(), "\n" if DEBUG;
 117
 118         if(defined $flood_queue) {
 119                 print "FLOOD QUEUE ACTIVE\n" if DEBUG;
 120                 push @$flood_queue, @_;
 121                 return;
 122         }
 123
 124         while(my $line = shift @_) {
 125                 my $r;
 126                 my $bytes = 0;
 127                 my $len = length($line) + 2;
 128                 write_log('netdump', '', split(NL, $line))
 129                         if main::NETDUMP();
 130                 while(1) {
 131                         $r = $irc_sock->syswrite($line . NL, undef, $bytes);
 132                         $bytes += $r if $r > 0;
 133
 134                         if($r <= 0 or $r < $len) {
 135                                 if($!{EAGAIN} or ($r > 0 and $r < $len)) {
 136                                         # Hold off to avoid flooding off
 137                                         print "FLOOD QUEUE ACTIVE\n" if DEBUG;
 138
 139                                         $flood_queue = [];
 140
 141                                         push @$flood_queue, substr($line, $bytes) unless $bytes == $len;
 142                                         push @$flood_queue, @_;
 143
 144                                         Event->idle (
 145                                                 min => 1,
 146                                                 max => 10,
 147                                                 repeat => 0,
 148                                                 cb => \&flush_flood_queue
 149                                         );
 150
 151                                         return;
 152                                 } else {
 153                                         irc_error($!);
 154                                         return;
 155                                 }
 156                         }
 157
 158                         last if($bytes == $len);
 159                 }
 160                 print "<< $line\n" if DEBUG_ANY;
 161         }
 162 }
 163
 164 sub ircsend {
 165         print "ircsend()  ima_worker: ", ima_worker(), "\n" if DEBUG;
 166         if(DEBUG) {
 167                 foreach my $x (@_) {
 168                         print "<< $ircline $x\n";
 169                 }
 170         }
 171
 172         if($ircd_ready) {
 173                 ircsendimm(@_);
 174         } else {
 175                 foreach my $x (@_) {
 176                         if($x =~ /^@{[TOK_NICK]}/) {
 177                                 unshift @queue, $x;
 178                         } else {
 179                                 push @queue, $x;
 180                         }
 181                 }
 182         }
 183 }
 184
 185 sub ircd_flush_queue() {
 186         ircsendimm(@queue);
 187         undef @queue;
 188 }
 189
 190 sub flush_flood_queue() {
 191         my $q = $flood_queue;
 192         undef $flood_queue;
 193         ircsendimm(@$q);
 194 }
 195
 196 1;