branches/0.5.0/SrSv/Unreal/Send.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 package ircd;
  17
  18 use strict;
  19 use IO::Socket::INET;
  20 use Event;
  21 use Carp;
  22 use MIME::Base64;
  23 use Data::Dumper;
  24 use SrSv::Conf 'main';
  25 use SrSv::Conf::main;
  26 use SrSv::Conf2Consts qw( main );
  27 use SrSv::Debug;
  28 use SrSv::Log;
  29 use Exporter 'import';
  30 our @EXPORT = qw (agent_doconn getUuid getRevUuid setUuid setRevUuid);
  31 # FIXME
  32 use constant {
  33         MAXBUFLEN => 510,
  34
  35 # These appear to match the implementations I've seen, but are unspecified in the RFCs.
  36 # They may vary by implementation.
  37         NICKLEN => 30, # some ircds are different. hyperion is 16.
  38         IDENTLEN => 10, # Sometimes 8 or 9.
  39                         # hyperion may break this due to it's ident format: [ni]=identhere, like this n=northman
  40         HOSTLEN => 63, # I think I've seen 64 here before.
  41         MASKLEN => 30 + 10 + 63 + 2, # 105, or maybe 106. the 2 constant is for !@
  42
  43         CHANNELLEN => 32, # From 005 reply. hyperion is 30.
  44
  45         SJ3 => 1,
  46         NOQUIT => 1,
  47         NICKIP => 1,
  48         SJB64 => 1,
  49         CLK => 1,
  50
  51         PREFIXAQ_DISABLE => 0,
  52 };
  53 die "NICKIP must be enabled if CLK is\n" if CLK && !NICKIP;
  54
  55 use SrSv::IRCd::IO qw(ircd_connect ircsend ircsendimm ircd_flush_queue);
  56 use SrSv::IRCd::Event qw(addhandler callfuncs);
  57 use SrSv::IRCd::State qw($ircline $remoteserv $ircd_ready synced initial_synced set_server_state set_server_juped get_server_state get_online_servers);
  58
  59 use SrSv::Unreal::Modes qw(@opmodes %opmodes $scm $ocm $acm);
  60 use SrSv::Unreal::Tokens;
  61 use SrSv::IRCd::Parse qw(parse_tkl parse_addline);
  62 use SrSv::Unreal::Base64 qw(itob64 b64toi);
  63
  64 use SrSv::Text::Format qw( wordwrap );
  65
  66 use SrSv::Agent;
  67
  68 use SrSv::Process::InParent qw(update_userkill);
  69
  70 our %defer_mode;
  71 our %preconnect_defer_mode;
  72 our @userkill;
  73 our $unreal_protocol_version;
  74 our $count = 65;
  75 our %uuids; #NickServ -> AAAAAA
  76 our %reverse_uuids; #AAAAA -> NickServ
  77 addhandler('SEOS', undef(), undef(), 'ircd::eos', 1);
  78 addhandler('NETINFO', undef(), undef(), 'ircd::netinfo', 1);
  79 addhandler('VERSION', undef(), undef(), 'ircd::version', 1);
  80 addhandler('SERVER', undef(), undef(), 'ircd::handle_server', 1);
  81 sub getAgentRevUuid($) {
  82         return undef;
  83 }
  84 sub getAgentUuid($) {
  85         return undef;
  86 }
  87 sub setAgentRevUuid ($$) {
  88 }
  89 sub setAgentUuid ($$) {
  90
  91 }
  92 sub serv_connect() {
  93         my $remote = main_conf_remote;
  94         my $port = main_conf_port;
  95
  96         ircd_connect($remote, $port);
  97
  98         ircsendimm('PROTOCTL '.(main_conf_tokens ? 'TOKEN ' : '').'NICKv2 UMODE2 TKLEXT'.
  99                 (CLK ? ' CLK' : ' VHP'). # CLK obsoletes VHP. Plus if you leave VHP on, CLK doesn't work.
 100                 (NOQUIT ? ' NOQUIT' : '').(SJ3 ? ' SJOIN SJOIN2 SJ3' : '').
 101                 (NICKIP ? ' NICKIP' : '').
 102                 (SJB64 ? ' SJB64 NS VL' : ''),
 103                 'PASS :'.main_conf_pass,
 104                 'SERVER '.main_conf_local.' 1 '.main_conf_numeric.(SJB64 ? ( ':U*-*-'.main_conf_numeric.' ') : ' :').main_conf_info);
 105
 106         %preconnect_defer_mode = %defer_mode;
 107         %defer_mode = ();
 108 }
 109
 110
 111 # Helper Functions
 112
 113 sub handle_server($$$$;$$$) {
 114 # This is mostly a stub function, but we may need the $unreal_protocol_version
 115 # at a later date. Plus we may want to maintain a server tree in another module.
 116         my ($src_server, $server_name, $num_hops, $info_line, $server_numeric, $protocol_version, $build_flags) = @_;
 117         $unreal_protocol_version = $protocol_version if defined $protocol_version;
 118 }
 119
 120
 121
 122 # Handler functions
 123 sub pong($$$) {
 124     my ($src, $cookie, $dst) = @_;
 125         # This will only make sense if you remember that
 126         # $src is where it came from, $dst is where it went (us)
 127         # we're basically bouncing it back, but changing from PING to PONG.
 128         if (defined($dst) and defined($cookie)) {
 129                 # $dst is always $main_conf{local} anyway...
 130                 # this is only valid b/c we never have messages routed THROUGH us
 131                 # we are always an end point.
 132                 ircsendimm(":$dst PONG $src :$cookie");
 133         }
 134         else {
 135                 ircsendimm("PONG :$src");
 136         }
 137 }
 138 sub eos {
 139         print "GOT EOS\n\n";
 140
 141         #foreach my $k (keys %servers) {
 142         #       print "Server: $k ircline: ",$servers{$k}[0], " state: ", $servers{$k}[1], "\n";
 143         #}
 144         #print "Synced: ", synced(), "\n\n";
 145         #exit;
 146
 147         ircsendimm(':'.$main_conf{local}.' EOS');
 148         ircsendimm(':'.$main_conf{local}.' VERSION');
 149         agent_sync();
 150         flushmodes(\%preconnect_defer_mode);
 151         ircd_flush_queue();
 152
 153         $ircd_ready = 1;
 154 }
 155
 156 sub netinfo($$$$$$$$) {
 157         ircsendimm('NETINFO 0 '.time." $_[2] $_[3] 0 0 0 :$_[7]");
 158         $main_conf{network} = $_[7];
 159 }
 160
 161 sub tssync {
 162         ircsendimm((SJB64 ? '@'.itob64($main_conf{numeric}) : ':'.$main_conf{local})." TSCTL SVSTIME ".time);
 163 }
 164
 165 sub parse_sjoin($$$$) {
 166         my ($server, $ts, $cn, $parms) = @_;
 167         my (@users, @bans, @excepts, @invex, @blobs, $blobs, $chmodes, $chmodeparms);
 168
 169         $server = '' unless $server;
 170
 171         if($parms =~ /^:(.*)/) {
 172                 $blobs = $1;
 173         } else {
 174                 ($chmodes, $blobs) = split(/ :/, $parms, 2);
 175                 ($chmodes, $chmodeparms) = split(/ /, $chmodes, 2);
 176         }
 177         @blobs = split(/ /, $blobs);
 178
 179         foreach my $x (@blobs) {
 180                 if($x =~ /^(\&|\"|\')(.*)$/) {
 181                         my $type;
 182                         push @bans, $2 if $1 eq '&';
 183                         push @excepts, $2 if $1 eq '"';
 184                         push @invex, $2 if $1 eq "\'";
 185                 } else {
 186                         $x =~ /^([*~@%+]*)(.*)$/;
 187                         my ($prefixes, $nick) = ($1, $2);
 188                         my @prefixes = split(//, $prefixes);
 189                         my $op;
 190                         foreach my $prefix (@prefixes) {
 191                                 $op |= $opmodes{q} if ($prefix eq '*');
 192                                 $op |= $opmodes{a} if ($prefix eq '~');
 193                                 $op |= $opmodes{o} if ($prefix eq '@');
 194                                 $op |= $opmodes{h} if ($prefix eq '%');
 195                                 $op |= $opmodes{v} if ($prefix eq '+');
 196                         }
 197
 198                         push @users, { NICK => $nick, __OP => $op };
 199                 }
 200         }
 201
 202         return ($server, $cn, $ts, $chmodes, $chmodeparms, \@users, \@bans, \@excepts, \@invex);
 203 }
 204
 205 # Send Functions
 206
 207 sub kick($$$$) {
 208         my ($src, $chan, $target, $reason) = @_;
 209         $src = $main_conf{local} unless initial_synced();
 210         my $srcN = $src->{NICK};
 211         my $targetN = $target->{NICK};
 212         ircsend(":$srcN KICK $chan $targetN :$reason");
 213         callfuncs('KICK', 0, 2, [$srcN, $chan, $targetN, $reason]);
 214 }
 215
 216 sub invite($$$) {
 217         my ($src, $chan, $target) = @_;
 218         my $srcN = $src->{NICK};
 219         my $targetN = $target->{NICK};
 220         ircsend(":$srcN INVITE $targetN $chan 0");
 221 }
 222
 223 sub ping {
 224 #       if(@_ == 1) {
 225                 ircsend(':'.$main_conf{local}.' PING :'.$main_conf{local});
 226 #       } else {
 227 #               ircsend(':'.$_[2].' '.$tkn{PONG}[$tkn].' '.$_[0].' :'.$_[1]);
 228 #       }
 229 }
 230
 231 sub privmsg($$@) {
 232         my ($src, $dst, @msgs) = @_;
 233         my @bufs;
 234         foreach my $buf (@msgs) {
 235                 # 3 spaces, two colons, PRIVMSG=7
 236                 # Length restrictions are for CLIENT Protocol
 237                 # hence the (MASKLEN - (NICKLEN + 1))
 238                 # Technically optimizable if we use $agent{lc $src}'s ident and host
 239                 my $buflen = length($src) + length($dst) + 12 + (MASKLEN - (NICKLEN + 1));
 240                 push @bufs, wordwrap($buf, (MAXBUFLEN - $buflen));
 241         }
 242         my $srcN = $src->{NICK};
 243         # submit a list of messages as a single packet to the server
 244         ircsend(":$srcN PRIVMSG $dst :".join("\r\n".":$src PRIVMSG $dst :", @bufs));
 245         callfuncs('LOOP_PRIVMSG', 0, 1, [$src, $dst, \@bufs]);
 246 }
 247
 248 sub debug(@) {
 249         my (@msgs) = @_;
 250         debug_privmsg($main_conf{local}, $main_conf{diag}, @msgs);
 251         write_log('diag', '<'.$main_conf{local}.'>', @msgs);
 252 }
 253 sub write_log () { }
 254 sub debug_nolog(@) {
 255         my (@msgs) = @_;
 256         debug_privmsg($main_conf{local}, $main_conf{diag}, @msgs);
 257 }
 258
 259 sub debug_privmsg($$@) {
 260         my ($src, $dst, @msgs) = @_;
 261
 262         my @bufs;
 263         foreach my $buf (@msgs) {
 264                 # 3 spaces, two colons, PRIVMSG=7
 265                 # Length restrictions are for CLIENT Protocol
 266                 # hence the (MASKLEN - (NICKLEN + 1))
 267                 my $buflen = length($src) + length($dst) + 12 + (MASKLEN - (NICKLEN + 1));
 268                 push @bufs, wordwrap($buf, (MAXBUFLEN - $buflen));
 269         }
 270
 271         # submit a list of messages as a single packet to the server
 272         ircsendimm(":$src PRIVMSG $dst :".join("\r\n".":$src PRIVMSG $dst :", @bufs));
 273         callfuncs('LOOP_PRIVMSG', 0, 1, [$src, $dst, \@bufs]);
 274 }
 275
 276 sub notice($$@) {
 277         my ($src, $dst, @msgs) = @_;
 278         my $target = $dst; #lazy erry
 279         my @bufs;
 280         foreach my $buf (@msgs) {
 281                 # 3 spaces, two colons, NOTICE=6
 282                 # Length restrictions are for CLIENT Protocol
 283                 # hence the (MASKLEN - (NICKLEN + 1))
 284                 my $buflen = length($src) + length($dst) + 12 + (MASKLEN - (NICKLEN + 1));
 285                 push @bufs, wordwrap($buf, (MAXBUFLEN - $buflen));
 286         }
 287         my $srcN = $src->{NICK};
 288         my $targetN;
 289         if (ref ($dst) eq "HASH") { #User Object
 290                 $targetN = $target->{NICK};
 291         }
 292         else { # /notice #channel This probably sucks. Blame erry :(
 293                 $targetN = $dst;
 294         }
 295         ircsend(":$srcN NOTICE $targetN :".join("\r\n".":$srcN NOTICE $targetN :", @bufs));
 296         callfuncs('LOOP_NOTICE', 0, 1, [$srcN, $targetN, \@bufs]);
 297 }
 298
 299 sub ctcp($$@) {
 300         my ($src, $dst, $cmd, @toks) = @_;
 301         my $target = $dst; #lazy erry
 302         my $srcN = $src->{NICK};
 303         my $targetN = ($target->{NICK});
 304         privmsg($srcN, $targetN, "\x01".join(' ', ($cmd, @toks))."\x01");
 305 }
 306
 307 sub ctcp_reply($$@) {
 308         my ($src, $dst, $cmd, @toks) = @_;
 309         my $target = $dst; #lazy erry
 310         my $srcN = $src->{NICK};
 311         my $targetN = $target->{NICK};
 312         notice($srcN, $targetN, "\x01".join(' ', ($cmd, @toks))."\x01");
 313 }
 314
 315 sub setumode($$$) {
 316         my ($src, $dst, $modes) = @_;
 317         my $target = $dst; #lazy erry
 318         my $srcN = $src->{NICK};
 319         my $targetN = $target->{NICK};
 320         ircsend(":$srcN SVSMODE $targetN $modes");
 321         callfuncs('UMODE', 0, undef, [$dst, $modes]);
 322 }
 323
 324 sub setsvsstamp($$$) {
 325         my ($src, $dst, $stamp) = @_;
 326         my $srcN = $src->{NICK};
 327         my $dstN = $dst->{NICK};
 328         ircsend(":$srcN SVS2MODE $dstN +d $stamp");
 329         # This function basically set the svsstamp to
 330         # be the same as the userid. Not all ircd will
 331         # support this function.
 332         #and insp doesn't.
 333         # We obviously already know the userid, so don't
 334         # use a callback here.
 335         #callfuncs('UMODE', 0, undef, [$dst, $modes]);
 336 }
 337
 338 sub setagent_umode($$) {
 339         my ($src, $modes) = @_;
 340         ircsend(":$src UMODE2 $modes");
 341 }
 342
 343 sub setmode2($$@) {
 344         my ($src, $dst, @modelist) = @_;
 345         #debug(" --", "-- ircd::setmode2: ".$_[0], split(/\n/, Carp::longmess($@)), " --");
 346         foreach my $modetuple (@modelist) {
 347                 my $target = $modetuple->[1];
 348                 setmode($src, $dst, $modetuple->[0], $modetuple->[1]);
 349         }
 350 }
 351 sub ban_list($$$$@) {
 352 # Convenience function for lots of bans or excepts.
 353         my ($src, $cn, $sign, $mode, @parms) = @_;
 354         my @masklist;
 355         foreach my $mask (@parms) {
 356                 push @masklist, [( ($sign >= 1) ? '+' : '-').$mode, $mask];
 357         }
 358         ircd::setmode2($src, $cn, @masklist);
 359 }
 360
 361 sub setmode($$$;$) {
 362         my ($src, $dst, $modes, $target) = @_;
 363         my $srcN;
 364         if (initial_synced()) {
 365                 if (ref($src) eq "HASH") {
 366                         $srcN = $src->{NICK};
 367                 }
 368                 else {
 369                         $srcN = $src;
 370                 }
 371         }
 372         else {
 373                 $src = $main_conf{local};
 374                 $srcN = $src;
 375         }
 376         my $targetN;
 377         if (ref ($target) eq "HASH") {
 378                 $targetN = $target->{NICK};
 379         }
 380         else {
 381                 $targetN = $target;
 382         }
 383         callfuncs('MODE', undef, 1, [$srcN, $dst, $modes, $targetN]);
 384         #print "$ircline -- setmode($srcId, $dst, $modes, $targetId)\n" ;
 385         ircsend(":$srcN MODE $dst $modes $targetN");
 386 }
 387
 388 sub setmode_many($$$;@) {
 389         my ($src, $dst, $modes, @targets) = @_;
 390         my $srcN;
 391         if (initial_synced()) {
 392                 $srcN = $src->{NICK};
 393         }
 394         else {
 395                 $srcN = $main_conf{local};
 396                 $srcN = $src;
 397         }
 398         my $parms = "";
 399         foreach my $target (@targets) {
 400                 my $targetN = $target->{NICK};
 401                 $parms .= ($parms eq ""?"":" ") . $targetN;
 402                 print "parms" . $parms . "\n";
 403         }
 404         callfuncs('MODE', undef, 1, [$srcN, $dst, $modes, $parms]);
 405         print "$ircline -- setmode($srcN, $dst, $modes, $parms)\n" ;
 406         ircsend(":$srcN MODE $dst $modes $parms");
 407 }
 408
 409
 410 sub flushmodes(;$) {
 411         my $dm = (shift or \%defer_mode);
 412         my @k = keys(%$dm); my @v = values(%$dm);
 413         for(my $i; $i<@k; $i++) {
 414                 my ($src, $dst) = split(/ /, $k[$i]);
 415                 my @m = @{$v[$i]};
 416                 foreach my $m (@m) {
 417                         my ($modes, $parms) = split(/ /, $m, 2);
 418                         setmode_real($src, $dst, $modes, $parms);
 419                 }
 420         }
 421         %$dm = ();
 422 }
 423
 424 sub setmode_real($$$;$) {
 425         my ($src, $dst, $modes, $parms) = @_;
 426         print "$ircline -- setmode_real($src, $dst, $modes, $parms)\n";
 427         # for server sources, there must be a timestamp. but you can put 0 for unspecified.
 428         $parms =~ s/\s+$//; #trim any trailing whitespace, as it might break the simple parser in the ircd.
 429
 430         ircsend(":$src MODE $dst $modes".($parms?" $parms":'').($src =~ /\./ ? ' 0' : ''));
 431 }
 432
 433 sub settopic($$$$$) {
 434         my ($src, $chan, $setter, $time, $topic) = @_;
 435         my $srcN;
 436         $srcN = $main_conf{local} unless initial_synced();
 437         if ($srcN eq "") {
 438                 $srcN = $src->{NICK};
 439         }
 440         ircsend(":$srcN TOPIC $chan :$topic");
 441         callfuncs('TOPIC', undef, undef, [$srcN, $chan, $setter, $time, $topic]);
 442 }
 443
 444 sub wallops ($$) {
 445         my ($src, $message) = @_;
 446         ircsend(":$src WALLOPS :$message");
 447 }
 448
 449 sub globops ($$) {
 450         my ($src, $message) = @_;
 451         my $srcN = $src->{NICK};
 452         ircsend(":$srcN GLOBOPS :$message");
 453 }
 454
 455 sub kline ($$$$$) {
 456     my ($setter, $ident, $host, $expiry, $reason) = @_;
 457         $setter = "srsv.erry.omg" unless defined($setter); #FIXME
 458         $ident = '*' unless defined($ident);
 459         my $setN;
 460         if (ref ($setter) eq "HASH") {
 461                 $setN = $setter->{NICK};
 462         }
 463         else { $setN = $setter; }
 464         #:nascent.surrealchat.net TKL + G * *.testing.only tabris!northman@netadmin.SCnet.ops 1089168439 1089168434 :This is just a test.
 465     my $line = "TKL + G $ident $host $setN ".($expiry + time()).' '.time()." :$reason";
 466
 467         ircsend($line);
 468         callfuncs('TKL', undef, undef, [parse_tkl($line)]);
 469 }
 470 sub unkline ($$$) {
 471         my ($setter, $ident, $host) = @_;
 472         # TKL - G ident host setter
 473 # TKL - G ident *.test.dom tabris!northman@netadmin.SCnet.ops
 474         my $setN;
 475         if (ref ($setter) eq "HASH") {
 476                 $setN = $setter->{NICK};
 477         }
 478         else { $setN = $setter; }
 479         my $line = "TKL - G $ident $host $setN";
 480         ircsend($line);
 481         callfuncs('TKL', undef, undef, [parse_tkl($line)]);
 482 }
 483
 484 sub zline ($$$$) {
 485     my ($setter, $host, $expiry, $reason) = @_;
 486
 487         #foreach my $ex (@except) { return 1 if $mask =~ /\Q$ex\E/i; }
 488
 489         # format is
 490         # TKL +/- type ident host setter expiretime settime :reason
 491     my $setN;
 492         if (ref ($setter) eq "HASH") {
 493                 $setN = $setter->{NICK};
 494         }
 495         else { $setN = $setter; }
 496     my $line = "TKL + Z * $host $setN ".($expiry + time).' '.time." :$reason";
 497         ircsend($line);
 498         callfuncs('TKL', undef, undef, [parse_tkl($line)]);
 499 }
 500
 501 sub unzline ($$) {
 502         my ($setter, $host) = @_;
 503         # TKL - G ident host setter
 504 # TKL - G ident *.test.dom tabris!northman@netadmin.SCnet.ops
 505         my $setN;
 506         if (ref ($setter) eq "HASH") {
 507                 $setN = $setter->{NICK};
 508         }
 509         else { $setN = $setter; }
 510         my $line = "TKL - Z * $host $setN";
 511         ircsend($line);
 512         callfuncs('TKL', undef, undef, [parse_tkl($line)]);
 513 }
 514
 515 sub spamfilter($$$$$$$) {
 516 # Note the hardcoded zero (0).
 517 # Looks like theoretically one can have expirable spamfilters.
 518 # This is untested however.
 519         my ($sign, $tkl_target, $tkl_action, $setter, $bantime, $reason, $regex) = @_;
 520         my $tkl = "TKL ".($sign ? '+' : '-' )." F $tkl_target $tkl_action $setter 0 ".time()." $bantime $reason :$regex";
 521         ircsend($tkl);
 522         callfuncs('TKL', undef, undef, [parse_tkl($tkl)]);
 523 }
 524
 525 sub update_userkill($) {
 526         my ($target) = @_;
 527
 528         # This is a simple way to do it, that _could_ be defeated
 529         # with enough users getting killed at once.
 530         # The alternative would require a timer to expire the old entries.
 531         return undef if (time() == $userkill[1] and $target eq $userkill[0]);
 532         @userkill = ($target, time());
 533
 534         return 1;
 535 }
 536
 537 sub irckill($$$) {
 538         my ($src, $target, $reason) = @_;
 539         $src = $main_conf{local} unless initial_synced();
 540         my $srcN = $src->{NICK};
 541         my $targetN = $target->{NICK};
 542         return 0 unless update_userkill($targetN);
 543         ircsendimm(":$srcN KILL $targetN ($reason)");
 544         callfuncs('KILL', 0, 1, [$src, $target, $srcN, $reason]);
 545 }
 546
 547 sub svssno($$$) {
 548     my ($src, $target, $snomasks) = @_;
 549     $src=$main_conf{local} unless defined($src);
 550     # TODO:
 551     # None, this doesn't affect us.
 552
 553     # SVSSNO is not in tokens.txt nor msg.h
 554     ircsend(":$src ".'SVS2SNO'." $target $snomasks ".time);
 555 }
 556
 557 sub svsnick($$$) {
 558     my ($src, $target, $newnick) = @_;
 559     $src=$main_conf{local} unless defined($src);
 560     # note: we will get a NICK cmd back after a
 561     # successful nick change.
 562     # warning, if misused, this can KILL the user
 563     # with a collision
 564         my $srcN = $src->{NICK};
 565         my $targetN = $target->{NICK};
 566     ircsend(":$srcN SVSNICK $targetN $newnick ".time);
 567 }
 568
 569 sub svsnoop($$$) {
 570     my ($targetserver, $bool, $src) = @_;
 571     $src = $main_conf{local} unless defined($src);
 572     if ($bool > 0) { $bool = '+'; } else { $bool = '-'; }
 573 #this is SVS NO-OP not SVS SNOOP
 574     ircsend(":$main_conf{local} SVSNOOP $targetserver $bool");
 575 }
 576
 577 #START TODO - erry
 578
 579 sub svswatch ($$@) {
 580 # Changes the WATCH list of a user.
 581 # Syntax: SVSWATCH <nick> :<watch parameters>
 582 # Example: SVSWATCH Blah :+Blih!*@* -Bluh!*@* +Bleh!*@*.com
 583 # *** We do not track this info nor care.
 584         my ($src, $target, @watchlist) = @_;
 585     my $srcId = ($src->{NICK});
 586         my $targetId = $target->{NICK};
 587         my $base_str = ":$srcId SVSWATCH $targetId :";
 588         my $send_str = $base_str;
 589         while (@watchlist) {
 590                 my $watch = shift @watchlist;
 591                 if (length("$send_str $watch") > MAXBUFLEN) {
 592                         ircsend($send_str);
 593                         $send_str = $base_str;
 594                 }
 595                 $send_str = "$send_str $watch";
 596         }
 597         ircsend($send_str);
 598 }
 599
 600 sub svssilence ($$@) {
 601 # Changes the SILENCE list of a user.
 602 # Syntax: SVSSILENCE <nick> :<silence parameters>
 603 # Example: SVSSILENCE Blah :+Blih!*@* -Bluh!*@* +Bleh!*@*.com
 604 # *** We do not track this info nor care.
 605         my ($src, $target, @silencelist) = @_;
 606     my $srcId = ($src->{NICK});
 607         my $targetId = ($target->{NICK});
 608         my $base_str = ":$srcId SVSSILENCE $targetId :";
 609         my $send_str = $base_str;
 610         while (@silencelist) {
 611                 my $silence = shift @silencelist;
 612                 if (length("$send_str $silence") > MAXBUFLEN) {
 613                         ircsend($send_str);
 614                         $send_str = $base_str;
 615                 }
 616                 $send_str = "$send_str $silence";
 617         }
 618         print "SENDING $send_str\n";
 619         ircsend($send_str);
 620 }
 621
 622 sub svso($$$) {
 623 # Gives nick Operflags like the ones in O:lines.
 624 # SVSO <nick> <+operflags> (Adds the Operflags)
 625 # SVSO <nick> - (Removes all O:Line flags)
 626 # Example: SVSO SomeNick +bBkK
 627 # *** We do not track this info nor care.
 628 # *** We will see any umode changes later.
 629 # *** this cmd does not change any umodes!
 630     my ($src, $target, $oflags) = @_;
 631     $src = $main_conf{local} unless defined($src);
 632     ircsend(":$src SVSO $target $oflags");
 633 }
 634
 635 sub swhois($$$) {
 636 # *** We do not track this info nor care.
 637     my ($src, $target, $swhois) = @_;
 638     $src = $main_conf{local} unless defined($src);
 639     ircsend(":$src SWHOIS $target :$swhois");
 640 }
 641 #END TODO - erry
 642
 643 sub svsjoin($$@) {
 644         my ($src, $target, @chans) = @_;
 645         while(my @chanList = splice(@chans, 0, 10)) {
 646         # split into no more than 10 at a time.
 647                 __svsjoin($src, $target, @chanList);
 648         }
 649 }
 650
 651 sub __svsjoin($$@) {
 652     my ($src, $target, @chans) = @_;
 653     # a note. a JOIN is returned back to us on success
 654     # so no need to process this command.
 655     # similar for svspart.
 656         my $srcN = $src->{NICK};
 657         my $targetN = $target->{NICK};
 658     ircsend(($srcN?":$srcN":'')." SVSJOIN $targetN ".join(',', @chans));
 659 }
 660
 661 sub svspart($$$@) {
 662     my ($src, $target, $reason, @chans) = @_;
 663         my $srcN = $src->{NICK};
 664         my $targetN = $target->{NICK};
 665     ircsend(($srcN ? ":$srcN" : '')." SVSPART $targetN ".join(',', @chans).
 666         ($reason ? " :$reason" : ''));
 667 }
 668
 669 sub sqline ($;$) {
 670         # we need to sqline most/all of our agents.
 671         # tho whether we want to put it in agent_connect
 672         # or leave it to the module to call it...
 673         my ($nickmask, $reason) = @_;
 674         #ircsend("$tkn{S1QLINE}[$tkn] $nickmask".($reason?" :$reason":''));
 675         qline($nickmask, 0, $reason);
 676 }
 677
 678 sub svshold($$$) {
 679         # Not all IRCd will support this command, as such the calling module must check the IRCd capabilities first.
 680         my ($nickmask, $expiry, $reason) = @_;
 681         # TKL version - Allows timed qlines.
 682         # TKL + Q * test services.SC.net 0 1092179497 :test
 683         my $line = 'TKL + Q H '.$nickmask.' '.main_conf_local.' '.($expiry ? $expiry+time() : 0).' '.time().' :'.$reason;
 684         ircsend($line);
 685         # at startup we send these too early,
 686         # before the handlers are initialized
 687         # so they may be lost.
 688         callfuncs('TKL', undef, undef, [parse_tkl($line)]);
 689 }
 690
 691 sub svsunhold($) {
 692         my ($nickmask) = @_;
 693         # TKL version
 694         # TKL - Q * test services.SC.net
 695         my $line = 'TKL - Q H '.$nickmask.' '.main_conf_local;
 696         ircsend($line);
 697         callfuncs('TKL', undef, undef, [parse_tkl($line)]);
 698 }
 699
 700 sub qline($$$) {
 701         my ($nickmask, $expiry, $reason) = @_;
 702 # TKL version - Allows timed qlines.
 703 # TKL + Q * test services.SC.net 0 1092179497 :test
 704         my $line = 'TKL + Q * '.$nickmask.' '.main_conf_local.' '.($expiry ? $expiry+time() : 0).' '.time().' :'.$reason;
 705         ircsend($line);
 706
 707         # at startup we send these too early,
 708         # before the handlers are initialized
 709         # so they may be lost.
 710         callfuncs('TKL', undef, undef, [parse_tkl($line)]);
 711 }
 712
 713 sub unsqline ($) {
 714 # we need to sqline most/all of our agents.
 715 # tho whether we want to put it in agent_connect
 716 # or leave it to the module to call it...
 717         my ($nickmask) = @_;
 718         unqline($nickmask);
 719 }
 720
 721 sub unqline($) {
 722         my ($nickmask) = @_;
 723 # TKL version
 724 # TKL - Q * test services.SC.net
 725         my $line = 'TKL - Q * '.$nickmask.' '.main_conf_local;
 726         ircsend($line);
 727         callfuncs('TKL', undef, undef, [parse_tkl($line)]);
 728 }
 729
 730 sub svskill($$$) {
 731         my ($srcUser, $targetUser, $reason) = @_;
 732         # SVSKILL requires a src, it will NOT work w/o one.
 733         # not sure if it'll accept a servername or not.
 734         # consider defaulting to ServServ
 735         my $srcN = $srcUser -> {NICK};
 736         my $targetN = $targetUser -> {NICK};
 737         die('svskill called w/o $srcUser') unless $srcUser;
 738         ircsend(':'.$srcN.' SVSKILL '.$targetN.' :'.$reason);
 739         callfuncs('QUIT', 0, undef, [$targetUser, $reason]);
 740 }
 741
 742 sub version($) {
 743         my ($src) = @_;
 744         #ircsend(":$main_conf{local} 351 $src $main::progname ver $main::version $main_conf{local} ".
 745         #       $main::extraversion);
 746 }
 747
 748 sub userhost($) {
 749         my ($target) = @_;
 750         ircsend("USERHOST $target");
 751 }
 752
 753 sub userip($) {
 754         my ($target) = @_;
 755         die "We're not supposed to use USERIP anymore!" if DEBUG and NICKIP;
 756         ircsend(":$main::rsnick USERIP $target");
 757 }
 758
 759 sub chghost($$$) {
 760         my ($src, $target, $vhost) = @_;
 761     my $srcN = $src->{NICK};
 762         my $targetN = $target->{NICK};
 763         ircsend(($srcN?":$srcN ":'')." CHGHOST $targetN $vhost");
 764         callfuncs('CHGHOST', 0, 1, [$srcN, $targetN, $vhost]);
 765 }
 766
 767 sub chgident($$$) {
 768         my ($src, $target, $ident) = @_;
 769     my $srcN = $src->{NICK};
 770         my $targetN = $target->{NICK};
 771         ircsend(($src?":$srcN ":'')." CHGIDENT $targetN $ident");
 772         callfuncs('CHGIDENT', 0, 1, [$srcN, $targetN, $ident]);
 773 }
 774
 775 sub jupe_server($$) {
 776         my ($server, $reason) = @_;
 777
 778         # :nascent.surrealchat.net SERVER wyvern.surrealchat.net 2 :SurrealChat
 779         die "You can't jupe $server"
 780                 if ((lc($server) eq lc($remoteserv)) or (lc($server) eq lc($main_conf{local})));
 781         ircsend(':'.$main_conf{local}." SQUIT $server :");
 782         ircsend(':'.$main_conf{local}." SERVER $server 2 :$reason");
 783
 784         set_server_juped($server);
 785 }
 786 sub agent_dojoin($$) {
 787         my ($agent, $chan) = @_;
 788         my $srcN;
 789         if (ref($agent) ne "HASH") {
 790                 $srcN = $agent;
 791         }
 792         else {
 793                 my $src = $agent;
 794                 $srcN = $src->{NICK};
 795         }
 796         ircsend(":" . $srcN .  " JOIN " . $chan);
 797 }
 798
 799 sub agent_dopart ($$$) {
 800         my ($agent, $chan, $reason) = @_;
 801         my $srcN;
 802         if (ref($agent) ne "HASH") {
 803                 $srcN = $agent;
 804         }
 805         else {
 806                 my $src = $agent;
 807                 $srcN = $src->{NICK};
 808         }
 809         ircsend(":$srcN PART $chan :$reason");
 810 }
 811 sub rehash_all_servers(;$) {
 812         my ($type) = @_;
 813
 814         # Validate the type before passing it along.
 815         # Very IRCd specific! May be version specific.
 816         $type = undef() if(defined($type) && !($type =~ /^\-(motd|botmotd|opermotd|garbage)$/i));
 817
 818         foreach my $server (get_online_servers()) {
 819                 ircsend(':'.$main::rsnick.' REHASH '.$server.(defined($type) ? ' '.$type : '') );
 820         }
 821 }
 822
 823 sub unban_nick($$@) {
 824 # This is an Unreal-specific server-protocol HACK.
 825 # It is not expected to be portable to other ircds.
 826 # Similar concepts may exist in other ircd implementations
 827         my ($src, $cn, @nicks) = @_;
 828         my $srcN = $src->{NICK};
 829         my $i = 0; my @nicklist = ();
 830         while(my $nick = shift @nicks) {
 831                 push @nicklist, $nick;
 832                 if(++$i >= 10) {
 833                         ircsend(($src ? ":$src" : '' )." SVSMODE $cn -".'b'x($i).' '.join(' ', @nicklist));
 834                         $i = 0; @nicklist = ();
 835                 }
 836         }
 837         ircsend(($srcN ? ":$srcN " : "SVSMODE $cn -".'b'x($i).' '.join(' ', @nicklist)));
 838         # We don't loopback this, as we'll receive back the list
 839         # of removed bans.
 840 }
 841
 842 sub clear_bans($$) {
 843 # This is an Unreal-specific server-protocol HACK.
 844 # It is not expected to be portable to other ircds.
 845 # Similar concepts may exist in other ircd implementations
 846         my ($src, $cn) = @_;
 847
 848         ircsend(($src ? ":$src " : '' ). "SVSMODE $cn -b");
 849         # We don't loopback this, as we'll receive back the list
 850         # of removed bans.
 851 }
 852
 853 # HostServ OFF would want this.
 854 # resets the vhost to be the cloakhost.
 855 sub reset_cloakhost($$) {
 856         my ($src, $target) = @_;
 857         setumode($src, $target, '-x+x'); # only works in 3.2.6.
 858 }
 859
 860 # removes the cloakhost, so that vhost matches realhost
 861 sub disable_cloakhost($$) {
 862         my ($src, $target) = @_;
 863         setumode($src, $target, '-x'); # only works in 3.2.6.
 864 }
 865
 866 # enables the cloakhost, so that vhost becomes the cloakhost
 867 sub enable_cloakhost($$) {
 868         my ($src, $target) = @_;
 869         setumode($src, $target, '+x'); # only works in 3.2.6.
 870 }
 871
 872 sub agent_doconn ($$$$$) {
 873         my ($nick, $ident, $host, $modes, $gecos) = @_;
 874         ircsend("NICK $nick 1 " . time . " $ident $host ".
 875                 (SJB64 ? itob64(main_conf_numeric) : main_conf_local).
 876                 " 1 $modes * :$gecos");
 877 }
 878
 879 sub nolag($$@) {
 880         my ($src, $sign, @targets) = @_;
 881         $src = $main_conf{local} unless $src;
 882         foreach my $target (@targets) {
 883                 ircsend(':'.$src .' SVSNOLAG '.$sign.' '.$target);
 884         }
 885 }
 886
 887 1;