POE-Component-IRC-6.90/0000755000175000017500000000000013153565114013776 5ustar bingosbingosPOE-Component-IRC-6.90/dist.ini0000644000175000017500000000224213153565114015442 0ustar bingosbingosname = POE-Component-IRC author = Chris Williams author = Hinrik Örn Sigurðsson copyright_holder = Dennis Taylor, Chris Williams, and Hinrik Örn Sigurðsson license = Perl_5 [@AVAR] dist = POE-Component-IRC authority = cpan:HINRIK bugtracker = rt use_CompileTests = 0 nextrelease_format = %-5v %{ccc MMM d HH:mm:ss V YYYY}d github_user = bingos git_tag_message = CPAN release %v no_AutoPrereq = 1 [Prereqs / RuntimeRequires] perl = 5.008001 ; POE core POE = 1.311 POE::Wheel::SocketFactory = 0 POE::Wheel::ReadWrite = 0 POE::Session = 0 POE::Driver::SysRW = 0 POE::Filter::Line = 0 POE::Filter::Stream = 0 POE::Filter::Stackable = 0 ; extras POE::Filter::IRCD = 2.42 POE::Component::Syndicator = 0 IRC::Utils = 0.12 List::Util = 1.33 [Prereqs / TestRequires] Test::More = 0.47 Test::Differences = 0.61 [Prereqs / RuntimeRecommends] POE::Component::Client::DNS = 0.99 POE-Component-IRC-6.90/META.json0000644000175000017500000000441113153565114015417 0ustar bingosbingos{ "abstract" : "A fully event-driven IRC client module", "author" : [ "Chris Williams ", "Hinrik \u00d6rn Sigur\u00f0sson " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.010, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "POE-Component-IRC", "no_index" : { "directory" : [ "examples", "t", "utils", "xt" ] }, "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Test::Pod" : "1.41" } }, "runtime" : { "recommends" : { "POE::Component::Client::DNS" : "0.99" }, "requires" : { "IRC::Utils" : "0.12", "List::Util" : "1.33", "POE" : "1.311", "POE::Component::Syndicator" : "0", "POE::Driver::SysRW" : "0", "POE::Filter::IRCD" : "2.42", "POE::Filter::Line" : "0", "POE::Filter::Stackable" : "0", "POE::Filter::Stream" : "0", "POE::Session" : "0", "POE::Wheel::ReadWrite" : "0", "POE::Wheel::SocketFactory" : "0", "perl" : "5.008001" } }, "test" : { "requires" : { "Test::Differences" : "0.61", "Test::More" : "0.47" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "mailto" : "bug-POE-Component-IRC@rt.cpan.org", "web" : "https://rt.cpan.org/Public/Dist/Display.html?Name=POE-Component-IRC" }, "homepage" : "http://metacpan.org/release/POE-Component-IRC", "license" : [ "http://dev.perl.org/licenses/" ], "repository" : { "type" : "git", "url" : "git://github.com/bingos/poe-component-irc.git", "web" : "http://github.com/bingos/poe-component-irc" } }, "version" : "6.90", "x_authority" : "cpan:HINRIK", "x_serialization_backend" : "Cpanel::JSON::XS version 3.0239" } POE-Component-IRC-6.90/MANIFEST0000644000175000017500000001172013153565114015130 0ustar bingosbingos# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.010. Changes LICENSE MANIFEST MANIFEST.SKIP META.json META.yml Makefile.PL dist.ini docs/ctcpspec.html docs/dccspec.html docs/draft-brocklesby-irc-isupport-03.txt docs/draft-mitchell-irc-capabilities-02.html docs/rfc1459.html docs/rfc2810.html docs/rfc2811.html docs/rfc2812.html docs/rfc2813.html examples/aimproxy.pl examples/dcctest.pl examples/dicebot.pl examples/eliza.pl examples/ircproxy.pl examples/logger.pl examples/moo.pl examples/rot13_multi.pl examples/simpleclient.pl examples/tinyurl.pl lib/POE/Component/IRC.pm lib/POE/Component/IRC/Common.pm lib/POE/Component/IRC/Constants.pm lib/POE/Component/IRC/Cookbook.pod lib/POE/Component/IRC/Cookbook/BasicBot.pod lib/POE/Component/IRC/Cookbook/Disconnecting.pod lib/POE/Component/IRC/Cookbook/Gtk2.pod lib/POE/Component/IRC/Cookbook/Hailo.pod lib/POE/Component/IRC/Cookbook/Reload.pod lib/POE/Component/IRC/Cookbook/Resolver.pod lib/POE/Component/IRC/Cookbook/Seen.pod lib/POE/Component/IRC/Cookbook/Translator.pod lib/POE/Component/IRC/Plugin.pm lib/POE/Component/IRC/Plugin/AutoJoin.pm lib/POE/Component/IRC/Plugin/BotAddressed.pm lib/POE/Component/IRC/Plugin/BotCommand.pm lib/POE/Component/IRC/Plugin/BotTraffic.pm lib/POE/Component/IRC/Plugin/CTCP.pm lib/POE/Component/IRC/Plugin/Connector.pm lib/POE/Component/IRC/Plugin/Console.pm lib/POE/Component/IRC/Plugin/CycleEmpty.pm lib/POE/Component/IRC/Plugin/DCC.pm lib/POE/Component/IRC/Plugin/FollowTail.pm lib/POE/Component/IRC/Plugin/ISupport.pm lib/POE/Component/IRC/Plugin/Logger.pm lib/POE/Component/IRC/Plugin/NickReclaim.pm lib/POE/Component/IRC/Plugin/NickServID.pm lib/POE/Component/IRC/Plugin/PlugMan.pm lib/POE/Component/IRC/Plugin/Proxy.pm lib/POE/Component/IRC/Plugin/Whois.pm lib/POE/Component/IRC/Projects.pod lib/POE/Component/IRC/Qnet.pm lib/POE/Component/IRC/Qnet/State.pm lib/POE/Component/IRC/State.pm lib/POE/Filter/IRC.pm lib/POE/Filter/IRC/Compat.pm t/01_base/01_compile.t t/01_base/02_filters.t t/01_base/04_pocosi.t t/02_behavior/01_public_methods.t t/02_behavior/02_connect.t t/02_behavior/03_socketerr.t t/02_behavior/04_ipv6.t t/02_behavior/05_resolver.t t/02_behavior/06_online.t t/02_behavior/07_subclass.t t/02_behavior/08_parent_session.t t/02_behavior/09_multiple.t t/02_behavior/10_signal.t t/02_behavior/11_multi_signal.t t/02_behavior/12_delays.t t/02_behavior/13_activity.t t/02_behavior/14_newline.t t/02_behavior/15_no_stacked_ctcp.t t/02_behavior/16_nonclosing_ctcp.t t/02_behavior/17_raw.t t/02_behavior/18_shutdown.t t/03_subclasses/01_state.t t/03_subclasses/02_qnet.t t/03_subclasses/03_qnet_state.t t/03_subclasses/04_netsplit.t t/03_subclasses/05_state_awaypoll.t t/03_subclasses/06_state_nick_sync.t t/04_plugins/01_ctcp/01_load.t t/04_plugins/01_ctcp/02_replies.t t/04_plugins/02_connector/01_load.t t/04_plugins/02_connector/02_reconnect.t t/04_plugins/03_botaddressed/01_load.t t/04_plugins/03_botaddressed/02_output.t t/04_plugins/04_bottraffic/01_load.t t/04_plugins/04_bottraffic/02_output.t t/04_plugins/05_isupport/01_load.t t/04_plugins/05_isupport/02_isupport.t t/04_plugins/06_plugman/01_load.t t/04_plugins/06_plugman/02_add.t t/04_plugins/06_plugman/03_irc_interface.t t/04_plugins/06_plugman/04_auth_sub.t t/04_plugins/07_console/01_load.t t/04_plugins/08_proxy/01_load.t t/04_plugins/08_proxy/02_connect.t t/04_plugins/09_nickreclaim/01_load.t t/04_plugins/09_nickreclaim/02_reclaim.t t/04_plugins/09_nickreclaim/03_immediate_change.t t/04_plugins/09_nickreclaim/04_immediate_quit.t t/04_plugins/10_followtail/01_load.t t/04_plugins/11_cycleempty/01_load.t t/04_plugins/11_cycleempty/02_cycle.t t/04_plugins/12_autojoin/01_load.t t/04_plugins/12_autojoin/02_join.t t/04_plugins/12_autojoin/03_banned.t t/04_plugins/12_autojoin/04_kicked.t t/04_plugins/12_autojoin/05_password.t t/04_plugins/12_autojoin/06_kick_ban_password.t t/04_plugins/13_botcommand/01_load.t t/04_plugins/13_botcommand/02_commands.t t/04_plugins/13_botcommand/03_options.t t/04_plugins/13_botcommand/04_help.t t/04_plugins/13_botcommand/05_auth_sub.t t/04_plugins/13_botcommand/06_prefix.t t/04_plugins/13_botcommand/07_bare_private.t t/04_plugins/13_botcommand/08_nonword.t t/04_plugins/14_logger/01_load.t t/04_plugins/14_logger/02_public.t t/04_plugins/14_logger/03_private.t t/04_plugins/14_logger/04_dcc_chat.t t/04_plugins/14_logger/05_log_sub.t t/04_plugins/15_nickservid/01_load.t t/04_plugins/16_whois/01_load.t t/04_plugins/16_whois/02_whois.t t/04_plugins/17_dcc/01_load.t t/04_plugins/17_dcc/02_timeout.t t/04_plugins/17_dcc/03_send.t t/04_plugins/17_dcc/04_send_spaces.t t/04_plugins/17_dcc/05_resume.t t/04_plugins/17_dcc/06_chat.t t/04_plugins/17_dcc/07_nat.t t/05_regression/01_dcc_chat_close.t t/inc/Crypt/PasswdMD5.pm t/inc/Net/Netmask.pm t/inc/POE/Component/IRC/Test/Plugin.pm t/inc/POE/Component/Server/IRC.pm t/inc/POE/Component/Server/IRC/Backend.pm t/inc/POE/Component/Server/IRC/Common.pm t/inc/POE/Component/Server/IRC/Plugin.pm t/inc/POE/Component/Server/IRC/Plugin/Auth.pm t/inc/POE/Component/Server/IRC/Plugin/OperServ.pm POE-Component-IRC-6.90/examples/0000755000175000017500000000000013153565114015614 5ustar bingosbingosPOE-Component-IRC-6.90/examples/aimproxy.pl0000755000175000017500000002303313153565114020025 0ustar bingosbingos#!/usr/bin/perl -w # # This bot is a proxy between AIM and IRC. You give the bot an AIM # username, and any messages sent to it by people on its buddy list get # forwarded to IRC. Originally written to allow poor disadvantaged # Hiptop users to get on IRC. # # -- dennis taylor, use strict; use Socket; use POE qw( Wheel::SocketFactory Wheel::ReadWrite Filter::Line Driver::SysRW ); use POE::Component::IRC; use Time::HiRes qw(gettimeofday tv_interval); use Net::AIM; use constant MSG_INTERVAL => 2.2; my $channel = '#tempura'; my $irc_server = $ARGV[1] || "scissorman.phreeow.net"; my $irc_port = $ARGV[2] || 6667; my ($aim, $aimconn); sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; $aim = Net::AIM->new(); $aim->newconn( Screenname => 'vscairc', Password => $ARGV[0], AutoReconnect => 1, ) or die "Can't connect to AIM server: $!"; $aimconn = $aim->getconn(); $aimconn->set_handler( 'update_buddy', \&_net_aim_update_buddy ); $aimconn->set_handler( 'config', \&_net_aim_config ); $aimconn->set_handler( 'im_in', \&_net_aim_im_in ); $aimconn->set_handler( 'error', \&_net_aim_error ); $kernel->alias_set( 'control' ); $kernel->yield( 'aim_listen' ); $heap->{aimqueue} = []; $heap->{lastsend} = [gettimeofday]; } sub _stop { my ($kernel, $heap) = @_[KERNEL, HEAP]; print "Control session killed.\n"; foreach my $user (keys %{$heap->{queue}}) { $kernel->call( "irc_$user", 'quit', '[aimproxy] Control session killed.' ); } $aimconn->disconnect(); $kernel->alias_remove( 'control' ); } sub aim_listen { $aim->do_one_loop(); $_[KERNEL]->yield( 'aim_send' ); $_[KERNEL]->delay( 'aim_listen', 0.5 ); } sub _net_aim_update_buddy { my ($self, $evt) = @_; my ($buddy, $online) = @{$evt->args()}; $poe_kernel->post( 'control', 'aim_buddy_update', $buddy, ($online == "T") ); } sub aim_buddy_update { my ($kernel, $heap, $buddy, $online) = @_[KERNEL, HEAP, ARG0, ARG1]; if ($online) { $heap->{friends}->{$buddy} = 1; } elsif (not $online and $kernel->alias_resolve( "irc_$buddy" )) { $heap->{friends}->{$buddy} = 0; $kernel->post( "irc_$buddy", 'quit', "[aimproxy] $buddy has signed off AIM." ); } } sub _net_aim_config { my ($self, $evt, $from, $to) = @_; my $str = shift @{$evt->args()}; my @friends; $self->set_config_str($str, 1); $self->send_config(); foreach (split /[\r\n]+/, $str) { if (/^b (\S+)$/) { push @friends, $1; print "$1 is my friend.\n"; } } $poe_kernel->post( 'control', 'aim_friends', \@friends ); } sub aim_friends { my ($heap, $friends) = @_[HEAP, ARG0]; $heap->{friends}->{$_} = 0 foreach @$friends; } sub _net_aim_im_in { my ($self, $evt) = @_; my ($nick, $auto_msg, $msg) = @{$evt->args()}; my $stripped = $msg; return if $auto_msg eq 'T'; $stripped =~ s/<[^>]+>//g; # $stripped =~ s/^\s+//g; will this interfere with /commands? # $stripped =~ s/\s+$//g; if (length $stripped) { $poe_kernel->post( 'control', 'aim_got_message', $nick, $stripped ); } } sub aim_got_message { my ($kernel, $heap, $nick, $msg) = @_[KERNEL, HEAP, ARG0, ARG1]; return unless exists $heap->{friends}->{$nick}; if ($kernel->alias_resolve( "irc_$nick" )) { if ($msg =~ m|^/msg\s+(\S+)\s+(.*)$|i) { $kernel->post( "irc_$nick", 'privmsg', $1, $2 ); } elsif ($msg =~ m|^/me\s+(.*)$|i) { $kernel->post( "irc_$nick", 'ctcp', $channel, "ACTION $1" ); } elsif ($msg =~ m!^/(?:quit|part|leave)(?:\s+(.*))?$!i) { my $quitmsg = $1 || "Client Exiting"; $kernel->post( "irc_$nick", 'quit', "[aimproxy] $quitmsg" ); } elsif ($msg =~ m|^/(\S+)|i) { $kernel->yield( 'aim_queue', $nick, "[aimproxy] Unknown command: /$1" ); } else { $kernel->post( "irc_$nick", 'privmsg', $channel, $msg ); } } else { $heap->{friends}->{$nick} = 1; push @{$heap->{queue}->{$nick}}, $msg; my $irc_nick = $nick; $irc_nick =~ tr/A-Za-z0-9\-[]\\\`^{}/_/cs; $irc_nick = substr $irc_nick, 0, 9; POE::Component::IRC->new( "irc_$nick" ) or die "Can't create new IRC component for $nick: $!\n"; $kernel->post( "irc_$nick", 'register', 'all'); $kernel->post( "irc_$nick", 'connect', { Debug => 0, Nick => $irc_nick, Server => $irc_server, Port => $irc_port, Username => 'aimbot', Ircname => 'VSCA AIM->IRC Proxy Bot', } ); } } sub _net_aim_error { my ($self, $evt) = @_; my ($error, @stuff) = @{$evt->args()}; my $errstr = $evt->trans($error); $errstr =~ s/\$(\d+)/$stuff[$1]/ge; warn "AIM ERROR: $errstr\n"; } sub aim_queue { my ($kernel, $heap, $nick, $msg) = @_[KERNEL, HEAP, ARG0, ARG1]; return unless $heap->{friends}->{$nick}; push @{$heap->{aimqueue}}, [$nick, $msg]; $kernel->yield( 'aim_send' ); } sub aim_send { my ($kernel, $heap) = @_[KERNEL, HEAP]; my $timenow = [gettimeofday]; if (@{$heap->{aimqueue}} > 0 and tv_interval( $heap->{lastsend}, $timenow ) > MSG_INTERVAL) { my $msg = shift @{$heap->{aimqueue}}; $aim->send_im( $msg->[0], $msg->[1] ); $heap->{lastsend} = $timenow; } } sub irc_001 { my $kernel = $_[KERNEL]; $kernel->post( $_[SENDER], "join", $channel ); } sub irc_433 { my ($kernel, $sender) = @_[KERNEL, SENDER]; my $user = _get_aim_username( @_ ); my $irc_nick = $user; $irc_nick =~ tr/A-Za-z0-9\-[]\\\`^{}/_/cs; $irc_nick = substr $irc_nick, 0, 8; my @punct = ('^', '`', '_', '\\', '-'); $kernel->post( $sender, 'nick', $irc_nick . $punct[ int( rand @punct ) ] ); } sub _get_aim_username { my ($kernel, $sender, $heap) = @_[KERNEL, SENDER, HEAP]; my $user = (split /_/, ($kernel->alias_list( $sender ))[0], 2)[1]; die "No such user: \"$user\"" unless exists $heap->{friends}->{$user}; return $user; } sub irc_ctcp_action { my ($kernel, $heap, $who, $msg) = @_[KERNEL, HEAP, ARG0, ARG2]; my $user = _get_aim_username( @_ ); my ($nick) = ($who =~ /^(.*)?!/); $kernel->yield( 'aim_queue', $user, "* $nick $msg" ); } sub irc_disconnected { my ($kernel, $sender, $heap, $server) = @_[KERNEL, SENDER, HEAP, ARG0]; my $user = _get_aim_username( @_ ); print "$user: Lost connection to server $server.\n"; delete $heap->{queue}->{$user}; $kernel->post( $sender, "shutdown" ); $kernel->yield( 'aim_queue', $user, "[aimproxy] Lost connection to IRC server!" ); } sub irc_error { my ($kernel, $heap, $err) = @_[KERNEL, HEAP, ARG0]; my $user = _get_aim_username( @_ ); print "$user: Server error occurred! $err\n"; $kernel->yield( 'aim_queue', $user, "[aimproxy] Error from $irc_server: $err" ); } sub irc_join { my ($kernel, $heap, $who, $chan) = @_[KERNEL, HEAP, ARG0, ARG1]; my $user = _get_aim_username( @_ ); my ($nick) = ($who =~ /^(.*)?!/); $kernel->yield( 'aim_queue', $user, "*** $nick joined channel $channel." ); if ($heap->{friends}->{$user} and @{$heap->{queue}->{$user}} > 0) { $kernel->yield( 'aim_got_message', $user, shift @{$heap->{queue}->{$user}} ); } } sub irc_kick { my ($kernel, $heap, $who, $chan, $victim, $msg) = @_[KERNEL, HEAP, ARG0 .. $#_]; my $user = _get_aim_username( @_ ); my ($nick) = ($who =~ /^(.*)?!/); $kernel->yield( 'aim_queue', $user, "*** $victim was kicked from $channel by $nick ($msg)" ); } sub irc_mode { my ($kernel, $heap, $who, $chan, $modes) = @_[KERNEL, HEAP, ARG0 .. $#_]; my $user = _get_aim_username( @_ ); my ($nick) = ($who =~ /^(.*)?!/); $modes .= " " . join( ' ', @_[ARG3 .. $#_] ); $kernel->yield( 'aim_queue', $user, "*** Mode change on $chan by $nick: $modes" ); } sub irc_msg { my ($kernel, $heap, $who, $msg) = @_[KERNEL, HEAP, ARG0, ARG2]; my $user = _get_aim_username( @_ ); my ($nick) = ($who =~ /^(.*)?!/); $kernel->yield( 'aim_queue', $user, "*$nick* $msg" ); } sub irc_nick { my ($kernel, $heap, $who, $newnick) = @_[KERNEL, HEAP, ARG0, ARG1]; my $user = _get_aim_username( @_ ); my ($nick) = ($who =~ /^(.*)?!/); $kernel->yield( 'aim_queue', $user, "*** $nick is now known as $newnick." ); } sub irc_notice { my ($kernel, $heap, $who, $msg) = @_[KERNEL, HEAP, ARG0, ARG2]; my $user = _get_aim_username( @_ ); my ($nick) = ($who =~ /^(.*)?!/); $kernel->yield( 'aim_queue', $user, "-$nick- $msg" ); } sub irc_part { my ($kernel, $heap, $who, $chan) = @_[KERNEL, HEAP, ARG0, ARG1]; my $user = _get_aim_username( @_ ); my ($nick) = ($who =~ /^(.*)?!/); $kernel->yield( 'aim_queue', $user, "*** $nick has left $channel." ); } sub irc_public { my ($kernel, $heap, $who, $msg) = @_[KERNEL, HEAP, ARG0, ARG2]; my $user = _get_aim_username( @_ ); my ($nick) = ($who =~ /^(.*)?!/); $kernel->yield( 'aim_queue', $user, "<$nick> $msg" ); } sub irc_quit { my ($kernel, $heap, $who, $msg) = @_[KERNEL, HEAP, ARG0, ARG1]; my $user = _get_aim_username( @_ ); my ($nick) = ($who =~ /^(.*)?!/); $kernel->yield( 'aim_queue', $user, "*** $nick has quit IRC ($msg)." ); } sub irc_socketerr { my ($kernel, $heap, $err) = @_[KERNEL, HEAP, ARG0]; my $user = _get_aim_username( @_ ); print "$user: Can't connect to $irc_server:$irc_port! $err\n"; $kernel->yield( 'aim_queue', $user, "[aimproxy] Can't connect to $irc_server:$irc_port: $err" ); } POE::Session->create( package_states => [ 'main' => [qw( _start _stop aim_buddy_update aim_friends aim_got_message aim_listen aim_queue aim_send irc_001 irc_433 irc_ctcp_action irc_disconnected irc_error irc_join irc_kick irc_mode irc_msg irc_nick irc_notice irc_part irc_public irc_quit irc_socketerr )], ], ); $poe_kernel->run(); exit 0; POE-Component-IRC-6.90/examples/logger.pl0000755000175000017500000000136613153565114017441 0ustar bingosbingos#!/usr/bin/perl # This is the most succinct IRC logger bot script in the history of the universe # Author: Hinrik Örn Sigurðsson, use strict; use warnings; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::IRC::Plugin::Logger; my $nick = 'mylogbot'; my $server = 'irc.blahblah.irc'; my @channels = ('#chan1', '#chan2'); my $path = "$ENV{HOME}/irclogs"; my $irc = POE::Component::IRC::State->spawn( Server => $server, Nick => $nick, ); $irc->plugin_add('AutoJoin', POE::Component::IRC::Plugin::AutoJoin->new( Channels => \@channels )); $irc->plugin_add('Logger', POE::Component::IRC::Plugin::Logger->new( Path => $path )); $irc->yield('connect'); $poe_kernel->run(); POE-Component-IRC-6.90/examples/moo.pl0000755000175000017500000001300713153565114016747 0ustar bingosbingos#!/usr/bin/perl -w # # This bot is a simple telnet proxy. You DCC CHAT with it, and it # connects to somewhere else, and you talk to the somewhere else over # the CHAT connection in your IRC client. I originally wrote it because # I wanted to use XChat as an interface to a MOO instead of telnet. :-) # # All things considered, a good demonstration of DCC code. # # -- dennis taylor, use strict; use Socket; use POE qw( Wheel::SocketFactory Wheel::ReadWrite Filter::Line Driver::SysRW ); use POE::Component::IRC; my $mynick = "moo"; my $user = "(fimm(tiu)?|(Half|Semi)jack|stimps)"; my $telnethost = "binky"; my $telnetport = 7788; my $verbose = 0; # turn this on to enable lots of garbage. my $chatsession = undef; sub _start { my ($kernel, $session) = @_[KERNEL, SESSION]; # $session->option( trace => 1 ); $kernel->post( 'irc', 'register', 'all'); $kernel->post( 'irc', 'connect', { Debug => 0, Nick => $mynick, Server => $ARGV[0] || 'irc.phreeow.net', Port => $ARGV[1] || 6667, Username => 'neenio', Ircname => 'Ask me about my colon!', } ); $kernel->sig( INT => "sigint" ); } sub _connected { my ($kernel, $heap, $sock, $addr, $port) = @_[KERNEL, HEAP, ARG0 .. ARG2]; $heap->{wheel} = POE::Wheel::ReadWrite->new( Handle => $sock, Filter => POE::Filter::Line->new(), Driver => POE::Driver::SysRW->new(), InputEvent => '_conn_data', ErrorEvent => '_conn_error', ); $kernel->post( 'irc', 'dcc_chat', $chatsession, "*** Connected." ); print "Connected.\n" if $verbose; } sub _connect_failed { my ($kernel, $heap, $function, $errstr) = @_[KERNEL, HEAP, ARG0, ARG2]; $kernel->post( 'irc', 'dcc_chat', $chatsession, "*** Couldn't connect to $telnethost:$telnetport: $errstr in $function" ); print "Couldn't connect to $telnethost:$telnetport: $errstr in $function\n"; delete $heap->{wheel}; } sub _conn_data { my ($kernel, $heap, $line) = @_[KERNEL, HEAP, ARG0]; $line = " " unless length $line; $kernel->post( 'irc', 'dcc_chat', $chatsession, $line ); print "<== $line\n" if $verbose; } sub _conn_error { my ($kernel, $heap, $function, $errstr) = @_[KERNEL, HEAP, ARG0, ARG2]; $kernel->post( 'irc', 'dcc_chat', $chatsession, "*** Connection to $telnethost:$telnetport lost: $errstr in $function" ); print "Connection to $telnethost:$telnetport lost: $errstr in $function\n"; delete $heap->{wheel}; } # After we successfully log into the IRC server, make ourselves invisible. sub irc_001 { $_[KERNEL]->post( 'irc', 'mode', $mynick, '+i' ); } sub irc_dcc_request { my ($kernel, $heap, $nick, $type, $port, $cookie) = @_[KERNEL, HEAP, ARG0 .. ARG3]; $nick =~ s/^(.+?)!.*$/$1/; unless ($nick =~ /^$user$/o and $type eq "CHAT") { $kernel->post( 'irc', 'notice', $nick, "Buzz off." ); return; } if ($port < 1024) { $kernel->post( 'irc', 'notice', $nick, "Reserved ports are beneath me." ); return; } if (defined $chatsession) { $kernel->post( 'irc', 'notice', $nick, "There's already a user on." ); return; } $kernel->post( 'irc', 'dcc_accept', $cookie ); } sub irc_dcc_start { my ($kernel, $heap, $cookie, $nick, $port) = @_[KERNEL, HEAP, ARG0, ARG1, ARG3]; unless ($chatsession) { die "Who the hell is \"$nick\"?" unless $nick =~ /^$user!.*$/o; print "DCC CHAT connection established with $nick on port $port.\n" if $verbose; } $chatsession = $cookie; # save the magic cookie $kernel->post( 'irc', 'dcc_chat', $chatsession, "*** Connecting to $telnethost, port $telnetport..." ); $heap->{factory} = POE::Wheel::SocketFactory->new( RemoteAddress => $telnethost, RemotePort => $telnetport, SuccessEvent => '_connected', FailureEvent => '_connect_failed', ); } sub irc_dcc_chat { my ($kernel, $heap, $peer, $line) = @_[KERNEL, HEAP, ARG1, ARG3]; if ($line eq "***reconnect" and not exists $heap->{wheel}) { $kernel->yield( 'irc_dcc_start', $chatsession, '', $peer, 0 ); } elsif ($line eq "***quit") { delete $heap->{factory}; delete $heap->{wheel}; } else { if ($line =~ /^\001ACTION (.*)\001\015?$/) { $line = ":$1"; } $heap->{wheel}->put( $line ) if exists $heap->{wheel}; print "==> $line\n" if $verbose; } } sub irc_dcc_done { my ($nick, $type) = @_[ARG0, ARG1]; print "DCC $type to $nick closed.\n" if $verbose; $chatsession = undef; } sub irc_dcc_error { my ($err, $nick, $type) = @_[ARG1 .. ARG3]; print "DCC $type to $nick failed: $err.\n" if $verbose; $chatsession = undef; } sub sigint { my ($kernel, $heap) = @_[KERNEL, HEAP]; delete $heap->{factory}; delete $heap->{wheel}; $kernel->sig_handled(); } sub _stop { my ($kernel) = $_[KERNEL]; print "Control session stopped.\n"; $kernel->call( 'irc', 'quit', 'Control session stopped.' ); } sub irc_disconnected { my ($server) = $_[ARG0]; print "Lost connection to server $server.\n"; } sub irc_error { my $err = $_[ARG0]; print "Server error occurred! $err\n"; } sub irc_socketerr { my $err = $_[ARG0]; print "Couldn't connect to server: $err\n"; } POE::Component::IRC->new( 'irc', trace => undef ) or die "Can't instantiate new IRC component!\n"; POE::Session->create( package_states => [ 'main' => [qw( _start _stop _connected sigint _connect_failed _conn_data _conn_error irc_001 irc_error irc_disconnected irc_socketerr irc_dcc_start irc_dcc_done irc_dcc_chat irc_dcc_error irc_dcc_request)], ], ); $poe_kernel->run(); exit 0; POE-Component-IRC-6.90/examples/ircproxy.pl0000755000175000017500000000472113153565114020037 0ustar bingosbingos#!/usr/bin/perl use strict; use warnings; use Socket; use Getopt::Long; use POE qw(Component::IRC::State Component::IRC::Plugin::Proxy); my $nick; my $user; my $server; my $port; my $ircname; my $bindaddr; my $bindport; my $password; my $channels; GetOptions( "address=s" => \$bindaddr, "bindport=s" => \$bindport, "password=s" => \$password, "nick=s" => \$nick, "server=s" => \$server, "user=s" => \$user, "port=s" => \$port, "ircname=s" => \$ircname, "channels=s" => \$channels, ); die "Please specify a nickname and a servername\n" unless ( $nick and $server ); my @channels = split /\,/, $channels; my $poco = POE::Component::IRC::State->spawn(Nick => $nick, Server => $server, Port => $port, Ircname => $ircname, Username => $user); POE::Session->create( package_states => [ 'main' => [ qw(_start _default irc_proxy_service irc_proxy_authed irc_proxy_close irc_001) ], ], heap => { irc => $poco, channels => \@channels }, options => { trace => 0 }, ); $poe_kernel->run(); exit 0; sub _start { my ($kernel,$heap) = @_[KERNEL,HEAP]; my $irc = $heap->{irc}; $irc->yield( register => 'all' ); $heap->{proxy} = POE::Component::IRC::Plugin::Proxy->new( bindaddress => $bindaddr, bindport => $bindport, password => $password ); $irc->plugin_add( 'Proxy' => $heap->{proxy} ); $irc->yield( connect => { } ); undef; } sub irc_001 { my ($kernel,$heap) = @_[KERNEL,HEAP]; $heap->{irc}->yield( join => $_ ) for @{ $heap->{channels} }; return; } sub _default { my ($event) = $_[ARG0]; my (@args) = @{ $_[ARG1] }; my (@output) = ( "$event: " ); foreach my $arg ( @args ) { if ( ref($arg) eq 'ARRAY' ) { push( @output, "[" . join(" ,", @$arg ) . "]" ); } else { push ( @output, "'$arg'" ); } } print STDOUT join(', ', @output, "\n" ); undef; } sub irc_proxy_service { my ($kernel,$heap,$mysockaddr) = @_[KERNEL,HEAP,ARG0]; my ($port, $myaddr) = sockaddr_in($mysockaddr); printf "Connect to %s [%s]:[%s]\n", scalar gethostbyaddr($myaddr, AF_INET), inet_ntoa($myaddr), $port; undef; } sub irc_proxy_authed { my ($kernel,$heap) = @_[KERNEL,HEAP]; $heap->{irc}->yield( ctcp => $_ => 'ACTION has attached' ) for keys %{ $heap->{irc}->channels() }; undef; } sub irc_proxy_close { my ($kernel,$heap) = @_[KERNEL,HEAP]; $heap->{irc}->yield( ctcp => $_ => 'ACTION has detached' ) for keys %{ $heap->{irc}->channels() }; undef; } POE-Component-IRC-6.90/examples/dicebot.pl0000755000175000017500000000520713153565114017571 0ustar bingosbingos#!/usr/bin/perl -w # # A simple example of a bot that listens for and responds to on-channel # user input. You can say "roll 2d12 + 2" or whatever, and it'll roll # the appropriate number and type of dice and speak the result out loud. # # -- dennis taylor, use strict; use POE; use POE::Component::IRC; use Data::Dumper; my $nick = 'dicebot'; sub _start { my ($kernel) = $_[KERNEL]; $kernel->post( 'dicebot', 'register', 'all'); $kernel->post( 'dicebot', 'connect', { Debug => 1, Nick => $nick, Server => $ARGV[0] || 'scissorman.phreeow.net', Port => $ARGV[1] || 6667, Username => 'neenio', Ircname => "HELP I'M A ROCK", }, ); $kernel->sig( INT => "sigint" ); } sub irc_001 { my ($kernel) = $_[KERNEL]; $kernel->post( 'dicebot', 'mode', $nick, '+i' ); $kernel->post( 'dicebot', 'join', '#dice' ); $kernel->post( 'dicebot', 'privmsg', '#dice', 'I am a dice-rolling bot.' ); $kernel->post( 'dicebot', 'topic', '#dice' ); } sub irc_disconnected { my ($server) = $_[ARG0]; print "Lost connection to server $server.\n"; $_[KERNEL]->post( "dicebot", "unregister", "all" ); } sub irc_error { my $err = $_[ARG0]; print "Server error occurred! $err\n"; } sub irc_socketerr { my $err = $_[ARG0]; print "Couldn't connect to server: $err\n"; $poe_kernel->sig( 'INT' ); } sub sigint { my $kernel = $_[KERNEL]; $kernel->post( 'dicebot', 'quit', 'Neenios on ice!' ); print "Tickles!!!!!!\n"; $kernel->sig( 'INT' ); $kernel->sig_handled(); } sub _stop { my ($kernel) = $_[KERNEL]; print "Control session stopped.\n"; } sub irc_public { my ($kernel, $who, $chan, $msg) = @_[KERNEL, ARG0 .. ARG2]; $who =~ s/^(.*)!.*$/$1/ or die "Weird-ass who: $who"; my ($num, $die, $plus) = ($msg =~ /^\s*(?:$nick,?\s*)?roll (?:a )?(\d+)d(\d+)\s*([+-]\s*(\d+))?/i); return unless $num and $die and $num < 1000 and $die < 10000; $plus =~ tr/+ //d if $plus; my @rolls; my $sum = $plus || 0; for (1 .. $num) { push @rolls, int rand( $die ) + 1; $sum += $rolls[-1]; } my $str = "You rolled a $sum"; if (@rolls > 1 or $plus) { $plus = '' unless $plus; $plus =~ s/\-(\d)/ \- $1/; $plus =~ s/^(\d)/ \+ $1/; $str .= " (" . join( " + ", @rolls) . "$plus)"; } $kernel->post( 'dicebot', 'privmsg', $chan, "$who: $str" ); } POE::Component::IRC->new( 'dicebot' ) or die "Can't instantiate new IRC component!\n"; POE::Session->create( package_states => [ 'main' => [qw(_start _stop irc_001 irc_disconnected sigint irc_socketerr irc_error irc_public)],], ); $poe_kernel->run(); exit 0; POE-Component-IRC-6.90/examples/eliza.pl0000755000175000017500000000601013153565114017255 0ustar bingosbingos#!/usr/bin/perl -w # # $Id: eliza.pl,v 3.5 2005/02/19 13:26:46 chris Exp $ # # This is an adaption of Dennis Taylor's test.pl. It combines a very # simple bot with Chatbot::Eliza to make something fairly annoying. # -- Rocco Caputo, use strict; use POE::Kernel; use POE::Session; use POE::Component::IRC 3.4; use Chatbot::Eliza; my $pid = $$; substr($pid, 0, 1) = '' while length($pid) > 3; my $nick = 'eliza' . $pid; my $name = 'eliza' . $pid; my $eliza = Chatbot::Eliza->new(); # This gets executed as soon as the kernel sets up this session. sub _start { my ($kernel, $session) = @_[KERNEL, SESSION]; $_[HEAP] = $_[ARG0]; # Uncomment this to turn on more verbose POE debugging information. # $session->option( trace => 1 ); # Ask the IRC component to send us all IRC events it receives. This # is the easy, indiscriminate way to do it. $_[HEAP]->yield( 'register', 'all'); # Setting Debug to 1 causes P::C::IRC to print all raw lines of text # sent to and received from the IRC server. Very useful for debugging. $_[HEAP]->yield( 'connect', { } ); } # After we successfully log into the IRC server, join a channel. sub irc_001 { my ($kernel) = $_[KERNEL]; $_[HEAP]->yield( 'mode', $nick, '+i' ); $_[HEAP]->yield( 'join', $ARGV[2] || '#IRC.pm' ); $_[HEAP]->yield( 'away', 'JOSHUA SCHACTER IST MEIN GELEESCHAUMGUMMIRING DER LIEBE!' ); } sub _stop { my ($kernel) = $_[KERNEL]; print "Control session stopped.\n"; $_[HEAP]->call( 'quit', 'Neenios on ice!' ); } sub irc_disconnected { my ($server) = $_[ARG0]; print "Lost connection to server $server.\n"; } sub irc_error { my $err = $_[ARG0]; print "Server error occurred! $err\n"; } sub irc_socketerr { my $err = $_[ARG0]; print "Couldn't connect to server: $err\n"; } sub irc_kick { my ($kernel, $who, $where, $isitme, $reason) = @_[KERNEL, ARG0 .. ARG4]; if ($isitme eq $nick) { print "Kicked from $where by $who: $reason\n"; # Uncomment for auto-rejoin. Nasty, evil, don't do it. # $kernel->post( 'test', 'join', $where ); } } sub irc_public { my ($kernel, $who, $where, $msg) = @_[KERNEL, ARG0 .. ARG2]; my $nick = (split /!/, $who)[0]; print "<$nick:@{$where}[0]> $msg\n"; $_[HEAP]->yield( privmsg => $where, $eliza->transform($msg) # Filter it through a Chatbot. ); } # here's where execution starts. my ($object) = POE::Component::IRC->spawn( Debug => 1, Nick => $nick, Server => $ARGV[0] || 'irc.rhizomatic.net', Port => $ARGV[1] || 6667, Username => $name, Ircname => 'Ask me about my colon!' ) or die "Can't instantiate new IRC component!\n"; POE::Session->create( package_states => [ 'main' => [ qw( _start _stop irc_001 irc_kick irc_disconnected irc_error irc_socketerr irc_public ) ], ], args => [ $object ], ); $poe_kernel->run(); exit 0; POE-Component-IRC-6.90/examples/dcctest.pl0000755000175000017500000000623713153565114017615 0ustar bingosbingos#!/usr/bin/perl -w # # $Id: dcctest.pl,v 3.5 2005/02/19 13:26:46 chris Exp $ # # This simple test program should give you an idea of how a basic # POE::Component::IRC script fits together. # -- dennis taylor, use strict; use POE::Kernel; use POE::Session; use POE::Component::IRC; my $nick = "spleen" . ($$ % 1000); # This gets executed as soon as the kernel sets up this session. sub _start { my ($kernel, $session) = @_[KERNEL, SESSION]; # Ask the IRC component to send us all IRC events it receives. This # is the easy, indiscriminate way to do it. $kernel->post( 'test', 'register', 'all'); # Setting Debug to 1 causes P::C::IRC to print all raw lines of text # sent to and received from the IRC server. Very useful for debugging. $kernel->post( 'test', 'connect', { Debug => 1, Nick => $nick, Server => $ARGV[0] || 'irc.phreeow.net', Port => $ARGV[1] || 6667, Username => 'neenio', Ircname => 'Ask me about my colon!', } ); } # After we successfully log into the IRC server, join a channel. sub irc_001 { my ($kernel) = $_[KERNEL]; $kernel->post( 'test', 'mode', $nick, '+i' ); $kernel->post( 'test', 'join', '#IRC.pm' ); $kernel->post( 'test', 'away', 'JOSHUA SCHACTER IS MY SLIPPERY TURGID ZUCCHINI OF LUST' ); } sub irc_dcc_done { my ($magic, $nick, $type, $port, $file, $size, $done) = @_[ARG0 .. ARG6]; print "DCC $type to $nick ($file) done: $done bytes transferred.\n", } sub irc_dcc_error { my ($err, $nick, $type, $file) = @_[ARG0 .. ARG2, ARG4]; print "DCC $type to $nick ($file) failed: $err.\n", } sub _stop { my ($kernel) = $_[KERNEL]; print "Control session stopped.\n"; $kernel->call( 'test', 'quit', 'Neenios on ice!' ); } sub irc_disconnected { my ($server) = $_[ARG0]; print "Lost connection to server $server.\n"; } sub irc_error { my $err = $_[ARG0]; print "Server error occurred! $err\n"; } sub irc_socketerr { my $err = $_[ARG0]; print "Couldn't connect to server: $err\n"; } sub irc_kick { my ($who, $where, $isitme, $reason) = @_[ARG0 .. ARG4]; print "Kicked from $where by $who: $reason\n" if $isitme eq $nick; } sub irc_public { my ($kernel, $who, $where, $msg) = @_[KERNEL, ARG0 .. ARG2]; $who = (split /!/, $who)[0]; print "<$who:@{$where}[0]> $msg\n"; if ($msg =~ /quit/i) { $kernel->post( 'test', 'quit', "Requested by $who" ); } elsif ($msg =~ /send/i) { $kernel->post( 'test', 'dcc', $who, 'send', '/etc/shells' ); } } sub irc_dcc_request { my ($kernel, $nick, $type, $port, $magic, $filename, $size) = @_[KERNEL, ARG0 .. ARG5]; print "DCC $type request from $nick on port $port\n"; $nick = ($nick =~ /^([^!]+)/); $nick =~ s/\W//; $kernel->post( 'test', 'dcc_accept', $magic, "$1.$filename" ); } # here's where execution starts. POE::Component::IRC->new( 'test' ) or die "Can't instantiate new IRC component!\n"; POE::Session->create( package_states => [ 'main' => [qw(_start _stop irc_001 irc_kick irc_disconnected irc_error irc_socketerr irc_dcc_done irc_dcc_error irc_dcc_request irc_public)],], ); $poe_kernel->run(); exit 0; POE-Component-IRC-6.90/examples/rot13_multi.pl0000755000175000017500000000545413153565114020346 0ustar bingosbingos#!/usr/bin/perl # A Multiple Network Rot13 'encryption' bot use strict; use warnings; use POE qw(Component::IRC); my $nickname = 'Flibble' . $$; my $ircname = 'Flibble the Sailor Bot'; my $settings = { 'server1.irc' => { port => 6667, channels => [ '#Foo' ], }, 'server2.irc' => { port => 6668, channels => [ '#Bar' ], }, 'server3.irc' => { port => 7001, channels => [ '#Baa' ], }, }; # We create our PoCo-IRC objects for my $server ( keys %{ $settings } ) { POE::Component::IRC->spawn( alias => $server, nick => $nickname, ircname => $ircname, ); } POE::Session->create( package_states => [ main => [ qw(_default _start irc_registered irc_001 irc_public) ], ], heap => { config => $settings }, ); $poe_kernel->run(); sub _start { my ($kernel, $session) = @_[KERNEL, SESSION]; # Send a POCOIRC_REGISTER signal to all poco-ircs $kernel->signal( $kernel, 'POCOIRC_REGISTER', $session->ID(), 'all' ); return; } # We'll get one of these from each PoCo-IRC that we spawned above. sub irc_registered { my ($kernel, $heap, $sender, $irc_object) = @_[KERNEL, HEAP, SENDER, ARG0]; my $alias = $irc_object->session_alias(); my %conn_hash = ( server => $alias, port => $heap->{config}->{ $alias }->{port}, ); # In any irc_* events SENDER will be the PoCo-IRC session $kernel->post( $sender, 'connect', \%conn_hash ); return; } sub irc_001 { my ($kernel, $heap, $sender) = @_[KERNEL, HEAP, SENDER]; # Get the component's object at any time by accessing # the heap of the SENDER my $poco_object = $sender->get_heap(); print "Connected to ", $poco_object->server_name(), "\n"; my $alias = $poco_object->session_alias(); my @channels = @{ $heap->{config}->{ $alias }->{channels} }; $kernel->post( $sender => join => $_ ) for @channels; return; } sub irc_public { my ($kernel, $sender, $who, $where, $what) = @_[KERNEL, SENDER, ARG0 .. ARG2]; my $nick = ( split /!/, $who )[0]; my $channel = $where->[0]; if ( my ($rot13) = $what =~ /^rot13 (.+)/ ) { $rot13 =~ tr[a-zA-Z][n-za-mN-ZA-M]; $kernel->post( $sender => privmsg => $channel => "$nick: $rot13" ); } if ( $what =~ /^!bot_quit$/ ) { # Someone has told us to die =[ $kernel->signal( $kernel, 'POCOIRC_SHUTDOWN', "See you loosers" ); } return; } # We registered for all events, this will produce some debug info. sub _default { my ($event, $args) = @_[ARG0 .. $#_]; my @output = ( "$event: " ); for my $arg ( @$args ) { if ( ref($arg) eq 'ARRAY' ) { push( @output, '[' . join(' ,', @$arg ) . ']' ); } else { push ( @output, "'$arg'" ); } } print join ' ', @output, "\n"; return 0; } POE-Component-IRC-6.90/examples/simpleclient.pl0000755000175000017500000000773213153565114020655 0ustar bingosbingos#!/usr/bin/perl -w use Getopt::Long; use POE qw(Component::IRC::State Wheel::ReadLine); use Data::Dumper; $Data::Dumper::Indent = 1; my $nick; my $user; my $server; my $port; my $ircname; my $password; my $current_channel; my $socks_proxy; my $socks_port; my $socks_id; my $no_dns; my $ip6; GetOptions( "nick=s" => \$nick, "server=s" => \$server, "user=s" => \$user, "port=s" => \$port, "pass=s" => \$password, "socksproxy=s" => \$socks_proxy, "socksport=s" => \$socks_port, "socksuser=s" => \$socks_id, "ircname=s" => \$ircname, "nodns" => \$no_dns, "ip6" => \$ip6, ); die unless $nick and $server; print "$nick $server\n"; my $irc = POE::Component::IRC::State->spawn( Nick => $nick, Server => $server, Port => $port, Ircname => $ircname, Username => $user, Password => $password, socks_proxy => $socks_proxy, socks_port => $socks_port, socks_id => $socks_id, NoDNS => $no_dns, useipv6 => $ip6 ); print STDOUT $irc->VERSION(), "\n"; POE::Session->create( package_states => [ 'main' => [ qw(_start _stop got_input parse_input _default irc_public) ], ], ); $poe_kernel->run(); exit 0; sub _start { my $heap = $_[HEAP]; $heap->{readline_wheel} = POE::Wheel::ReadLine->new( InputEvent => 'got_input' ); $heap->{readline_wheel}->get("> "); $irc->yield( register => 'all' ); undef; } sub _stop { delete $_[HEAP]->{readline_wheel}; $irc->yield( unregister => 'all' ); $irc->yield( 'shutdown' ); undef; } sub got_input { my ( $heap, $kernel, $input, $exception ) = @_[ HEAP, KERNEL, ARG0, ARG1 ]; if ( defined $input ) { $heap->{readline_wheel}->addhistory($input); #$heap->{readline_wheel}->put("I heard $input"); $kernel->yield( 'parse_input' => $input ); } elsif ( $exception eq 'interrupt' ) { $heap->{readline_wheel}->put("Goodbye."); delete $heap->{readline_wheel}; $irc->yield( unregister => 'all' ); $irc->yield( 'shutdown' ); return; } else { $heap->{readline_wheel}->put("\tException: $exception"); if ( $exception eq 'eot' ) { $irc->yield( unregister => 'all' ); $irc->yield( 'shutdown' ); delete ( $heap->{readline_wheel} ); } } $heap->{readline_wheel}->get("> ") if ( $heap->{readline_wheel} ); undef; } sub parse_input { my ($kernel, $heap, $input) = @_[KERNEL,HEAP,ARG0]; # Parse input if ( $input =~ /^\//) { $input =~ s/^\///; my (@args) = split(/ /,$input); my ($cmd) = shift @args; SWITCH: { if ( $cmd eq 'connect' ) { if ( $irc->connected() ) { $heap->{readline_wheel}->put("Already connected"); last SWITCH; } $heap->{readline_wheel}->put("Connecting"); $irc->yield( 'connect' ); last SWITCH; } if ( $cmd eq 'dump_state' ) { unless (@args) { $heap->{readline_wheel}->put($_) for split /\n/, Dumper($irc->{STATE}); } else { open my $fh, ">", $args[0] or return; print $fh Dumper($irc->{STATE}); } last SWITCH; } if ( $cmd eq 'sl' or $cmd eq 'quote' ) { $irc->yield( $cmd => join ( ' ', @args ) ); } else { $irc->yield( $cmd => @args ); } $heap->{readline_wheel}->put($cmd . " " . join(' ',@args) ); } } undef; } sub _default { my ( $event, $args ) = @_[ ARG0 .. $#_ ]; my (@output); my $arg_number = 0; foreach (@$args) { SWITCH: { if ( ref($_) eq 'ARRAY' ) { push ( @output, "[", join ( ", ", @$_ ), "]" ); last SWITCH; } if ( ref($_) eq 'HASH' ) { push ( @output, "{", join ( ", ", %$_ ), "}" ); last SWITCH; } push ( @output, "'$_'" ); } $arg_number++; } $_[HEAP]->{readline_wheel}->put("$event " . join(' ',@output) ) if ( defined ( $_[HEAP]->{readline_wheel} ) ); return 0; # Don't handle signals. } sub irc_public { my ($kernel,$heap,$who,$where,$what) = @_[KERNEL,HEAP,ARG0,ARG1,ARG2]; my ($nick) = ( split /!/, $who )[0]; my ($chan) = $where->[0]; $heap->{readline_wheel}->put($chan . ':<' . $nick . '> ' . $what); undef; } POE-Component-IRC-6.90/examples/tinyurl.pl0000755000175000017500000001107513153565114017666 0ustar bingosbingos#!/usr/bin/perl -w # # tinyurl.pl listens on a channel for URLs longer than a certain length, # and then makes a tinyurl shortcut to them for the convenience of the # poor bastards using terminal-based IRC clients. # # -- dennis taylor, use strict; use POE; use POE::Component::IRC; use LWP::UserAgent; use HTTP::Response; use HTTP::Request::Common; use URI::Find; # but... but... who'd want to? use constant MIN_URL_LENGTH => 60; my @urls; my $finder = URI::Find->new( sub { push @urls, $_[1]; } ); my $ua = LWP::UserAgent->new(); my $chan = '#tempura'; my $nick = 'ebi'; my %services = ( tinyurl => \&_get_tinyurl, shorl => \&_get_shorl, masl => \&_get_masl, shorter => \&_get_shorter, ); my $current = 'tinyurl'; sub _start { my ($kernel) = $_[KERNEL]; $ua->agent( 'Mozilla/5.0 (X11; U; Linux i386; en-US; rv:1.0.0) Gecko/20020529' ); $kernel->post( 'urlbot', 'register', 'all'); $kernel->post( 'urlbot', 'connect', { Debug => 1, Nick => $nick, Server => $ARGV[0] || 'scissorman.phreeow.net', Port => $ARGV[1] || 6667, Username => 'neenio', Ircname => "tinyurl.pl", } ); } sub irc_001 { my ($kernel) = $_[KERNEL]; $kernel->post( 'urlbot', 'mode', $nick, '+i' ); $kernel->post( 'urlbot', 'join', $chan ); } sub irc_disconnected { my ($server) = $_[ARG0]; print "Lost connection to server $server.\n"; } sub irc_error { my $err = $_[ARG0]; print "Server error occurred! $err\n"; } sub irc_socketerr { my $err = $_[ARG0]; print "Couldn't connect to server: $err\n"; } sub _stop { my ($kernel) = $_[KERNEL]; print "Control session stopped.\n"; $kernel->call( 'urlbot', 'quit', 'Neenios on ice!' ); } sub irc_public { my ($kernel, $who, $chan, $msg) = @_[KERNEL, ARG0 .. ARG2]; make_tiny( $kernel, $who, $chan, $msg, 0 ); } sub irc_msg { my ($kernel, $who, $chan, $msg) = @_[KERNEL, ARG0 .. ARG2]; make_tiny( $kernel, $who, $chan, $msg, 1 ); } sub make_tiny { my ($kernel, $who, $chan, $msg, $private) = @_; $who =~ s/^(.*)!.*$/$1/ or die "Weird-ass who: $who"; # IGNORE INFOBOTS. ALL MUST DIE. return if $who eq "pea"; if ($msg =~ /^\s*$nick[:,\-!](?:\s*please)?\s*switch to (\w+)/i and not $private) { my $new_service = $1; if (exists $services{$new_service}) { $current = $new_service; $kernel->post( 'urlbot', 'privmsg', $chan, 'Done.' ); } else { my $known = join ', ', keys %services; $kernel->post( 'urlbot', 'privmsg', $chan, "Sorry, $who, I don't know that service. Here are the ones I do know about: $known." ); } } else { $finder->find( \$msg ); while (@urls) { my $url = shift @urls; next if length $url < MIN_URL_LENGTH; $kernel->post( 'urlbot', 'privmsg', $private ? $who : $chan, $services{$current}->( $who, $url ) ); } } } sub _get_tinyurl { my ($who, $url) = @_; my $re = '
(http://tinyurl\.com/.*?)
'; my $response = $ua->request( POST 'http://tinyurl.com/create.php', [ url => $url ] ); if ($response->is_success and $response->content =~ /$re/) { return "$who\'s url is at $1"; } else { return 'tinyurl.com sucks.'; } } sub _get_shorl { my ($who, $url) = @_; my $re = 'Shorl: (http://shorl\.com/.*?)
'; my $response = $ua->request( POST 'http://shorl.com/create.php', [ url => $url ] ); if ($response->is_success and $response->content =~ /$re/) { return "$who\'s url is at $1"; } else { return 'shorl.com sucks.'; } } sub _get_masl { my ($who, $url) = @_; my $re = 'Your shorter link is: '; my $response = $ua->request( POST 'http://makeashorterlink.com/index.php', [ url => $url ] ); if ($response->is_success and $response->content =~ /$re/) { return "$who\'s url is at $1"; } else { return 'makeashorterlink.com sucks.'; } } sub _get_shorter { my ($who, $url) = @_; my $re = 'is:

'; my $response = $ua->request( GET 'http://shorterlink.com/add_url.html', [ url => $url ] ); if ($response->is_success and $response->content =~ /$re/) { return "$who\'s url is at $1"; } else { return 'makeashorterlink.com sucks.'; } } POE::Component::IRC->new( 'urlbot' ) or die "Can't instantiate new IRC component!\n"; POE::Session->create( package_states => [ 'main' => [qw(_start _stop irc_001 irc_disconnected irc_socketerr irc_error irc_public irc_msg)],], ); $poe_kernel->run(); exit 0; POE-Component-IRC-6.90/t/0000755000175000017500000000000013153565114014241 5ustar bingosbingosPOE-Component-IRC-6.90/t/05_regression/0000755000175000017500000000000013153565114016725 5ustar bingosbingosPOE-Component-IRC-6.90/t/05_regression/01_dcc_chat_close.t0000644000175000017500000000636513153565114022341 0ustar bingosbingos# This make sures that we can close a DCC connection right after sending # some data over it. The original bug was that the DCC plugin didn't post # a delayed close event correctly so it ended up checking if there was data # left to be sent on an undefined value rather than the wheel in question. use strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE::Component::IRC; use POE::Component::Server::IRC; use POE; use Test::More tests => 12; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done irc_dcc_chat irc_dcc_start )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); if ($nick eq $irc->nick_name()) { is($where, '#testchannel', 'Joined Channel Test'); if ($nick eq 'TestBot2') { $irc->yield(dcc => TestBot1 => CHAT => '' => '' => 5); } } } sub irc_dcc_request { my ($sender, $cookie) = @_[SENDER, ARG3]; pass('Got dcc request'); $sender->get_heap()->yield(dcc_accept => $cookie); } sub irc_dcc_start { my ($sender, $id) = @_[SENDER, ARG0]; my $irc = $sender->get_heap(); pass('DCC started'); if ($irc->nick_name() eq 'TestBot2') { $irc->yield(dcc_chat => $id => 'MOO'); $irc->yield(dcc_close => $id); } } sub irc_dcc_chat { my ($sender, $what) = @_[SENDER, ARG3]; is($what, 'MOO', 'DCC CHAT test'); } sub irc_dcc_done { pass('Got dcc close'); $_[SENDER]->get_heap()->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/0000755000175000017500000000000013153565114016225 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/11_cycleempty/0000755000175000017500000000000013153565114020704 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/11_cycleempty/01_load.t0000644000175000017500000000220313153565114022305 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::CycleEmpty; my $bot = POE::Component::IRC::State->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::CycleEmpty->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::CycleEmpty'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::CycleEmpty'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::CycleEmpty'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/11_cycleempty/02_cycle.t0000644000175000017500000000607113153565114022475 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::CycleEmpty; use POE::Component::Server::IRC; use Test::More tests => 10; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); my $plugin = POE::Component::IRC::Plugin::CycleEmpty->new(); $bot2->plugin_add(CycleEmpty => $plugin); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_part irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name . ' logged in'); $irc->yield(join => '#testchannel') if $irc == $bot1; } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); if (!$heap->{joined} || $heap->{joined} != 2) { $heap->{joined}++; pass("$nick joined channel"); $bot2->yield(join => $where) if $irc == $bot1; } if ($irc == $bot2) { $bot1->yield(part => $where); if ($heap->{cycling}) { pass("$nick rejoined channel"); $bot1->yield('quit'); $bot2->yield('quit'); } } } sub irc_part { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass("$nick parted channel"); if ($irc == $bot2) { ok($plugin->is_cycling($where), "$nick is cycling"); $heap->{cycling} = 1; } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/12_autojoin/0000755000175000017500000000000013153565114020357 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/12_autojoin/05_password.t0000644000175000017500000000667413153565114022727 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 10; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(AutoJoin => POE::Component::IRC::Plugin::AutoJoin->new( Channels => { '#testchannel' => 'secret' }, RejoinOnKick => 1, Rejoin_delay => 1, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_chan_mode irc_kick )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $heap->{port} = $port; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); if ($irc == $bot1) { $irc->yield(join => '#testchannel'); } } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', "$nick joined $where"); if ($nick eq 'TestBot1') { $bot1->yield(mode => $where, '+k secret'); } else { $heap->{bot2_joined}++; if ($heap->{bot2_joined} == 1) { $bot1->yield(mode => $where, '+k topsecret'); } else { $bot1->yield('quit'); $bot2->yield('quit'); } } } sub irc_chan_mode { my ($heap, $where, $mode) = @_[HEAP, ARG1, ARG2]; return if $bot1 != $_[SENDER]->get_heap(); if ($mode eq '+k') { pass("$where key set"); $heap->{key_set}++; if ($heap->{key_set} == 1) { $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $heap->{port}, }); } else { $bot1->yield(kick => $where, 'TestBot2'); } } } sub irc_kick { my ($sender, $where, $victim) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $victim ne $irc->nick_name(); pass("$victim kicked from $where"); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/12_autojoin/06_kick_ban_password.t0000644000175000017500000001027513153565114024541 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 17; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(AutoJoin => POE::Component::IRC::Plugin::AutoJoin->new( Channels => { '#testchannel' => 'secret' }, RejoinOnKick => 1, Rejoin_delay => 1, Retry_when_banned => 1, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_chan_mode irc_kick )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $heap->{port} = $port; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); if ($irc == $bot1) { $irc->yield(join => '#testchannel'); $irc->yield(join => '#testchannel2'); } } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); like($where, qr/#testchannel2?/, "$nick joined $where"); if ($nick eq 'TestBot1') { if ($where eq '#testchannel') { $bot1->yield(mode => $where, '+k secret'); } else { $bot1->yield(mode => $where, '+k secret2'); } } elsif ($where eq '#testchannel') { $heap->{bot2_joined}++; if ($heap->{bot2_joined} == 1) { $bot1->yield(mode => $where, '+k topsecret'); } else { $bot2->yield(join => '#testchannel2', 'secret2'); } } else { $heap->{bot2_joined_2}++; if ($heap->{bot2_joined_2} == 1) { $bot1->yield(kick => $where, 'TestBot2'); } else { $bot1->yield('quit'); $bot2->yield('quit'); } } } sub irc_chan_mode { my ($heap, $where, $mode) = @_[HEAP, ARG1, ARG2]; return if $bot1 != $_[SENDER]->get_heap(); if ($mode eq '+k') { pass("$where key set"); $heap->{key_set}++; if ($heap->{key_set} == 2) { $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $heap->{port}, }); } elsif ($heap->{key_set} == 3) { $bot1->yield(mode => $where, '+b TestBot2!*@*'); $bot1->yield(kick => $where, 'TestBot2'); } } elsif ($mode eq '+b') { pass('Ban set'); } elsif ($mode eq '-b') { pass('Ban removed'); } } sub irc_kick { my ($sender, $where, $victim) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $victim ne $irc->nick_name(); pass("$victim kicked from $where"); $bot1->delay([mode => $where, '-b TestBot2!*@*'], 4); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/12_autojoin/02_join.t0000644000175000017500000000373413153565114022013 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 4; my $bot = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot->plugin_add(AutoJoin => POE::Component::IRC::Plugin::AutoJoin->new( Channels => ['#chan1', '#chan2'], )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); } sub irc_join { my ($sender, $heap, $where) = @_[SENDER, HEAP, ARG1]; my $irc = $sender->get_heap(); $heap->{joined}++; $where =~ /^#chan[12]$/ ? pass("Joined channel $where") : fail("Joined wrong channel $where"); ; $irc->yield('quit') if $heap->{joined} == 2; } sub irc_disconnected { my ($kernel) = $_[KERNEL]; pass('irc_disconnected'); $kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $bot->yield('shutdown'); $ircd->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/12_autojoin/03_banned.t0000644000175000017500000000577413153565114022312 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 9; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(AutoJoin => POE::Component::IRC::Plugin::AutoJoin->new( Retry_when_banned => 1, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_chan_mode irc_474 )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name.' logged in'); if ($irc == $bot1) { $irc->yield(join => '#testchannel'); } } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', $irc->nick_name. ' joined channel'); if ($nick eq 'TestBot1') { $irc->yield(mode => $where, '+b TestBot2!*@*'); } else { $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_chan_mode { my ($chan, $mode) = @_[ARG1, ARG2]; if ($mode eq '+b') { pass('Ban set'); $bot2->yield(join => $chan); } elsif ($mode eq '-b') { pass('Ban removed'); } } sub irc_474 { my ($chan) = $_[ARG2]->[0]; if (!$_[HEAP]->{denied}) { pass("Can't join due to ban"); $bot1->yield(mode => $chan, '-b TestBot2!*@*'); $_[HEAP]->{denied} = 1; } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $bot1->yield('shutdown'); $bot2->yield('shutdown'); $ircd->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/12_autojoin/01_load.t0000644000175000017500000000215313153565114021764 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::AutoJoin; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::AutoJoin->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::AutoJoin'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::AutoJoin'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::AutoJoin'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/12_autojoin/04_kicked.t0000644000175000017500000000570113153565114022304 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 8; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(AutoJoin => POE::Component::IRC::Plugin::AutoJoin->new( Channels => [ '#testchannel' ], RejoinOnKick => 1, Rejoin_delay => 1, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_kick irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $heap->{port} = $port; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name(). ' logged in'); if ($irc == $bot1) { $irc->yield(join => '#testchannel'); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $_[HEAP]->{port}, }); } } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', "$nick joined $where"); if ($nick eq 'TestBot2') { $heap->{joined}++; if ($heap->{joined} == 1) { $bot1->yield(kick => $where, 'TestBot2'); } else { $bot1->yield('quit'); $bot2->yield('quit'); } } } sub irc_kick { my ($sender, $where, $victim) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $victim ne $irc->nick_name(); pass("$victim kicked from $where"); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/01_ctcp/0000755000175000017500000000000013153565114017456 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/01_ctcp/02_replies.t0000644000175000017500000000712513153565114021614 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::CTCP; use POE::Component::Server::IRC; use Test::More tests => 8; my $bot = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot->plugin_add(CTCP => POE::Component::IRC::Plugin::CTCP->new( version => 'Test version', userinfo => 'Test userinfo', clientinfo => 'Test clientinfo', source => 'Test source', )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_disconnected irc_ctcpreply_version irc_ctcpreply_userinfo irc_ctcpreply_clientinfo irc_ctcpreply_source irc_ctcpreply_ping irc_ctcpreply_time )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(ctcp => $irc->nick_name(), 'VERSION'); $irc->yield(ctcp => $irc->nick_name(), 'USERINFO'); $irc->yield(ctcp => $irc->nick_name(), 'CLIENTINFO'); $irc->yield(ctcp => $irc->nick_name(), 'SOURCE'); $irc->yield(ctcp => $irc->nick_name(), 'PING test'); $irc->yield(ctcp => $irc->nick_name(), 'TIME'); } sub irc_ctcpreply_version { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; $heap->{replies}++; is($msg, 'Test version', 'CTCP VERSION reply'); $sender->get_heap()->yield('quit') if $heap->{replies} == 6; } sub irc_ctcpreply_userinfo { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; $heap->{replies}++; is($msg, 'Test userinfo', 'CTCP USERINFO reply'); $sender->get_heap()->yield('quit') if $heap->{replies} == 6; } sub irc_ctcpreply_clientinfo { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; $heap->{replies}++; is($msg, 'Test clientinfo', 'CTCP CLIENTINFO reply'); $sender->get_heap()->yield('quit') if $heap->{replies} == 6; } sub irc_ctcpreply_source { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; $heap->{replies}++; is($msg, 'Test source', 'CTCP SOURCE reply'); $sender->get_heap()->yield('quit') if $heap->{replies} == 6; } sub irc_ctcpreply_ping { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; $heap->{replies}++; is($msg, 'test', 'CTCP PING reply'); $sender->get_heap()->yield('quit') if $heap->{replies} == 6; } sub irc_ctcpreply_time { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; $heap->{replies}++; ok(length $msg, 'CTCP TIME reply'); $sender->get_heap()->yield('quit') if $heap->{replies} == 6; } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/01_ctcp/01_load.t0000644000175000017500000000212713153565114021064 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::CTCP; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::CTCP->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::CTCP'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::CTCP'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::CTCP'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/05_isupport/0000755000175000017500000000000013153565114020416 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/05_isupport/01_load.t0000644000175000017500000000215313153565114022023 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::ISupport; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::ISupport->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::ISupport'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::ISupport'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::ISupport'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/05_isupport/02_isupport.t0000644000175000017500000000364513153565114023001 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 5; my $bot = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_isupport irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); } sub irc_isupport { my ($sender, $heap, $plugin) = @_[SENDER, HEAP, ARG0]; my $irc = $sender->get_heap(); return if $heap->{got_isupport}; $heap->{got_isupport}++; pass('irc_isupport'); isa_ok($plugin, 'POE::Component::IRC::Plugin::ISupport'); my @keys = $plugin->isupport_dump_keys(); ok($plugin->isupport(pop @keys), "Queried a parameter"); $irc->yield('quit'); } sub irc_disconnected { my ($kernel) = $_[KERNEL]; pass('irc_disconnected'); $kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/03_botaddressed/0000755000175000017500000000000013153565114021172 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/03_botaddressed/01_load.t0000644000175000017500000000217713153565114022605 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotAddressed; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::BotAddressed->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::BotAddressed'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::BotAddressed'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::BotAddressed'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/03_botaddressed/02_output.t0000644000175000017500000000652213153565114023225 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotAddressed; use POE::Component::Server::IRC; use Test::More tests => 10; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(BotAddressed => POE::Component::IRC::Plugin::BotAddressed->new()); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_disconnected irc_join irc_bot_addressed irc_bot_mentioned irc_bot_mentioned_action )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); $heap->{joined}++; pass($irc->nick_name() . ' joined channel'); return if $heap->{joined} != 2; $bot1->yield(privmsg => $where, $bot2->nick_name . ': y halo thar'); $bot1->yield(privmsg => $where, '@' . $bot2->nick_name . ': y halo thar'); $bot1->yield(privmsg => $where, 'y halo thar, ' . $bot2->nick_name()); $bot1->yield(ctcp => $where, 'ACTION greets ' . $bot2->nick_name()); } sub irc_bot_addressed { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; my $irc = $sender->get_heap(); is($msg, 'y halo thar', 'irc_bot_addressed'); } sub irc_bot_mentioned { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; my $irc = $sender->get_heap(); is($msg, 'y halo thar, ' . $irc->nick_name(), 'irc_bot_mentioned'); } sub irc_bot_mentioned_action { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; my $irc = $sender->get_heap(); is($msg, 'greets ' . $irc->nick_name(), 'irc_bot_mentioned_action'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/16_whois/0000755000175000017500000000000013153565114017664 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/16_whois/02_whois.t0000644000175000017500000000371713153565114021513 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 12; my $bot = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_whois irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(whois => $irc->nick_name()); } sub irc_whois { my ($sender, $heap, $whois) = @_[SENDER, HEAP, ARG0]; my $irc = $sender->get_heap(); pass('irc_whois'); is(keys %$whois, 8, 'Got whois info'); for my $key (qw(actually nick idle host user server real signon)) { ok(defined $whois->{$key}, "$key key present"); } $irc->yield('quit'); } sub irc_disconnected { my ($kernel, $heap, $sender) = @_[KERNEL, HEAP, SENDER]; my $irc = $sender->get_heap(); pass('irc_disconnected'); $kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/16_whois/01_load.t0000644000175000017500000000213413153565114021270 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::Whois; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::Whois->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::Whois'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Whois'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Whois'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/17_dcc/0000755000175000017500000000000013153565114017265 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/17_dcc/04_send_spaces.t0000644000175000017500000000632313153565114022250 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 13; use Data::Dumper; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); my $space_file = 'dcc with spaces'; open my $handle, '>', $space_file, or die "Couldn't open '$space_file': $!"; syswrite $handle, "One\nTwo\nThree\n"; POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done irc_dcc_start irc_dcc_error )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $bot1->yield(dcc => $bot2->nick_name() => SEND => $space_file => 1024 => 5); } sub irc_dcc_request { my ($sender, $cookie) = @_[SENDER, ARG3]; pass("Got dcc request"); $sender->get_heap()->yield(dcc_accept => $cookie => "$space_file.send"); } sub irc_dcc_start { pass('DCC started'); } sub irc_dcc_done { my ($sender, $size1, $size2) = @_[SENDER, ARG5, ARG6]; pass('Got dcc close'); is($size1, $size2, 'Send test results'); $sender->get_heap()->yield('quit'); } sub irc_dcc_error { my ($sender, $error) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); fail('('. $irc->nick_name() .") DCC failed: $error"); $irc->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; if ($heap->{count} == 2) { $kernel->yield('_shutdown'); unlink $space_file, "$space_file.send"; } } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/17_dcc/07_nat.t0000644000175000017500000000562113153565114020546 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 9; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done irc_dcc_error )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, nataddr => '127.0.0.100', }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, nataddr => '127.0.0.100', }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where,'#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $bot1->yield(dcc => $bot2->nick_name() => CHAT => undef, undef, 3); } sub irc_dcc_request { my ($sender, $cookie) = @_[SENDER, ARG3]; pass('Got dcc request'); is($cookie->{addr}, '2130706532', 'NAT Address'); $sender->get_heap()->yield('quit'); } sub irc_dcc_done { pass('Got dcc timeout'); $_[SENDER]->get_heap()->yield('quit'); } sub irc_dcc_error { my ($sender, $error) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); fail('('. $irc->nick_name() .") DCC failed: $error"); $sender->get_heap()->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } POE-Component-IRC-6.90/t/04_plugins/17_dcc/06_chat.t0000644000175000017500000000622313153565114020701 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE::Component::IRC; use POE::Component::Server::IRC; use POE; use Test::More tests => 13; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done irc_dcc_chat irc_dcc_start irc_dcc_error )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $bot1->yield(dcc => $bot2->nick_name() => CHAT => undef, undef, 5); } sub irc_dcc_request { my ($sender, $cookie) = @_[SENDER, ARG3]; pass('Got dcc request'); $sender->get_heap()->yield(dcc_accept => $cookie); } sub irc_dcc_start { my ($sender, $id) = @_[SENDER, ARG0]; pass('DCC started'); $sender->get_heap()->yield(dcc_chat => $id => 'MOO'); } sub irc_dcc_chat { my ($sender, $id, $what) = @_[SENDER, ARG0, ARG3]; is($what, 'MOO', 'DCC CHAT test'); $sender->get_heap()->yield(dcc_close => $id); } sub irc_dcc_done { pass('Got dcc close'); $_[SENDER]->get_heap()->yield('quit'); } sub irc_dcc_error { my ($sender, $error) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); fail('('. $irc->nick_name() .") DCC failed: $error"); $sender->get_heap()->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/17_dcc/02_timeout.t0000644000175000017500000000626713153565114021454 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE qw(Wheel::SocketFactory); use POE::Component::IRC; use POE::Component::Server::IRC; use Socket qw(unpack_sockaddr_in); use Test::More tests => 9; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done )], ], ); $poe_kernel->run(); sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; my ($port, $addr) = get_port() or $kernel->yield(_shutdown => 'No free port'); $heap->{_addr} = unpack 'N', $addr; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub get_port { my $wheel = POE::Wheel::SocketFactory->new( BindAddress => '127.0.0.1', BindPort => 0, SuccessEvent => '_fake_success', FailureEvent => '_fake_failure', ); return if !$wheel; return unpack_sockaddr_in($wheel->getsockname()) if wantarray; return (unpack_sockaddr_in($wheel->getsockname))[0]; } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $bot1->yield(dcc => $bot2->nick_name() => CHAT => undef, undef, 3); } sub irc_dcc_request { my ($sender, $heap, $cookie) = @_[SENDER, HEAP, ARG3]; pass('Got dcc request'); is($cookie->{addr}, $heap->{_addr}, 'Correct Address Test'); $sender->get_heap()->yield('quit'); } sub irc_dcc_done { pass('Got dcc timeout'); $_[SENDER]->get_heap()->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/17_dcc/03_send.t0000644000175000017500000000606713153565114020716 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use File::Temp qw(tempfile); use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 13; my ($rcv_fh, $rcv_file) = tempfile(UNLINK => 1); my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done irc_dcc_start irc_dcc_error )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $bot1->yield(dcc => $bot2->nick_name() => SEND => 'Changes' => 1024 => 5); } sub irc_dcc_request { my ($sender, $cookie) = @_[SENDER, ARG3]; pass("Got dcc request"); $sender->get_heap()->yield(dcc_accept => $cookie => $rcv_file); } sub irc_dcc_start { pass('DCC started'); } sub irc_dcc_done { my ($sender, $size1, $size2) = @_[SENDER, ARG5, ARG6]; pass('Got dcc close'); is($size1, $size2, 'Send test results'); $sender->get_heap()->yield('quit'); } sub irc_dcc_error { my ($sender, $error) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); fail('('. $irc->nick_name() .") DCC failed: $error"); $sender->get_heap()->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/17_dcc/01_load.t0000644000175000017500000000212213153565114020666 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::DCC; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::DCC->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::DCC'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::DCC'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::DCC'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/17_dcc/05_resume.t0000644000175000017500000000722013153565114021257 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use File::Temp qw(tempfile); use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::Differences; use Test::More tests => 12; my ($resume_fh, $resume_file) = tempfile(UNLINK => 1); my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_dcc_request irc_dcc_done irc_dcc_start irc_dcc_error )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $bot1->yield(dcc => $bot2->nick_name() => SEND => 'Changes', undef, 5); } sub irc_dcc_request { my ($sender, $type, $cookie) = @_[SENDER, ARG1, ARG3]; return if $type ne 'SEND'; pass('Got dcc request'); open (my $orig, '<', 'Changes') or die "Can't open Changes file: $!"; sysread $orig, my $partial, 12000; truncate $resume_fh, 12000; syswrite $resume_fh, $partial; $sender->get_heap()->yield(dcc_resume => $cookie => $resume_file); } sub irc_dcc_start { pass('DCC started'); } sub irc_dcc_done { my ($sender, $size1, $size2) = @_[SENDER, ARG5, ARG6]; my $irc = $sender->get_heap(); return if $irc != $bot2; pass('Got dcc done'); is($size1, $size2, 'Send test results'); open my $orig, '<', 'Changes' or die $!; open my $resume, '<', $resume_file or die $!; my $orig_changes = do { local $/; <$orig> }; my $resume_changes = do { local $/; <$resume> }; eq_or_diff($resume_changes, $orig_changes, 'File contents match'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_dcc_error { my ($sender, $error) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); fail('('. $irc->nick_name() .") DCC failed: $error"); $sender->get_heap()->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/10_followtail/0000755000175000017500000000000013153565114020701 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/10_followtail/01_load.t0000644000175000017500000000346213153565114022312 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use File::Temp qw(tempfile); use POE qw(Filter::Line); use POE::Component::IRC; use POE::Component::IRC::Plugin::FollowTail; use Test::More tests => 5; my ($temp_fh, $temp_file) = tempfile(UNLINK => 1); my $inode = (stat $temp_fh)[1]; $temp_fh->autoflush(1); print $temp_fh "moocow\n"; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del irc_tail_input) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::FollowTail->new( filename => $temp_file, filter => POE::Filter::Line->new(), ); isa_ok($plugin, 'POE::Component::IRC::Plugin::FollowTail'); if (!$bot->plugin_add('TestPlugin', $plugin) ) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::FollowTail'); print $temp_fh "Cows go moo, yes they do\n"; } sub irc_tail_input { my ($sender, $filename, $input) = @_[SENDER, ARG0, ARG1]; my $irc = $sender->get_heap(); SKIP: { skip "No inodes on Windows", 1 if $^O eq 'MSWin32'; is((stat $filename)[1], $inode, 'Filename is okay'); } is($input, 'Cows go moo, yes they do', 'Cows go moo!'); if (!$irc->plugin_del('TestPlugin')) { fail('plugin_del failed'); $irc->yield('shutdown'); } } sub irc_plugin_del { my ($sender, $name, $plugin) = @_[SENDER, ARG0, ARG1]; my $irc = $sender->get_heap(); return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::FollowTail'); $irc->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/07_console/0000755000175000017500000000000013153565114020175 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/07_console/01_load.t0000644000175000017500000000214613153565114021604 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::Console; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::Console->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::Console'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Console'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Console'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/06_plugman/0000755000175000017500000000000013153565114020175 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/06_plugman/02_add.t0000644000175000017500000000366013153565114021420 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::PlugMan; use Test::More tests => 8; { package MyPlugin; use POE::Component::IRC::Plugin qw( :ALL ); sub new { return bless { @_[1..$#_] }, $_[0]; } sub PCI_register { $_[1]->plugin_register($_[0], 'SERVER', qw(all)); return 1; } sub PCI_unregister { return 1; } sub _default { return PCI_EAT_NONE; } } my $bot = POE::Component::IRC::State->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw( _start irc_plugin_add irc_plugin_del )], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::PlugMan->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::PlugMan'); if (!$bot->plugin_add('TestPlugin', $plugin)) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($sender, $name, $plugin) = @_[SENDER, ARG0, ARG1]; my $irc = $sender->get_heap(); return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::PlugMan'); ok($plugin->load('Test1', 'POE::Component::IRC::Test::Plugin'), 'PlugMan_load'); ok($plugin->reload('Test1'), 'PlugMan_reload'); ok($plugin->unload('Test1'), 'PlugMan_unload'); ok($plugin->load('Test2', MyPlugin->new()), 'PlugMan2_load'); ok($plugin->unload('Test2'), 'PlugMan2_unload'); if (!$irc->plugin_del('TestPlugin')) { fail('plugin_del failed'); $irc->yield('shutdown' ); } } sub irc_plugin_del { my ($sender, $name, $plugin) = @_[SENDER, ARG0, ARG1]; my $irc = $sender->get_heap(); return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::PlugMan'); $irc->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/06_plugman/03_irc_interface.t0000644000175000017500000000554613153565114023473 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::PlugMan; use POE::Component::Server::IRC; use Test::More tests => 12; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot1->plugin_add(PlugMan => POE::Component::IRC::Plugin::PlugMan->new( botowner => 'TestBot2!*@*', )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_chan_sync irc_public irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_chan_sync { my ($heap, $where) = @_[HEAP, ARG0]; is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; if ($heap->{joined} == 2) { $bot2->yield(privmsg => $where, $bot1->nick_name() . ': plugin_add CTCP POE::Component::IRC::Plugin::CTCP'); $bot2->yield(privmsg => $where, $bot1->nick_name() . ': plugin_reload CTCP'); $bot2->yield(privmsg => $where, $bot1->nick_name() . ': plugin_del CTCP'); } } sub irc_public { my $irc = $_[SENDER]->get_heap(); if ($irc == $bot1) { pass('Got command'); } else { pass('Got response'); $_[HEAP]->{response}++; if ($_[HEAP]->{response} == 3) { $bot1->yield('quit'); $bot2->yield('quit'); } } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/06_plugman/01_load.t0000644000175000017500000000214613153565114021604 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::PlugMan; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::PlugMan->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::PlugMan'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::PlugMan'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::PlugMan'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/06_plugman/04_auth_sub.t0000644000175000017500000000761313153565114022506 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::PlugMan; use POE::Component::Server::IRC; use Test::More tests => 14; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot3 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot1->plugin_add(PlugMan => POE::Component::IRC::Plugin::PlugMan->new( auth_sub => sub { return 1 if $_[1] =~ /^TestBot2!\S+@\S+$/; return }, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_chan_sync irc_public irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); $bot3->yield(register => 'all'); $bot3->yield(connect => { nick => 'TestBot3', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_chan_sync { my ($heap, $where) = @_[HEAP, ARG0]; is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; if ($heap->{joined} == 3) { # these should succeed $bot2->yield(privmsg => $where, $bot1->nick_name() . ': plugin_add CTCP POE::Component::IRC::Plugin::CTCP'); $bot2->yield(privmsg => $where, $bot1->nick_name() . ': plugin_reload CTCP'); } } sub irc_public { my $irc = $_[SENDER]->get_heap(); my $nick = (split /!/, $_[ARG0])[0]; my $where = $_[ARG1]->[0]; my $what = $_[ARG2]; return if $irc == $bot3; if ($irc == $bot1) { pass($irc->nick_name() . ' got command'); $_[HEAP]->{commands}++; if ($_[HEAP]->{commands} == 2) { # should fail and not generate a response $bot3->yield(privmsg => $where, $bot1->nick_name() . ': plugin_reload CTCP'); } elsif ($_[HEAP]->{commands} == 3) { # this should be the last message on the channel $bot1->yield(privmsg => $where, 'LAST MESSAGE'); } } elsif ($nick eq $bot1->nick_name()) { if ($what eq 'LAST MESSAGE') { $bot1->yield('quit'); $bot2->yield('quit'); $bot3->yield('quit'); return; } pass($irc->nick_name() . ' got response'); $_[HEAP]->{responses}++; if ($_[HEAP]->{responses} > 2) { fail "Superfluous message: $what\n"; return; } } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 3; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); $bot3->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/08_proxy/0000755000175000017500000000000013153565114017715 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/08_proxy/01_load.t0000644000175000017500000000215213153565114021321 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Proxy; my $bot = POE::Component::IRC::State->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::Proxy->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::Proxy'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Proxy'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Proxy'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/08_proxy/02_connect.t0000644000175000017500000000652513153565114022044 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Proxy; use POE::Component::Server::IRC; use Socket qw(unpack_sockaddr_in); use Test::More tests => 8; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure irc_proxy_up _shutdown irc_001 irc_332 irc_topic irc_join irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; $bot1->plugin_add(Proxy => POE::Component::IRC::Plugin::Proxy->new( password => 'proxy_pass', )); $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub irc_proxy_up { my ($heap, $port) = @_[HEAP, ARG0]; $heap->{proxy_port} = (unpack_sockaddr_in($port))[0]; } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); if ($irc == $bot1) { pass($irc->nick_name() . ' logged in'); $irc->yield(join => '#testchannel'); } else { pass($irc->nick_name() . ' logged in (via proxy)'); } } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); if ($irc == $bot1) { like($where, qr/#testchannel/, "$nick joined $where"); $irc->yield(topic => $where, 'Some topic'); } else { like($where, qr/#testchannel/, "$nick joined $where (via proxy)"); } } sub irc_topic { my ($heap, $sender, $topic) = @_[HEAP, SENDER, ARG2]; my $irc = $sender->get_heap(); is($topic, 'Some topic', $irc->nick_name() . ' changed topic'); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $heap->{proxy_port}, password => 'proxy_pass', }); } sub irc_332 { my ($heap, $sender, $reply) = @_[HEAP, SENDER, ARG2]; my $topic = $reply->[1]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($topic, 'Some topic', $irc->nick_name() . ' got topic (via proxy)'); $bot2->yield('quit'); $bot1->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/04_bottraffic/0000755000175000017500000000000013153565114020653 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/04_bottraffic/01_load.t0000644000175000017500000000216513153565114022263 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotTraffic; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::BotTraffic->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::BotTraffic'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::BotTraffic'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::BotTraffic'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/04_bottraffic/02_output.t0000644000175000017500000000547013153565114022707 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotTraffic; use POE::Component::Server::IRC; use Test::More tests => 7; my $bot = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot->plugin_add(BotTraffic => POE::Component::IRC::Plugin::BotTraffic->new()); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected irc_bot_public irc_bot_msg irc_bot_action irc_bot_notice )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); pass('Joined channel'); $irc->yield(privmsg => $where, 'A public message'); } sub irc_bot_public { my ($sender, $text) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); is($text, 'A public message', 'irc_bot_public'); $irc->yield(privmsg => $irc->nick_name(), 'A private message'); } sub irc_bot_msg { my ($sender, $text) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); is($text, 'A private message', 'irc_bot_msg'); $irc->yield(ctcp => 'TestBot1', 'ACTION some action'); } sub irc_bot_action { my ($sender, $text) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); is($text, 'some action', 'irc_bot_action'); $irc->yield(notice => 'TestBot1', 'some notice'); } sub irc_bot_notice { my ($sender, $text) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); is($text, 'some notice', 'irc_bot_action'); $irc->yield('quit'); } sub irc_disconnected { my ($kernel) = $_[KERNEL]; pass('irc_disconnected'); $kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/15_nickservid/0000755000175000017500000000000013153565114020673 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/15_nickservid/01_load.t0000644000175000017500000000221113153565114022273 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::NickServID; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::NickServID->new( Password => 'test' ); isa_ok($plugin, 'POE::Component::IRC::Plugin::NickServID'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::NickServID'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::NickServID'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/13_botcommand/0000755000175000017500000000000013153565114020653 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/13_botcommand/05_auth_sub.t0000644000175000017500000000722313153565114023162 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 14; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_notice irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new( Auth_sub => sub { return 1 if $_[3] eq 'help'; return 0; } ); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with no commands'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; $bot2->yield(privmsg => $where, "TestBot1: help"); $bot2->yield(privmsg => $where, "TestBot1: help foo"); } sub irc_notice { my ($sender, $heap, $who, $where, $what) = @_[SENDER, HEAP, ARG0..ARG2]; my $irc = $sender->get_heap(); my $nick = (split /!/, $who)[0]; return if $irc != $bot2; $heap->{replies}++; ## no critic (ControlStructures::ProhibitCascadingIfElse) if ($heap->{replies} == 1) { is($nick, $bot1->nick_name(), 'Bot nickname'); like($what, qr/^No commands/, 'Bot reply'); } elsif ($heap->{replies} == 2) { is($nick, $bot1->nick_name(), 'Bot nickname'); like($what, qr/^Unknown command:/, 'Bot reply'); my ($p) = grep { $_->isa('POE::Component::IRC::Plugin::BotCommand') } values %{ $bot1->plugin_list() }; ok($p->add(foo => 'Test command'), 'Add command foo'); $irc->yield(privmsg => $where, "TestBot1: hlagh"); } elsif ($heap->{replies} == 4) { is($nick, $bot1->nick_name(), 'Bot nickname'); like($what, qr/^You are not authorized/, 'Bot reply'); $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } POE-Component-IRC-6.90/t/04_plugins/13_botcommand/07_bare_private.t0000644000175000017500000000745713153565114024026 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 18; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_botcmd_cmd1 irc_botcmd_cmd2 irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new( Bare_private => 1, Commands => { cmd1 => 'First test command', foo => 'This will get removed', }, ); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with two commands'); ok($plugin->add(cmd2 => 'Second test command'), 'Add another command'); ok($plugin->remove('foo'), 'Remove command'); my %cmds = $plugin->list(); is(keys %cmds, 2, 'Correct number of commands'); ok($cmds{cmd1}, 'First command is present'); ok($cmds{cmd2}, 'Second command is present'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; # try command $bot2->yield(privmsg => $bot1->nick_name(), "cmd1 foo bar"); # and one with color $bot2->yield(privmsg => $bot1->nick_name(), "\x02cmd2\x0f"); } sub irc_botcmd_cmd1 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Normal command (user)'); is($where, $bot2->nick_name(), 'Normal command (channel)'); is($args, 'foo bar', 'Normal command (arguments)'); } sub irc_botcmd_cmd2 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Colored command (user)'); is($where, $bot2->nick_name(), 'Colored command (channel)'); ok(!defined $args, 'Colored command (arguments)'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } POE-Component-IRC-6.90/t/04_plugins/13_botcommand/04_help.t0000644000175000017500000001037513153565114022301 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 25; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_notice irc_disconnected )], ], ); my @bar_help = ( "Syntax: TestBot1: bar arg1 arg2 ...", "Description: Test command2", "Arguments:", " arg1: What to bar (table|chair)", " arg2: Where to bar" ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new(); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with no commands'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; $bot2->yield(privmsg => $where, "TestBot1: help"); $bot2->yield(privmsg => $where, "TestBot1: help foo"); } sub irc_notice { my ($sender, $heap, $who, $where, $what) = @_[SENDER, HEAP, ARG0..ARG2]; my $irc = $sender->get_heap(); my $nick = (split /!/, $who)[0]; return if $irc != $bot2; $heap->{replies}++; ## no critic (ControlStructures::ProhibitCascadingIfElse) if ($heap->{replies} == 1) { is($nick, $bot1->nick_name(), 'Bot nickname'); like($what, qr/^No commands/, 'Bot reply'); } elsif ($heap->{replies} == 2) { is($nick, $bot1->nick_name(), 'Bot nickname'); like($what, qr/^Unknown command:/, 'Bot reply'); my ($p) = grep { $_->isa('POE::Component::IRC::Plugin::BotCommand') } values %{ $bot1->plugin_list() }; ok($p->add(foo => 'Test command'), 'Add command foo'); ok($p->add(bar => { info => 'Test command2', args => [qw(arg1 arg2)], arg1 => ['What to bar', qw(table chair)], arg2 => 'Where to bar', variable => 1, }), 'Add command bar'); $irc->yield(privmsg => $where, "TestBot1: help"); $irc->yield(privmsg => $where, "TestBot1: help bar"); } elsif ($heap->{replies} == 4) { is($nick, $bot1->nick_name(), 'Bot nickname'); like($what, qr/^Commands: bar, foo/, 'Bot reply'); } elsif ($heap->{replies} >= 6 && $heap->{replies} <= 11) { is($nick, $bot1->nick_name(), 'Bot nickname'); is($what, shift @bar_help, 'Command with args help'); $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } POE-Component-IRC-6.90/t/04_plugins/13_botcommand/01_load.t0000644000175000017500000000216513153565114022263 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::BotCommand->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::BotCommand'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::BotCommand'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::BotCommand'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/13_botcommand/03_options.t0000644000175000017500000001013413153565114023034 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 18; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); { package TestPlugin; use POE::Component::IRC::Plugin 'PCI_EAT_NONE'; use Test::More; use strict; use warnings; sub new { bless {}, shift } sub PCI_register { $_[1]->plugin_register($_[0], 'SERVER', 'public'); 1 } sub PCI_unregister { 1 } sub S_public { fail("Shouldn't get irc_public event"); PCI_EAT_NONE; } } POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_botcmd_cmd1 irc_botcmd_cmd2 irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new( Commands => { cmd1 => 'First test command', foo => 'This will get removed', }, Addressed => 0, Prefix => ',', Eat => 1, ); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with two commands'); $irc->plugin_add(TestPlugin => TestPlugin->new()); ok($plugin->add(cmd2 => 'Second test command'), 'Add another command'); ok($plugin->remove('foo'), 'Remove one command'); my %cmds = $plugin->list(); is(keys %cmds, 2, 'Correct number of commands'); ok($cmds{cmd1}, 'First command is present'); ok($cmds{cmd2}, 'Second command is present'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; $bot2->yield(privmsg => $where, ",cmd1 foo bar"); $bot2->yield(privmsg => $where, ",cmd2"); } sub irc_botcmd_cmd1 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'cmd1 user'); is($where, '#testchannel', 'cmd1 channel'); is($args, 'foo bar', 'cmd1 arguments'); } sub irc_botcmd_cmd2 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'cmd2 user'); is($where, '#testchannel', 'cmd2 channel'); ok(!defined $args, 'cmd1 arguments'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } POE-Component-IRC-6.90/t/04_plugins/13_botcommand/06_prefix.t0000644000175000017500000000752313153565114022651 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 18; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_botcmd_cmd1 irc_botcmd_cmd2 irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new( Addressed => 0, Prefix => '(', # regex metacharacter should not cause issues Commands => { cmd1 => 'First test command', foo => 'This will get removed', }, ); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with two commands'); ok($plugin->add(cmd2 => 'Second test command'), 'Add another command'); ok($plugin->remove('foo'), 'Remove command'); my %cmds = $plugin->list(); is(keys %cmds, 2, 'Correct number of commands'); ok($cmds{cmd1}, 'First command is present'); ok($cmds{cmd2}, 'Second command is present'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; # try command $bot2->yield(privmsg => $where, "(cmd1 foo bar"); # and one with color $bot2->yield(privmsg => $where, "\x02(cmd2\x0f"); } sub irc_botcmd_cmd1 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Normal command (user)'); is($where, '#testchannel', 'Normal command (channel)'); is($args, 'foo bar', 'Normal command (arguments)'); } sub irc_botcmd_cmd2 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Colored command (user)'); is($where, '#testchannel', 'Colored command (channel)'); ok(!defined $args, 'Colored command (arguments)'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } POE-Component-IRC-6.90/t/04_plugins/13_botcommand/02_commands.t0000644000175000017500000001137713153565114023153 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 22; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_botcmd_cmd1 irc_botcmd_cmd2 irc_botcmd_cmd3 irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new( Commands => { cmd1 => 'First test command', cmd2 => { info => 'First test command with argument count checking', args => [qw(test_arg test_arg2)], variable => 1, test_arg => ['Description of first arg', qw(value1 value2)], test_arg2 => 'Description of second arg', optional_arg => 'Description of optional arg', }, foo => 'This will get removed', }, ); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with three commands'); ok($plugin->add(cmd3 => 'Third test command'), 'Add another command'); ok($plugin->remove('foo'), 'Remove command'); my %cmds = $plugin->list(); is(keys %cmds, 3, 'Correct number of commands'); ok($cmds{cmd1}, 'First command is present'); ok($cmds{cmd2}, 'Second command is present'); ok($cmds{cmd3}, 'Third command is present'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; # try command $bot2->yield(privmsg => $where, "TestBot1: cmd1 foo bar"); # try command with predefined arguments $bot2->yield(privmsg => $where, "TestBot1: cmd2 value1 bar opt_arg"); # and one with color $bot2->yield(privmsg => $where, "\x0302TestBot1\x0f: \x02cmd3\x0f"); } sub irc_botcmd_cmd1 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Normal command (user)'); is($where, '#testchannel', 'Normal command (channel)'); is($args, 'foo bar', 'Normal command (arguments)'); } sub irc_botcmd_cmd2 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Command with args (user)'); is($where, '#testchannel', 'Command with args (channel)'); is_deeply($args, { test_arg => 'value1', test_arg2 => 'bar', opt0 => 'opt_arg'}, 'Command with args (arguments)'); } sub irc_botcmd_cmd3 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Colored command (user)'); is($where, '#testchannel', 'Colored command (channel)'); ok(!defined $args, 'Colored command (arguments)'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } POE-Component-IRC-6.90/t/04_plugins/13_botcommand/08_nonword.t0000644000175000017500000000766113153565114023047 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Server::IRC; use Test::More tests => 18; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected )], main => { 'irc_botcmd_cmd-1' => 'irc_botcmd_cmd1', 'irc_botcmd_cmd-2' => 'irc_botcmd_cmd2', }, ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); return if $irc != $bot1; my $plugin = POE::Component::IRC::Plugin::BotCommand->new( Addressed => 0, Prefix => '(', # regex metacharacter should not cause issues Commands => { 'cmd-1' => 'First test command', foo => 'This will get removed', }, ); ok($irc->plugin_add(BotCommand => $plugin), 'Add plugin with two commands'); ok($plugin->add('cmd-2', 'Second test command'), 'Add another command'); ok($plugin->remove('foo'), 'Remove command'); my %cmds = $plugin->list(); is(keys %cmds, 2, 'Correct number of commands'); ok($cmds{'cmd-1'}, 'First command is present'); ok($cmds{'cmd-2'}, 'Second command is present'); } sub irc_join { my ($heap, $sender, $who, $where) = @_[HEAP, SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass('Joined channel'); $heap->{joined}++; return if $heap->{joined} != 2; # try command $bot2->yield(privmsg => $where, "(cmd-1 foo bar"); # and one with color $bot2->yield(privmsg => $where, "\x02(cmd-2\x0f"); } sub irc_botcmd_cmd1 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Normal command (user)'); is($where, '#testchannel', 'Normal command (channel)'); is($args, 'foo bar', 'Normal command (arguments)'); } sub irc_botcmd_cmd2 { my ($sender, $user, $where, $args) = @_[SENDER, ARG0..ARG2]; my $nick = (split /!/, $user)[0]; my $irc = $sender->get_heap(); is($nick, $bot2->nick_name(), 'Colored command (user)'); is($where, '#testchannel', 'Colored command (channel)'); ok(!defined $args, 'Colored command (arguments)'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $poe_kernel->yield('_shutdown') if $heap->{count} == 2; } POE-Component-IRC-6.90/t/04_plugins/14_logger/0000755000175000017500000000000013153565114020010 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/14_logger/03_private.t0000644000175000017500000001031313153565114022147 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use File::Temp qw(tempdir); use File::Spec::Functions qw(catfile); use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Logger; use POE::Component::Server::IRC; use Test::More; my $log_dir = tempdir(CLEANUP => 1); my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(Logger => POE::Component::IRC::Plugin::Logger->new( Path => $log_dir, Notices => 1, )); my $file = catfile($log_dir, 'testbot1.log'); unlink $file if -e $file; my @correct = ( ' Hello there', ' Hi yourself', '* TestBot1 is talking', '* TestBot2 is too', '>TestBot1< This is a notice', '>TestBot2< So is this', ); plan tests => 8 + @correct; POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_msg irc_ctcp_action irc_notice irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my ($heap, $server) = @_[HEAP, ARG0]; my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); $heap->{logged_in}++; return if $heap->{logged_in} != 2; $bot1->yield(privmsg => $bot2->nick_name(), 'Hello there'); $heap->{msg}++; } sub irc_msg { my $heap = $_[HEAP]; pass('irc_msg'); if ($heap->{msg} == 1) { $bot2->yield(privmsg => $bot1->nick_name(), 'Hi yourself'); $heap->{msg}++; } elsif ($heap->{msg} == 2) { $bot1->yield(ctcp => $bot2->nick_name(), 'ACTION is talking'); $heap->{msg}++; } } sub irc_ctcp_action { my $heap = $_[HEAP]; pass('irc_ctcp_action'); if ($heap->{msg} == 3) { $bot2->yield(ctcp => $bot1->nick_name(), 'ACTION is too'); $heap->{msg}++; } elsif ($heap->{msg} == 4) { $bot1->yield(notice => $bot2->nick_name(), 'This is a notice'); $heap->{msg}++; } } sub irc_notice { my $heap = $_[HEAP]; if ($heap->{msg} == 5) { $bot2->yield(notice => $bot1->nick_name(), 'So is this'); $heap->{msg}++; } elsif ($heap->{msg} == 6) { $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; if ($heap->{count} == 2) { verify_log(); $kernel->yield('_shutdown'); } } sub verify_log { open my $log, '<', $file or die "Can't open log file '$file': $!"; my @lines = <$log>; close $log; my $check = 0; for my $line (@lines) { next if $line =~ /^\*{3}/; chomp $line; $line = substr($line, 20); last if !defined $correct[$check]; if (ref $correct[$check] eq 'Regexp') { like($line, $correct[$check], 'Line ' . ($check+1)); } else { is($line, $correct[$check], 'Line ' . ($check+1)); } $check++; } fail('Log too short') if $check > @correct; } POE-Component-IRC-6.90/t/04_plugins/14_logger/04_dcc_chat.t0000644000175000017500000001051213153565114022227 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use File::Temp qw(tempdir); use File::Spec::Functions qw(catfile); use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Logger; use POE::Component::Server::IRC; use Test::More; my $log_dir = tempdir(CLEANUP => 1); my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(Logger => POE::Component::IRC::Plugin::Logger->new( Path => $log_dir, )); my $file = catfile($log_dir, '=testbot1.log'); unlink $file if -e $file; my @correct = ( qr/^--> Opened DCC chat connection with TestBot1 \(\S+:\d+\)$/, ' Oh hi', '* TestBot1 does something', ' Hi yourself', '* TestBot2 does something as well', qr/^<-- Closed DCC chat connection with TestBot1 \(\S+:\d+\)$/, ); plan tests => 7 + @correct; POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_dcc_request irc_dcc_start irc_dcc_chat irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my ($heap, $server) = @_[HEAP, ARG0]; my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); $heap->{logged_in}++; return if $heap->{logged_in} != 2; $bot2->yield(dcc => $bot1->nick_name() => CHAT => undef, undef, 5); } sub irc_dcc_request { my ($sender, $cookie) = @_[SENDER, ARG3]; my $irc = $sender->get_heap(); pass($irc->nick_name() . ' got dcc request'); $irc->yield(dcc_accept => $cookie); } sub irc_dcc_start { my ($sender, $heap, $id) = @_[SENDER, HEAP, ARG0]; my $irc = $sender->get_heap(); pass($irc->nick_name() . ' got irc_dcc_started'); $heap->{started}++; if ($heap->{started} == 2) { $irc->yield(dcc_chat => $id, 'Oh hi'); $irc->yield(dcc_chat => $id, "\001ACTION does something\001"); } } sub irc_dcc_chat { my ($heap, $sender, $id, $msg) = @_[HEAP, SENDER, ARG0, ARG3]; my $irc = $sender->get_heap(); $heap->{msgs}++; if ($heap->{msgs} == 2) { $irc->yield(dcc_chat => $id, 'Hi yourself'); $irc->yield(dcc_chat => $id, "\001ACTION does something as well\001"); } elsif ($heap->{msgs} == 4) { $irc->yield(dcc_close => $id); $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; if ($heap->{count} == 2) { verify_log(); $kernel->yield('_shutdown'); } } sub verify_log { open my $log, '<', $file or die "Can't open log file '$file': $!"; my @lines = <$log>; close $log; my $check = 0; for my $line (@lines) { next if $line =~ /^\*{3}/; chomp $line; $line = substr($line, 20); last if !defined $correct[$check]; if (ref $correct[$check] eq 'Regexp') { like($line, $correct[$check], 'Line ' . ($check+1)); } else { is($line, $correct[$check], 'Line ' . ($check+1)); } $check++; } fail('Log too short') if $check > @correct; } POE-Component-IRC-6.90/t/04_plugins/14_logger/05_log_sub.t0000644000175000017500000000561013153565114022135 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use File::Spec::Functions qw(catfile); use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Logger; use POE::Component::Server::IRC; use Test::More tests => 12; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); my $got = 0; $bot1->plugin_add(Logger => POE::Component::IRC::Plugin::Logger->new( Log_sub => sub { $got++; if ($got == 1) { is($_[0], '#testchannel', 'Got context'); is($_[1], 'join', 'Got type'); is($_[2], 'TestBot1', 'Got arguments'); } elsif ($got == 2) { is($_[0], '#testchannel', 'Got context'); is($_[1], '+n', 'Got type'); is($_[2], 'poco.server.irc', 'Got arguments'); } elsif ($got == 3) { is($_[0], '#testchannel', 'Got context'); is($_[1], '+t', 'Got type'); is($_[2], 'poco.server.irc', 'Got arguments'); } elsif ($got == 4) { is($_[0], '#testchannel', 'Got context'); is($_[1], 'quit', 'Got type'); is($_[2], 'TestBot1', 'Got arguments'); } } )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); } sub irc_001 { my ($heap, $server) = @_[HEAP, ARG0]; my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass("$nick joined channel"); $bot1->yield('quit'); } sub irc_disconnected { my ($kernel, $sender) = @_[KERNEL, SENDER]; my $irc = $sender->get_heap(); pass('irc_disconnected'); $kernel->yield('_shutdown'); } POE-Component-IRC-6.90/t/04_plugins/14_logger/02_public.t0000644000175000017500000001336513153565114021764 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use File::Temp qw(tempdir); use File::Spec::Functions qw(catfile); use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Logger; use POE::Component::Server::IRC; use Test::More; my $log_dir = tempdir(CLEANUP => 1); my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(Logger => POE::Component::IRC::Plugin::Logger->new( Path => $log_dir, Notices => 1, )); my $file = catfile($log_dir, '#testchannel.log'); my @correct = ( qr/^--> TestBot2 \(\S+@\S+\) joins #testchannel$/, ' Oh hi', '>TestBot1< Hello', '--- TestBot1 disables topic protection', '--- TestBot1 enables secret channel status', '--- TestBot1 enables channel moderation', '--- TestBot1 sets channel keyword to foo', '--- TestBot1 removes channel keyword', '--- TestBot1 sets channel user limit to 10', '--- TestBot1 removes channel user limit', '--- TestBot1 sets ban on TestBot2!*@*', '--- TestBot1 removes ban on TestBot2!*@*', '--- TestBot1 gives channel operator status to TestBot2', '--- TestBot1 changes the topic to: Testing, 1 2 3', '--- TestBot1 is now known as NewNick', qr/^<-- NewNick \(\S+@\S+\) leaves #testchannel \(NewNick\)$/, qr/^--> NewNick \(\S+@\S+\) joins #testchannel$/, '<-- TestBot2 kicks NewNick from #testchannel (Bye bye)', qr/^--> NewNick \(\S+@\S+\) joins #testchannel$/, qr/^<-- NewNick \(\S+@\S+\) quits \(.*\)$/, ); plan tests => 10 + @correct; POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_part irc_kick irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } sub irc_001 { my ($heap, $server) = @_[HEAP, ARG0]; my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name() . ' logged in'); $heap->{logged_in}++; if ($heap->{logged_in} == 2) { $bot1->yield(join => '#testchannel'); } } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass("$nick joined channel"); $heap->{joined}++; if ($heap->{joined} == 1) { $bot2->yield(join => $where); return; } if ($heap->{done}) { $bot1->yield('quit'); return; } if ($irc == $bot2) { $bot1->yield(privmsg => $where, 'Oh hi'); $bot1->yield(notice => $where, 'Hello'); $bot1->yield(mode => $where, '-t'); $bot1->yield(mode => $where, '+s'); $bot1->yield(mode => $where, '+m'); $bot1->yield(mode => $where, '+k foo'); $bot1->yield(mode => $where, '-k'); $bot1->yield(mode => $where, '+l 10'); $bot1->yield(mode => $where, '-l'); $bot1->yield(mode => $where, '+b TestBot2!*@*'); $bot1->yield(mode => $where, '-b TestBot2!*@*'); $bot1->yield(mode => $where, '+o TestBot2'); $bot1->yield(topic => $where, 'Testing, 1 2 3'); $bot1->yield(nick => 'NewNick'); $bot1->yield(part => $where); } else { $bot2->yield(kick => $where, $bot1->nick_name(), 'Bye bye'); } } sub irc_part { my $irc = $_[SENDER]->get_heap(); my $nick = (split /!/, $_[ARG0])[0]; if ($nick eq $irc->nick_name()) { pass("$nick parted channel"); $irc->yield(join => $_[ARG1]); } } sub irc_kick { my ($heap, $chan, $nick) = @_[HEAP, ARG1, ARG2]; my $irc = $_[SENDER]->get_heap(); return if $nick ne $irc->nick_name(); pass($nick . ' kicked'); $irc->yield(join => $chan); $heap->{done} = 1; } sub irc_disconnected { my ($kernel, $sender) = @_[KERNEL, SENDER]; my $irc = $sender->get_heap(); pass('irc_disconnected'); if ($irc == $bot1) { $bot2->yield('quit'); } else { verify_log(); $kernel->yield('_shutdown'); } } sub verify_log { open my $log, '<', $file or die "Can't open log file '$file': $!"; my @lines = <$log>; close $log; my $check = 0; for my $line (@lines) { next if $line =~ /^\*{3}/; chomp $line; $line = substr($line, 20); last if !defined $correct[$check]; if (ref $correct[$check] eq 'Regexp') { like($line, $correct[$check], 'Line ' . ($check+1)); } else { is($line, $correct[$check], 'Line ' . ($check+1)); } $check++; } fail('Log too short') if $check > @correct; } POE-Component-IRC-6.90/t/04_plugins/14_logger/01_load.t0000644000175000017500000000230313153565114021412 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use File::Temp qw(tempdir); use Test::More tests => 3; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::Logger; my $log_dir = tempdir(CLEANUP => 1); my $bot = POE::Component::IRC::State->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::Logger->new( Path => $log_dir ); isa_ok($plugin, 'POE::Component::IRC::Plugin::Logger'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Logger'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Logger'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/09_nickreclaim/0000755000175000017500000000000013153565114021016 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/09_nickreclaim/02_reclaim.t0000644000175000017500000000526413153565114023127 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::NickReclaim; use POE::Component::Server::IRC; use Test::More tests => 6; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, alias => 'bot1', ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, alias => 'bot2', ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(NickReclaim => POE::Component::IRC::Plugin::NickReclaim->new( poll => 1, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_433 irc_nick irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $heap->{port} = $port; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->session_alias() . ' (nick=' . $irc->nick_name() .') logged in'); return if $irc != $bot1; $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $_[HEAP]->{port}, }); } sub irc_433 { my $irc = $_[SENDER]->get_heap(); pass($irc->session_alias . ' (nick=' . $irc->nick_name() .') nick collision'); $bot1->yield('quit'); } sub irc_nick { my ($sender, $new_nick) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); is($new_nick, 'TestBot1', $irc->session_alias . ' reclaimed nick ' . $irc->nick_name()); $irc->yield('quit'); } sub irc_disconnected { my ($kernel, $sender, $heap) = @_[KERNEL, SENDER, HEAP]; my $irc = $sender->get_heap(); pass($irc->session_alias . ' (nick=' . $irc->nick_name() .') disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/09_nickreclaim/04_immediate_quit.t0000644000175000017500000000617713153565114024521 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::NickReclaim; use POE::Component::Server::IRC; use Test::More tests => 8; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, alias => 'bot1', ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, alias => 'bot2', ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(NickReclaim => POE::Component::IRC::Plugin::NickReclaim->new( poll => 65, # longer than the test timeout )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_433 irc_join irc_nick irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $heap->{port} = $port; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->session_alias() . ' (nick=' . $irc->nick_name() .') logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass($irc->session_alias().' (nick='.$irc->nick_name().") joined $where"); if ($irc == $bot1) { $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $_[HEAP]->{port}, }); } else { $bot1->yield('quit'); } } sub irc_433 { my $irc = $_[SENDER]->get_heap(); pass($irc->session_alias . ' (nick=' . $irc->nick_name() .') nick collision'); } sub irc_nick { my ($sender, $new_nick) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); return if $irc != $bot2 || $new_nick ne 'TestBot1'; pass($irc->session_alias().' (nick='.$irc->nick_name().') reclaimed nick'); $irc->yield('quit'); } sub irc_disconnected { my ($kernel, $sender, $heap) = @_[KERNEL, SENDER, HEAP]; my $irc = $sender->get_heap(); pass($irc->session_alias . ' (nick=' . $irc->nick_name() .') disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/09_nickreclaim/01_load.t0000644000175000017500000000217213153565114022424 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::NickReclaim; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::NickReclaim->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::NickReclaim'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::NickReclaim'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::NickReclaim'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/09_nickreclaim/03_immediate_change.t0000644000175000017500000000650413153565114024755 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::NickReclaim; use POE::Component::Server::IRC; use Test::More tests => 9; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, alias => 'bot1', ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, alias => 'bot2', ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot2->plugin_add(NickReclaim => POE::Component::IRC::Plugin::NickReclaim->new( poll => 65, # longer than the test timeout )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_433 irc_join irc_nick irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $heap->{port} = $port; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->session_alias() . ' (nick=' . $irc->nick_name() .') logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); pass($irc->session_alias().' (nick='.$irc->nick_name().") joined $where"); if ($irc == $bot1) { $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $_[HEAP]->{port}, }); } else { $bot1->yield(nick => 'TestBot2'); } } sub irc_433 { my $irc = $_[SENDER]->get_heap(); pass($irc->session_alias . ' (nick=' . $irc->nick_name() .') nick collision'); } sub irc_nick { my ($sender, $new_nick) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); if ($irc == $bot1 && $new_nick eq 'TestBot2') { pass($irc->session_alias().' (nick='.$irc->nick_name().') changed nicks'); } elsif ($irc == $bot2 && $new_nick eq 'TestBot1') { pass($irc->session_alias().' (nick='.$irc->nick_name().') reclaimed nick'); $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_disconnected { my ($kernel, $sender, $heap) = @_[KERNEL, SENDER, HEAP]; my $irc = $sender->get_heap(); pass($irc->session_alias . ' (nick=' . $irc->nick_name() .') disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/02_connector/0000755000175000017500000000000013153565114020520 5ustar bingosbingosPOE-Component-IRC-6.90/t/04_plugins/02_connector/01_load.t0000644000175000017500000000216013153565114022123 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More tests => 3; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::Connector; my $bot = POE::Component::IRC->spawn( plugin_debug => 1 ); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); my $plugin = POE::Component::IRC::Plugin::Connector->new(); isa_ok($plugin, 'POE::Component::IRC::Plugin::Connector'); if (!$bot->plugin_add('TestPlugin', $plugin )) { fail('plugin_add failed'); $bot->yield('shutdown'); } } sub irc_plugin_add { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Connector'); if (!$bot->plugin_del('TestPlugin') ) { fail('plugin_del failed'); $bot->yield('shutdown'); } } sub irc_plugin_del { my ($name, $plugin) = @_[ARG0, ARG1]; return if $name ne 'TestPlugin'; isa_ok($plugin, 'POE::Component::IRC::Plugin::Connector'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/04_plugins/02_connector/02_reconnect.t0000644000175000017500000000407713153565114023176 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::Connector; use POE::Component::Server::IRC; use Test::More tests => 4; my $bot = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); $bot->plugin_add(Connector => POE::Component::IRC::Plugin::Connector->new( timeout => 2, reconnect => 2, )); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); } sub irc_001 { my ($kernel, $sender, $heap) = @_[KERNEL, SENDER, HEAP]; my $irc = $sender->get_heap(); if (!$heap->{killed}) { pass('Logged in'); $ircd->daemon_server_kill($irc->nick_name()); $heap->{killed}++; return; } pass('Re-logged in'); $irc->plugin_del('Connector'); $irc->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; if ($heap->{killed} < 2) { $heap->{killed}++; pass('Killed from the IRC server'); return; } pass('irc_disconnected'); $kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/01_base/0000755000175000017500000000000013153565114015453 5ustar bingosbingosPOE-Component-IRC-6.90/t/01_base/01_compile.t0000644000175000017500000000207413153565114017573 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More; my @modules = qw( POE::Filter::IRC POE::Filter::IRC::Compat POE::Component::IRC POE::Component::IRC::State POE::Component::IRC::Qnet POE::Component::IRC::Qnet::State POE::Component::IRC::Constants POE::Component::IRC::Common POE::Component::IRC::Plugin POE::Component::IRC::Plugin::Whois POE::Component::IRC::Plugin::Proxy POE::Component::IRC::Plugin::PlugMan POE::Component::IRC::Plugin::NickServID POE::Component::IRC::Plugin::NickReclaim POE::Component::IRC::Plugin::Logger POE::Component::IRC::Plugin::ISupport POE::Component::IRC::Plugin::FollowTail POE::Component::IRC::Plugin::Console POE::Component::IRC::Plugin::Connector POE::Component::IRC::Plugin::CTCP POE::Component::IRC::Plugin::CycleEmpty POE::Component::IRC::Plugin::BotTraffic POE::Component::IRC::Plugin::BotAddressed POE::Component::IRC::Plugin::AutoJoin POE::Component::IRC::Plugin::BotCommand ); plan tests => scalar @modules; use_ok($_) for @modules; POE-Component-IRC-6.90/t/01_base/02_filters.t0000644000175000017500000001365213153565114017620 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use Test::More; use POE::Filter::Stackable; use POE::Filter::IRCD; use POE::Filter::IRC::Compat; use POE::Filter::IRC; my @tests = ( { line => ':joe!joe@example.com PART #foo :Goodbye', events => { part => [ 'joe!joe@example.com', '#foo', 'Goodbye', ], }, }, { line => ':joe!joe@example.com JOIN #foo', events => { join => [ 'joe!joe@example.com', '#foo', ], }, }, { line => ':magnet.shadowcat.co.uk 366 Flibble28185 #IRC.pm :End of /NAMES list.', events => { 366 => [ 'magnet.shadowcat.co.uk', '#IRC.pm :End of /NAMES list.', [ '#IRC.pm', 'End of /NAMES list.' ], ], }, }, { line => ':joe!joe@example.com PRIVMSG #foo :Fish go moo', events => { public => [ 'joe!joe@example.com', [ '#foo', ], 'Fish go moo', ], }, }, { line => ':joe!joe@example.com NOTICE #foo :Fish go moo', events => { notice => [ 'joe!joe@example.com', [ '#foo', ], 'Fish go moo', ], }, }, { line => ':joe!joe@example.com PRIVMSG foobar :Fish go moo', events => { msg => [ 'joe!joe@example.com', [ 'foobar', ], 'Fish go moo', ], }, }, { line => ':joe!joe@example.com NICK :moe', events => { nick => [ 'joe!joe@example.com', 'moe', ], }, }, { line => ':joe!joe@example.com QUIT :moe', events => { quit => [ 'joe!joe@example.com', 'moe', ], }, }, { line => 'PING :moe', events => { ping => [ 'moe' ], }, }, { line => ':joe!joe@example.com TOPIC #foo :Fish go moo', events => { topic => [ 'joe!joe@example.com', '#foo', 'Fish go moo', ], }, }, { line => ':joe!joe@example.com KICK #foo foobar :Goodbye', events => { kick => [ 'joe!joe@example.com', '#foo', 'foobar', 'Goodbye', ], }, }, { line => ':joe!joe@example.com INVITE foobar :#foo', events => { invite => [ 'joe!joe@example.com', '#foo', ], }, }, { line => ':joe!joe@example.com MODE #foo +m', events => { mode => [ 'joe!joe@example.com', '#foo', '+m', ], }, }, { line => ":joe!joe\@example.com PRIVMSG #foo :\001ACTION barfs on the floor.\001", events => { ctcp_action => [ 'joe!joe@example.com', [ '#foo', ], 'barfs on the floor.', ], }, }, { line => 'NOTICE * :Fish go moo', events => { snotice => [ 'Fish go moo', '*', ], }, }, { line => ':foo.bar.baz NOTICE * :Fish go moo', events => { snotice => [ 'Fish go moo', '*', 'foo.bar.baz', ], }, }, ); sub count { my (@items) = @_; my $count = 0; for my $item (@items) { $count++; next if ref $item ne 'ARRAY'; $count += count(@$item); } return $count; } my $sum; $sum += $_ for map { map { 4 + count( @$_ ) } values %{ $_->{events} } } @tests; plan tests => (2 + 2 * $sum); my $irc_filter = POE::Filter::IRC->new(); my $stack = POE::Filter::Stackable->new( Filters => [ POE::Filter::IRCD->new(), POE::Filter::IRC::Compat->new(), ]); for my $filter ( $stack, $irc_filter ) { isa_ok( $filter, 'POE::Filter::Stackable'); for my $test (@tests) { my @events = @{ $filter->get( [$test->{line}]) }; is(scalar @events, scalar keys %{ $test->{events} }, 'Event count'); for my $event (@events) { ok($test->{events}{$event->{name}}, "Got irc_$event->{name}"); is($event->{raw_line}, $test->{line}, "Raw Line $event->{name}"); my $test_args = $test->{events}{$event->{name}}; is(scalar @{ $event->{args} }, scalar @$test_args, "Args count $event->{name}"); for my $idx (0 .. $#$test_args) { if (ref $test_args->[$idx] eq 'ARRAY') { is( scalar @{ $event->{args}[$idx] }, scalar @{ $test_args->[$idx] }, "Sub args count $event->{name}", ); for my $iidx (0 .. $#{ $test_args->[$idx] }) { is( $event->{args}->[$idx][$iidx], $test_args->[$idx][$iidx], "Sub args Index $event->{name} $idx $iidx", ); } } else { is( $event->{args}[$idx], $test_args->[$idx], "Args Index $event->{name} $idx", ); } } } } } POE-Component-IRC-6.90/t/01_base/04_pocosi.t0000644000175000017500000000067713153565114017451 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::Server::IRC; use Test::More tests => 2; my $ircd = POE::Component::Server::IRC->spawn(auth => 0); isa_ok($ircd, 'POE::Component::Server::IRC'); POE::Session->create( package_states => [ main => [ qw(_start) ] ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; pass('Session started'); $ircd->yield('shutdown'); } POE-Component-IRC-6.90/t/inc/0000755000175000017500000000000013153565114015012 5ustar bingosbingosPOE-Component-IRC-6.90/t/inc/Crypt/0000755000175000017500000000000013153565114016113 5ustar bingosbingosPOE-Component-IRC-6.90/t/inc/Crypt/PasswdMD5.pm0000644000175000017500000000753313153565114020230 0ustar bingosbingos# # Crypt::PasswdMD5: Module to provide an interoperable crypt() # function for modern Unix O/S. This is based on the code for # # /usr/src/libcrypt/crypt.c # # on a FreeBSD 2.2.5-RELEASE system, which included the following # notice. # # ---------------------------------------------------------------------------- # "THE BEER-WARE LICENSE" (Revision 42): # wrote this file. As long as you retain this notice you # can do whatever you want with this stuff. If we meet some day, and you think # this stuff is worth it, you can buy me a beer in return. Poul-Henning Kamp # ---------------------------------------------------------------------------- # # $Id: PasswdMD5.pm,v 1.3 2004/02/17 11:21:38 lem Exp $ # ################ package Crypt::PasswdMD5; $VERSION='1.3'; require 5.000; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(unix_md5_crypt apache_md5_crypt); $Magic = q/$1$/; # Magic string $itoa64 = "./0123456789ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz"; use Digest::MD5; sub to64 { my ($v, $n) = @_; my $ret = ''; while (--$n >= 0) { $ret .= substr($itoa64, $v & 0x3f, 1); $v >>= 6; } $ret; } sub apache_md5_crypt { # change the Magic string to match the one used by Apache local $Magic = q/$apr1$/; unix_md5_crypt(@_); } sub unix_md5_crypt { my($pw, $salt) = @_; my $passwd; if ( defined $salt ) { $salt =~ s/^\Q$Magic//; # Take care of the magic string if # if present. $salt =~ s/^(.*)\$.*$/$1/; # Salt can have up to 8 chars... $salt = substr($salt, 0, 8); } else { $salt = ''; # in case no salt was proffered $salt .= substr($itoa64,int(rand(64)+1),1) while length($salt) < 8; } $ctx = new Digest::MD5; # Here we start the calculation $ctx->add($pw); # Original password... $ctx->add($Magic); # ...our magic string... $ctx->add($salt); # ...the salt... my ($final) = new Digest::MD5; $final->add($pw); $final->add($salt); $final->add($pw); $final = $final->digest; for ($pl = length($pw); $pl > 0; $pl -= 16) { $ctx->add(substr($final, 0, $pl > 16 ? 16 : $pl)); } # Now the 'weird' xform for ($i = length($pw); $i; $i >>= 1) { if ($i & 1) { $ctx->add(pack("C", 0)); } # This comes from the original version, # where a memset() is done to $final # before this loop. else { $ctx->add(substr($pw, 0, 1)); } } $final = $ctx->digest; # The following is supposed to make # things run slower. In perl, perhaps # it'll be *really* slow! for ($i = 0; $i < 1000; $i++) { $ctx1 = new Digest::MD5; if ($i & 1) { $ctx1->add($pw); } else { $ctx1->add(substr($final, 0, 16)); } if ($i % 3) { $ctx1->add($salt); } if ($i % 7) { $ctx1->add($pw); } if ($i & 1) { $ctx1->add(substr($final, 0, 16)); } else { $ctx1->add($pw); } $final = $ctx1->digest; } # Final xform $passwd = ''; $passwd .= to64(int(unpack("C", (substr($final, 0, 1))) << 16) | int(unpack("C", (substr($final, 6, 1))) << 8) | int(unpack("C", (substr($final, 12, 1)))), 4); $passwd .= to64(int(unpack("C", (substr($final, 1, 1))) << 16) | int(unpack("C", (substr($final, 7, 1))) << 8) | int(unpack("C", (substr($final, 13, 1)))), 4); $passwd .= to64(int(unpack("C", (substr($final, 2, 1))) << 16) | int(unpack("C", (substr($final, 8, 1))) << 8) | int(unpack("C", (substr($final, 14, 1)))), 4); $passwd .= to64(int(unpack("C", (substr($final, 3, 1))) << 16) | int(unpack("C", (substr($final, 9, 1))) << 8) | int(unpack("C", (substr($final, 15, 1)))), 4); $passwd .= to64(int(unpack("C", (substr($final, 4, 1))) << 16) | int(unpack("C", (substr($final, 10, 1))) << 8) | int(unpack("C", (substr($final, 5, 1)))), 4); $passwd .= to64(int(unpack("C", substr($final, 11, 1))), 2); $final = ''; $Magic . $salt . q/$/ . $passwd; } 1; __END__ POE-Component-IRC-6.90/t/inc/POE/0000755000175000017500000000000013153565114015435 5ustar bingosbingosPOE-Component-IRC-6.90/t/inc/POE/Component/0000755000175000017500000000000013153565114017377 5ustar bingosbingosPOE-Component-IRC-6.90/t/inc/POE/Component/Server/0000755000175000017500000000000013153565114020645 5ustar bingosbingosPOE-Component-IRC-6.90/t/inc/POE/Component/Server/IRC.pm0000644000175000017500000105562613153565114021637 0ustar bingosbingospackage POE::Component::Server::IRC; BEGIN { $POE::Component::Server::IRC::AUTHORITY = 'cpan:HINRIK'; } BEGIN { $POE::Component::Server::IRC::VERSION = '1.52'; } use strict; use warnings; use Carp qw(croak); use IRC::Utils qw(uc_irc parse_mode_line unparse_mode_line normalize_mask matches_mask gen_mode_change is_valid_nick_name is_valid_chan_name); use List::Util qw(sum); use POE; use POE::Component::Server::IRC::Common qw(chkpasswd); use POE::Component::Server::IRC::Plugin qw(:ALL); use POSIX 'strftime'; use base qw(POE::Component::Server::IRC::Backend); sub spawn { my ($package, %args) = @_; $args{lc $_} = delete $args{$_} for keys %args; my $config = delete $args{config}; my $debug = delete $args{debug}; my $self = $package->create( ($debug ? (raw_events => 1) : ()), %args, states => [ [qw(add_spoofed_nick del_spoofed_nick)], { map { +"daemon_cmd_$_" => '_spoofed_command' } qw(join part mode kick topic nick privmsg notice gline kline unkline sjoin locops wallops operwall) }, ], ); $self->configure($config ? $config : ()); $self->{debug} = $debug; $self->_state_create(); return $self; } sub IRCD_connection { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id, $peeraddr, $peerport, $sockaddr, $sockport, $needs_auth) = map { ${ $_ } } @_; if ($self->_connection_exists($conn_id)) { delete $self->{state}{conns}{$conn_id}; } $self->{state}{conns}{$conn_id}{registered} = 0; $self->{state}{conns}{$conn_id}{type} = 'u'; $self->{state}{conns}{$conn_id}{seen} = time(); $self->{state}{conns}{$conn_id}{socket} = [$peeraddr, $peerport, $sockaddr, $sockport]; $self->_state_conn_stats(); if (!$needs_auth) { $self->{state}{conns}{$conn_id}{auth} = { hostname => '', ident => '', }; $self->_client_register($conn_id); } return PCSI_EAT_CLIENT; } sub IRCD_connected { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id, $peeraddr, $peerport, $sockaddr, $sockport, $name) = map { ${ $_ } } @_; if ($self->_connection_exists($conn_id)) { delete $self->{state}{conns}{$conn_id}; } $self->{state}{conns}{$conn_id}{peer} = $name; $self->{state}{conns}{$conn_id}{registered} = 0; $self->{state}{conns}{$conn_id}{cntr} = 1; $self->{state}{conns}{$conn_id}{type} = 'u'; $self->{state}{conns}{$conn_id}{seen} = time(); $self->{state}{conns}{$conn_id}{socket} = [$peeraddr, $peerport, $sockaddr, $sockport]; $self->_state_conn_stats(); $self->_state_send_credentials($conn_id, $name); return PCSI_EAT_CLIENT; } sub IRCD_connection_flood { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id) = map { ${ $_ } } @_; $self->_terminate_conn_error($conn_id, 'Excess Flood'); return PCSI_EAT_CLIENT; } sub IRCD_connection_idle { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id, $interval) = map { ${ $_ } } @_; return PCSI_EAT_NONE if !$self->_connection_exists($conn_id); my $conn = $self->{state}{conns}{$conn_id}; if ($conn->{type} eq 'u') { $self->_terminate_conn_error($conn_id, 'Connection Timeout'); return PCSI_EAT_CLIENT; } if ($conn->{pinged}) { my $msg = 'Ping timeout: '.(time - $conn->{seen}).' seconds'; $self->_terminate_conn_error($conn_id, $msg); return PCSI_EAT_CLIENT; } $conn->{pinged} = 1; $self->send_output( { command => 'PING', params => [$self->server_name()], }, $conn_id, ); return PCSI_EAT_CLIENT; } sub IRCD_auth_done { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id, $ref) = map { ${ $_ } } @_; return PCSI_EAT_CLIENT if !$self->_connection_exists($conn_id); $self->{state}{conns}{$conn_id}{auth} = $ref; $self->_client_register($conn_id); return PCSI_EAT_CLIENT; } sub IRCD_disconnected { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id, $errstr) = map { ${ $_ } } @_; return PCSI_EAT_CLIENT if !$self->_connection_exists($conn_id); if ($self->_connection_is_peer($conn_id)) { my $peer = $self->{state}{conns}{$conn_id}{name}; $self->send_output( @{ $self->_daemon_peer_squit($conn_id, $peer, $errstr) } ); } elsif ($self->_connection_is_client($conn_id)) { $self->send_output( @{ $self->_daemon_cmd_quit( $self->_client_nickname($conn_id,$errstr ), $errstr, )} ); } delete $self->{state}{conns}{$conn_id}; return PCSI_EAT_CLIENT; } sub IRCD_compressed_conn { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id) = map { ${ $_ } } @_; $self->_state_send_burst($conn_id); return PCSI_EAT_CLIENT; } sub IRCD_raw_input { my ($self, $ircd) = splice @_, 0, 2; return PCSI_EAT_CLIENT if !$self->{debug}; my $conn_id = ${ $_[0] }; my $input = ${ $_[1] }; warn "<<< $conn_id: $input\n"; return PCSI_EAT_CLIENT; } sub IRCD_raw_output { my ($self, $ircd) = splice @_, 0, 2; return PCSI_EAT_CLIENT if !$self->{debug}; my $conn_id = ${ $_[0] }; my $output = ${ $_[1] }; warn ">>> $conn_id: $output\n"; return PCSI_EAT_CLIENT; } sub _default { my ($self, $ircd, $event) = splice @_, 0, 3; return PCSI_EAT_NONE if $event !~ /^IRCD_cmd_/; pop @_; my ($conn_id, $input) = map { $$_ } @_; return PCSI_EAT_CLIENT if !$self->_connection_exists($conn_id); $self->{state}{conns}{$conn_id}{seen} = time; if (!$self->_connection_registered($conn_id)) { $self->_cmd_from_unknown($conn_id, $input); } elsif ($self->_connection_is_peer($conn_id)) { $self->_cmd_from_peer($conn_id, $input); } elsif ($self->_connection_is_client($conn_id)) { delete $input->{prefix}; $self->_cmd_from_client($conn_id, $input); } return PCSI_EAT_CLIENT; } sub _auth_finished { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); return $self->{state}{conns}{$conn_id}{auth}; } sub _connection_exists { my $self = shift; my $conn_id = shift || return; return if !defined $self->{state}{conns}{$conn_id}; return 1; } sub _client_register { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); return if !$self->{state}{conns}{$conn_id}{nick}; return if !$self->{state}{conns}{$conn_id}{user}; my $auth = $self->_auth_finished($conn_id); return if !$auth; # pass required for link if (!$self->_state_auth_client_conn($conn_id)) { $self->_terminate_conn_error( $conn_id, 'You are not authorized to use this server', ); return; } if ($self->_state_user_matches_gline($conn_id)) { $self->_terminate_conn_error($conn_id, 'G-Lined'); return; } if ($self->_state_user_matches_kline($conn_id)) { $self->_terminate_conn_error($conn_id, 'K-Lined'); return; } if ($self->_state_user_matches_rkline($conn_id)) { $self->_terminate_conn_error($conn_id, 'K-Lined'); return; } # Add new nick $self->_state_register_client($conn_id); my $server = $self->server_name(); my $nick = $self->_client_nickname($conn_id); my $port = $self->{state}{conns}{$conn_id}{socket}[3]; my $version = $self->server_version(); my $network = $self->server_config('NETWORK'); my $server_is = "$server\[$server/$port]"; $self->_send_output_to_client( $conn_id, { prefix => $server, command => '001', params => [ $nick, "Welcome to the $network Internet Relay Chat network $nick" ], } ); $self->_send_output_to_client( $conn_id, { prefix => $server, command => '002', params => [ $nick, "Your host is $server_is, running version $version", ], }, ); $self->_send_output_to_client( $conn_id, { prefix => $server, command => '003', params => [$nick, $self->server_created()], }, ); $self->_send_output_to_client( $conn_id, { prefix => $server, command => '004', colonify => 0, params => [ $nick, $server, $version, 'Dilowz', 'biklmnopstveIh', 'bkloveIh', ], } ); for my $output (@{ $self->_daemon_cmd_isupport($nick) }) { $self->_send_output_to_client($conn_id, $output); } $self->{state}{conns}{$conn_id}{registered} = 1; $self->{state}{conns}{$conn_id}{type} = 'c'; $self->send_event( 'cmd_lusers', $conn_id, { command => 'LUSERS' }, ); $self->send_event( 'cmd_motd', $conn_id, { command => 'MOTD' }, ); $self->send_event( 'cmd_mode', $conn_id, { command => 'MODE', params => [$nick, '+i'], }, ); return 1; } sub _connection_registered { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); return $self->{state}{conns}{$conn_id}{registered}; } sub _connection_is_peer { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); return if !$self->{state}{conns}{$conn_id}{registered}; return 1 if $self->{state}{conns}{$conn_id}{type} eq 'p'; return; } sub _connection_is_client { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); return if !$self->{state}{conns}{$conn_id}{registered}; return 1 if $self->{state}{conns}{$conn_id}{type} eq 'c'; return; } sub _cmd_from_unknown { my ($self, $wheel_id, $input) = @_; my $cmd = uc $input->{command}; my $params = $input->{params} || [ ]; my $pcount = @$params; my $invalid = 0; SWITCH: { if ($cmd eq 'ERROR') { my $peer = $self->{state}{conns}{$wheel_id}{peer}; if (defined $peer) { $self->send_event_next( 'daemon_error', $wheel_id, $peer, $params->[0], ); } } if ($cmd eq 'QUIT') { $self->_terminate_conn_error($wheel_id, 'Client Quit'); last SWITCH; } # PASS or NICK cmd but no parameters. if ($cmd =~ /^(PASS|NICK|SERVER)$/ && !$pcount) { $self->_send_output_to_client($wheel_id, '461', $cmd); last SWITCH; } # PASS or NICK cmd with one parameter, connection from client if ($cmd eq 'PASS' && $pcount) { $self->{state}{conns}{$wheel_id}{lc $cmd} = $params->[0]; if ($params->[1] && $params->[1] =~ /TS$/) { $self->{state}{conns}{$wheel_id}{ts_server} = 1; $self->antiflood($wheel_id, 0); } last SWITCH; } # SERVER stuff. if ($cmd eq 'CAPAB' && $pcount) { $self->{state}{conns}{$wheel_id}{capab} = [split /\s+/, $params->[0]]; last SWITCH; } if ($cmd eq 'SERVER' && $pcount < 2) { $self->_send_output_to_client($wheel_id, '461', $cmd); last SWITCH; } if ($cmd eq 'SERVER') { my $conn = $self->{state}{conns}{$wheel_id}; $conn->{name} = $params->[0]; $conn->{hops} = $params->[1] || 1; $conn->{desc} = $params->[2] || ''; if (!$conn->{ts_server}) { $self->_terminate_conn_error($wheel_id, 'Non-TS server.'); last SWITCH; } if (!$self->_state_auth_peer_conn($wheel_id, $conn->{name}, $conn->{pass})) { $self->_terminate_conn_error( $wheel_id, 'Unauthorised server.', ); last SWITCH; } if ($self->state_peer_exists($conn->{name})) { $self->_terminate_conn_error($wheel_id, 'Server exists.'); last SWITCH; } $self->_state_register_peer($wheel_id); if ($conn->{zip} && grep { $_ eq 'ZIP' } @{ $conn->{capab} }) { $self->compressed_link($wheel_id, 1, $conn->{cntr}); } else { $self->_state_send_burst($wheel_id); } $self->send_event( "daemon_capab", $conn->{name}, @{ $conn->{capab} }, ); last SWITCH; } if ($cmd eq 'NICK' && $pcount) { if (!is_valid_nick_name($params->[0])) { $self->_send_output_to_client( $wheel_id, '432', $params->[0], ); last SWITCH; } if ($self->state_nick_exists($params->[0])) { $self->_send_output_to_client( $wheel_id, '433', $params->[0], ); last SWITCH; } my $nicklen = $self->server_config('NICKLEN'); if (length($params->[0]) > $nicklen) { $params->[0] = substr($params->[0], 0, $nicklen); } $self->{state}{conns}{$wheel_id}{lc $cmd} = $params->[0]; $self->{state}{pending}{uc_irc($params->[0])} = $wheel_id; $self->_client_register($wheel_id); last SWITCH; } if ($cmd eq 'USER' && $pcount < 4) { $self->_send_output_to_client($wheel_id, '461', $cmd); last SWITCH; } if ($cmd eq 'USER') { $self->{state}{conns}{$wheel_id}{user} = $params->[0]; $self->{state}{conns}{$wheel_id}{ircname} = $params->[3] || ''; $self->_client_register($wheel_id); last SWITCH; } last SWITCH if $self->{state}{conns}{$wheel_id}{cntr}; $invalid = 1; $self->_send_output_to_client($wheel_id, '451'); } return 1 if $invalid; $self->_state_cmd_stat($cmd, $input->{raw_line}); return 1; } sub _cmd_from_peer { my ($self, $conn_id, $input) = @_; my $cmd = $input->{command}; my $params = $input->{params}; my $prefix = $input->{prefix}; my $invalid = 0; SWITCH: { my $method = '_daemon_peer_' . lc $cmd; if ($cmd eq 'SQUIT' && !$prefix ){ $self->_daemon_peer_squit($conn_id, @$params); #$self->_send_output_to_client( # $conn_id, # $prefix, # (ref $_ eq 'ARRAY' ? @{ $_ } : $_) #) for $self->_daemon_cmd_squit($prefix, @$params); last SWITCH; } if ($cmd =~ /\d{3}/) { $self->send_output( $input, $self->_state_user_route($params->[0]) ); last SWITCH; } if ($cmd eq 'QUIT') { $self->send_output( @{ $self->_daemon_peer_quit( $prefix, @$params, $conn_id )} ); last SWITCH; } if ($cmd =~ /^(PRIVMSG|NOTICE)$/) { $self->_send_output_to_client( $conn_id, $prefix, (ref $_ eq 'ARRAY' ? @{ $_ } : $_) ) for $self->_daemon_peer_message( $conn_id, $prefix, $cmd, @$params ); last SWITCH; } if ($cmd =~ /^(WHOIS|VERSION|TIME|NAMES|LINKS|ADMIN|INFO|MOTD|SQUIT)$/i ) { my $client_method = '_daemon_cmd_' . lc $cmd; $self->_send_output_to_client( $conn_id, $prefix, (ref $_ eq 'ARRAY' ? @{ $_ } : $_ ) ) for $self->$client_method($prefix, @$params); last SWITCH; } if ($cmd =~ /^(PING|PONG)$/i && $self->can($method)) { $self->$method($conn_id, @{ $params }); last SWITCH; } if ($cmd =~ /^SVINFO$/i && $self->can($method)) { $self->$method($conn_id, @$params); my $conn = $self->{state}{conns}{$conn_id}; $self->send_event( "daemon_svinfo", $conn->{name}, @$params, ); last SWITCH; } if ($cmd eq 'MODE' && $self->state_nick_exists($params->[0])) { $method = '_daemon_peer_umode'; } if ($self->can($method)) { $self->$method($conn_id, $prefix, @$params); last SWITCH; } $invalid = 1; } return 1 if $invalid; $self->_state_cmd_stat($cmd, $input->{raw_line}, 1); return 1; } sub _cmd_from_client { my ($self, $wheel_id, $input) = @_; my $cmd = uc $input->{command}; my $params = $input->{params} || [ ]; my $pcount = @$params; my $server = $self->server_name(); my $nick = $self->_client_nickname($wheel_id); my $invalid = 0; SWITCH: { my $method = '_daemon_cmd_' . lc $cmd; if ($cmd eq 'QUIT') { $self->_terminate_conn_error( $wheel_id, ($pcount ? qq{"$params->[0]"} : 'Client Quit'), ); last SWITCH; } if ($cmd =~ /^(USERHOST|MODE)$/ && !$pcount) { $self->_send_output_to_client($wheel_id, '461', $cmd); last SWITCH; } if ($cmd =~ /^(USERHOST)$/) { $self->_send_output_to_client($wheel_id, $_) for $self->$method( $nick, ($pcount <= 5 ? @$params : @{ $params }[0..5] ) ); last SWITCH; } if ($cmd =~ /^(PRIVMSG|NOTICE)$/) { $self->{state}{conns}{$wheel_id}{idle_time} = time; $self->_send_output_to_client( $wheel_id, (ref $_ eq 'ARRAY' ? @{ $_ } : $_), ) for $self->_daemon_cmd_message($nick, $cmd, @$params); last SWITCH; } if ($cmd eq 'MODE' && $self->state_nick_exists($params->[0])) { if (uc_irc($nick) ne uc_irc($params->[0])) { $self->_send_output_to_client($wheel_id => '502'); last SWITCH; } my $modestring = join('', @{ $params }[1..$#{ $params }]); $modestring =~ s/\s+//g; $modestring =~ s/[^a-zA-Z+-]+//g; $modestring =~ s/[^DGglwiozl+-]+//g; $modestring = unparse_mode_line($modestring); $self->_send_output_to_client($wheel_id, $_) for $self->_daemon_cmd_umode($nick, $modestring); last SWITCH; } if ($self->can($method)) { $self->_send_output_to_client( $wheel_id, (ref $_ eq 'ARRAY' ? @{ $_ } : $_), ) for $self->$method($nick, @$params); last SWITCH; } $invalid = 1; $self->_send_output_to_client($wheel_id, '421', $cmd); } return 1 if $invalid; $self->_state_cmd_stat($cmd, $input->{raw_line}); return 1; } sub _daemon_cmd_message { my $self = shift; my $nick = shift || return; my $type = shift || return; my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$count) { push @$ref, ['461', $type]; last SWITCH; } if ($count < 2 || !$args->[1]) { push @$ref, ['412']; last SWITCH; } my $targets = 0; my $max_targets = $self->server_config('MAXTARGETS'); my $full = $self->state_user_full($nick); my $targs = $self->_state_parse_msg_targets($args->[0]); LOOP: for my $target (keys %$targs) { my $targ_type = shift @{ $targs->{$target} }; if ($targ_type =~ /(server|host)mask/ && !$self->state_user_is_operator($nick)) { push @$ref, ['481']; next LOOP; } if ($targ_type =~ /(server|host)mask/ && $targs->{$target}[0] !~ /\./) { push @$ref, ['413', $target]; next LOOP; } if ($targ_type =~ /(server|host)mask/ && $targs->{$target}[0] =~ /\x2E.*[\x2A\x3F]+.*$/) { push @$ref, ['414', $target]; next LOOP; } if ($targ_type eq 'channel_ext' && !$self->state_chan_exists($targs->{$target}[1])) { push @$ref, ['401', $targs->{$target}[1]]; next LOOP; } if ($targ_type eq 'channel' && !$self->state_chan_exists($target)) { push @$ref, ['401', $target]; next LOOP; } if ($targ_type eq 'nick' && !$self->state_nick_exists($target)) { push @$ref, ['401', $target]; next LOOP; } if ($targ_type eq 'nick_ext' && !$self->state_peer_exists($targs->{$target}[1])) { push @$ref, ['402', $targs->{$target}[1]]; next LOOP; } $targets++; if ($targets > $max_targets) { push @$ref, ['407', $target]; last SWITCH; } # $$whatever if ($targ_type eq 'servermask') { my $us = 0; my %targets; my $ucserver = uc $self->server_name(); for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask( $targs->{$target}[0], $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{ $self->_state_peer_route($peer) }++; } } } $self->send_output( { prefix => $nick, command => $type, params => [$target, $args->[1]], }, keys %targets, ); if ($us) { my $local = $self->{state}{peers}{uc $self->server_name()}{users}; my @local; my $spoofed = 0; for my $luser (values %$local) { if ($luser->{route_id} eq 'spoofed') { $spoofed = 1; } else { push @local, $luser->{route_id}; } } $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, @local, ); $self->send_event( "daemon_" . lc $type, $full, $target, $args->[1], ) if $spoofed; } next LOOP; } # $#whatever if ($targ_type eq 'hostmask') { my $spoofed = 0; my %targets; my @local; HOST: for my $luser (values %{ $self->{state}{users} }) { if (!matches_mask($targs->{$target}[0], $luser->{auth}{hostname})) {; next HOST; } if ($luser->{route_id} eq 'spoofed') { $spoofed = 1; } elsif ($luser->{type} eq 'r') { $targets{ $luser->{route_id} }++; } else { push @local, $luser->{route_id}; } } $self->send_output( { prefix => $nick, command => $type, params => [$target, $args->[1]], }, keys %targets, ); $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, @local, ); $self->send_event( "daemon_" . lc $type, $full, $target, $args->[1], ) if $spoofed; next LOOP; } if ($targ_type eq 'nick_ext') { $targs->{$target}[1] = $self->_state_peer_name( $targs->{$target}[1]); if ($targs->{$target}[2] && !$self->state_user_is_operator($nick)) { push @$ref, ['481']; next LOOP; } if ($targs->{$target}[1] ne $self->server_name()) { $self->send_output( { prefix => $nick, command => $type, params => [$target, $args->[1]], }, $self->_state_peer_route($targs->{$target}[1]), ); next LOOP; } if (uc $targs->{$target}[0] eq 'OPERS') { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; next LOOP; } $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, keys %{ $self->{state}{localops} }, ); next LOOP; } my @local = $self->_state_find_user_host( $targs->{$target}[0], $targs->{$target}[2], ); if (@local == 1) { my $ref = shift @local; if ($ref->[0] eq 'spoofed') { $self->send_event( "daemon_" . lc $type, $full, $ref->[1], $args->[1], ); } else { $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, $ref->[0], ); } } else { push @$ref, ['407', $target]; next LOOP; } } my ($channel, $status_msg); if ($targ_type eq 'channel') { $channel = $self->_state_chan_name($target); } if ($targ_type eq 'channel_ext') { $channel = $self->_state_chan_name($targs->{target}[1]); $status_msg = $targs->{target}[0]; } if ($channel && $status_msg && !$self->state_user_chan_mode($nick, $channel)) { push @$ref, ['482', $target]; next LOOP; } if ($channel && $self->state_chan_mode_set($channel, 'n') && !$self->state_is_chan_member($nick, $channel)) { push @$ref, ['404', $channel]; next LOOP; } if ($channel && $self->state_chan_mode_set($channel, 'm') && !$self->state_user_chan_mode($nick, $channel)) { push @$ref, ['404', $channel]; next LOOP; } if ($channel && $self->_state_user_banned($nick, $channel) && !$self->state_user_chan_mode($nick, $channel)) { push @$ref, ['404', $channel]; next LOOP; } if ($channel) { my $common = { }; my $msg = { command => $type, params => [ ($status_msg ? $target : $channel), $args->[1] ], }; for my $member ($self->state_chan_list($channel, $status_msg)) { next if $self->_state_user_is_deaf($member); $common->{ $self->_state_user_route($member) }++; } delete $common->{ $self->_state_user_route($nick) }; for my $route_id (keys %$common) { $msg->{prefix} = $nick; if ($self->_connection_is_client($route_id)) { $msg->{prefix} = $full; } if ($route_id ne 'spoofed') { $self->send_output($msg, $route_id); } else { my $tmsg = $type eq 'PRIVMSG' ? 'public' : 'notice'; $self->send_event( "daemon_$tmsg", $full, $channel, $args->[1], ); } } next LOOP; } my $server = $self->server_name(); if ($self->state_nick_exists($target)) { $target = $self->state_user_nick($target); if (my $away = $self->_state_user_away_msg($target)) { push @$ref, { prefix => $server, command => '301', params => [$nick, $target, $away], }; } my $targ_umode = $self->state_user_umode($target); # Target user has CALLERID on if ($targ_umode && $targ_umode =~ /[Gg]/) { my $targ_rec = $self->{state}{users}{uc_irc($target)}; if (($targ_umode =~ /G/ && (!$self->state_users_share_chan($target, $nick) || !$targ_rec->{accepts}{uc_irc($nick)})) || ($targ_umode =~ /g/ && !$targ_rec->{accepts}{uc_irc($nick)})) { push @$ref, { prefix => $server, command => '716', params => [ $nick, $target, 'is in +g mode (server side ignore)', ], }; if (!$targ_rec->{last_caller} || time() - $targ_rec->{last_caller} >= 60) { my ($n, $uh) = split /!/, $self->state_user_full($nick); $self->send_output( { prefix => $server, command => '718', params => [ $target, "$n\[$uh\]", 'is messaging you, and you are umode +g.', ] }, $targ_rec->{route_id}, ) if $targ_rec->{route_id} ne 'spoofed'; push @$ref, { prefix => $server, command => '717', params => [ $nick, $target, 'has been informed that you messaged them.', ], }; } $targ_rec->{last_caller} = time(); next LOOP; } } my $msg = { prefix => $nick, command => $type, params => [$target, $args->[1]], }; my $route_id = $self->_state_user_route($target); if ($route_id eq 'spoofed') { $msg->{prefix} = $full; $self->send_event( "daemon_" . lc $type, $full, $target, $args->[1], ); } else { if ($self->_connection_is_client($route_id)) { $msg->{prefix} = $full; } $self->send_output($msg, $route_id); } next LOOP; } } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_accept { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count || !$args->[0] || $args->[0] eq '*') { my $record = $self->{state}{users}{uc_irc($nick)}; my @list; for my $accept (keys %{ $record->{accepts} }) { if (!$self->state_nick_exists($accept)) { delete $record->{accepts}{$accept}; next; } push @list, $self->state_user_nick($accept); } push @$ref, { prefix => $server, command => '281', params => [$nick, join( ' ', @list)], } if @list; push @$ref, { prefix => $server, command => '282', params => [$nick, 'End of /ACCEPT list'], }; last SWITCH; } } my $record = $self->{state}{users}{uc_irc($nick)}; for (keys %{ $record->{accepts} }) { delete $record->{accepts}{$_} if !$self->state_nick_exists($_); } OUTER: for my $target (split /,/, $args->[0]) { if (my ($foo) = $target =~ /^\-(.+)$/) { my $dfoo = delete $record->{accepts}{uc_irc($foo)}; if (!$dfoo) { push @$ref, { prefix => $server, command => '458', params => [$nick, $foo, "doesn\'t exist"], }; } delete $self->{state}{accepts}{uc_irc($foo)}{uc_irc($nick)}; if (!keys %{ $self->{state}{accepts}{uc_irc($foo)} }) { delete $self->{state}{accepts}{uc_irc($foo)}; } next OUTER; } if (!$self->state_nick_exists($target)) { push @$ref, ['401', $target]; next OUTER; } # 457 ERR_ACCEPTEXIST if ($record->{accepts}{uc_irc($target)}) { push @$ref, { prefix => $server, command => '457', params => [ $nick, $self->state_user_nick($target), 'already exists', ], }; next OUTER; } if ($record->{umode} && $record->{umode} =~ /G/ && $self->_state_users_share_chan($nick, $target) ) { push @$ref, { prefix => $server, command => '457', params => [ $nick, $self->state_user_nick($target), 'already exists', ], }; next OUTER; } $self->{state}{accepts}{uc_irc($target)}{uc_irc($nick)} = $record->{accepts}{uc_irc($target)} = time; my @list = map { $self->state_user_nick($_) } keys %{ $record->{accepts} }; push @$ref, { prefix => $server, command => '281', params => [ $nick, join(' ', @list), ], } if @list; push @$ref, { prefix => $server, command => '282', params => [$nick, 'End of /ACCEPT list'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_quit { my $self = shift; my $nick = shift || return; my $qmsg = shift || 'Client Quit'; my $ref = [ ]; my $full = $self->state_user_full($nick); $nick = uc_irc($nick); my $record = delete $self->{state}{peers}{uc $self->server_name()}{users}{$nick}; $self->send_output( { prefix => $record->{nick}, command => 'QUIT', params => [$qmsg], }, $self->_state_connected_peers(), ) if !$record->{killed}; push @$ref, { prefix => $full, command => 'QUIT', params => [$qmsg], }; $self->send_event("daemon_quit", $full, $qmsg); # Remove for peoples accept lists for my $user (keys %{ $record->{accepts} }) { delete $self->{state}{users}{$user}{accepts}{uc_irc($nick)}; } # Okay, all 'local' users who share a common channel with user. my $common = { }; for my $uchan (keys %{ $record->{chans} }) { delete $self->{state}{chans}{$uchan}{users}{$nick}; for my $user ($self->state_chan_list($uchan)) { next if !$self->_state_is_local_user($user); $common->{$user} = $self->_state_user_route($user); } if (!keys %{ $self->{state}{chans}{$uchan}{users} }) { delete $self->{state}{chans}{$uchan}; } } push @$ref, $common->{$_} for keys %$common; $self->{state}{stats}{ops_online}-- if $record->{umode} =~ /o/; $self->{state}{stats}{invisible}-- if $record->{umode} =~ /i/; delete $self->{state}{users}{$nick} if !$record->{nick_collision}; delete $self->{state}{localops}{$record->{route_id}}; return @$ref if wantarray; return $ref; } sub _daemon_cmd_ping { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $args = [ @_ ]; my $count = @$args; my $ref = [ ]; SWITCH: { if (!$count) { push @$ref, [ '409' ]; last SWITCH; } if ($count >= 2 && !$self->state_peer_exists($args->[1])) { push @$ref, ['402', $args->[1]]; last SWITCH; } if ($count >= 2 && (uc $args->[1] ne uc $server)) { my $target = $self->_state_peer_name($args->[1]); $self->send_output( { command => 'PING', params => [$nick, $target], }, $self->_state_peer_route($args->[1]), ); last SWITCH; } push @$ref, { prefix => $server, command => 'PONG', params => [$server, $args->[0]], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_pong { my $self = shift; my $nick = shift || return; my $server = uc $self->server_name(); my $args = [ @_ ]; my $count = @$args; my $ref = [ ]; SWITCH: { if (!$count) { push @$ref, ['409']; last SWITCH; } if ($count >= 2 && !$self->state_peer_exists($args->[1])) { push @$ref, ['402', $args->[1]]; last SWITCH; } if ($count >= 2 && uc $args->[1] ne uc $server) { my $target = $self->_state_peer_name($args->[1]); $self->send_output( { command => 'PONG', params => [$nick, $target], }, $self->_state_peer_route($args->[1]), ); last SWITCH; } delete $self->{state}{users}{uc_irc($nick)}{pinged}; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_pass { my $self = shift; my $nick = shift || return; my $server = uc $self->server_name(); my $ref = [['462']]; return @$ref if wantarray; return $ref; } sub _daemon_cmd_user { my $self = shift; my $nick = shift || return; my $server = uc $self->server_name(); my $ref = [['462']]; return @$ref if wantarray; return $ref; } sub _daemon_cmd_oper { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { last SWITCH if $self->state_user_is_operator($nick); if (!$count || $count < 2) { push @$ref, ['461', 'OPER']; last SWITCH; } my $result = $self->_state_o_line($nick, @$args); if (!$result || $result <= 0) { push @$ref, ['491']; last SWITCH; } $self->{stats}{ops}++; my $record = $self->{state}{users}{uc_irc($nick)}; $record->{umode} .= 'o'; $self->{state}{stats}{ops_online}++; push @$ref, { prefix => $server, command => '381', params => [$nick, 'You are now an IRC operator'], }; my $reply = { prefix => $nick, command => 'MODE', params => [$nick, '+o'], }; $self->send_output( $reply, $self->_state_connected_peers(), ); $self->send_event( "daemon_umode", $self->state_user_full($nick), '+o', ); my $route_id = $self->_state_user_route($nick); $self->{state}{localops}{$route_id} = time; $self->antiflood($route_id, 0); push @$ref, $reply; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_die { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } $self->send_event("daemon_die", $nick); $self->shutdown(); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_rehash { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } $self->send_event("daemon_rehash", $nick); push @$ref, { prefix => $server, command => '383', params => [$nick, 'ircd.conf', 'Rehashing'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_locops { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count) { push @$ref, ['461', 'LOCOPS']; last SWITCH; } my $full = $self->state_user_full($nick); $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['LOCOPS - ' . $args->[0]], }, keys %{ $self->{state}{locops} }, ); $self->send_event("daemon_locops", $full, $args->[0]); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_wallops { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count) { push @$ref, ['461', 'WALLOPS']; last SWITCH; } my $full = $self->state_user_full($nick); $self->send_output( { prefix => $nick, command => 'WALLOPS', params => [$args->[0]], }, $self->_state_connected_peers(), ); $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['OPERWALL - ' . $args->[0]], }, keys %{ $self->{state}{operwall} }, ); $self->send_event("daemon_operwall", $full, $args->[0]); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_operwall { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count) { push @$ref, ['461', 'OPERWALL']; last SWITCH; } my $full = $self->state_user_full($nick); $self->send_output( { prefix => $nick, command => 'WALLOPS', params => [$args->[0]], }, $self->_state_connected_peers(), ); $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['OPERWALL - ' . $args->[0]], }, keys %{ $self->{state}{operwall} }, ); $self->send_event("daemon_operwall", $full, $args->[0]); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_connect { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count) { push @$ref, ['461', 'CONNECT']; last SWITCH; } if ($count >= 3 && !$self->state_peer_exists($args->[2])) { push @$ref, ['402', $args->[2]]; last SWITCH; } if ($count >= 3 && uc $server ne uc $args->[2]) { $args->[2] = $self->_state_peer_name($args->[2]); $self->send_output( { prefix => $nick, command => 'CONNECT', params => $args, }, $self->_state_peer_route($args->[2]), ); last SWITCH; } if (!$self->{config}{peers}{uc $args->[0]} || $self->{config}{peers}{uc $args->[0]}{type} ne 'r') { push @$ref, { command => 'NOTICE', params => [ $nick, "Connect: Host $args->[0] is not listed in ircd.conf", ], }; last SWITCH; } if (my $peer_name = $self->_state_peer_name($args->[0])) { push @$ref, { command => 'NOTICE', params => [ $nick, "Connect: Server $args->[0] already exists from $peer_name.", ], }; last SWITCH; } my $connector = $self->{config}{peers}{uc $args->[0]}; my $name = $connector->{name}; my $rport = $args->[1] || $connector->{rport}; my $raddr = $connector->{raddress}; $self->add_connector( remoteaddress => $raddr, remoteport => $rport, name => $name, ); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_squit { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count) { push @$ref, ['461', 'SQUIT']; last SWITCH; } if (!$self->state_peer_exists($args->[0]) || uc $server eq uc $args->[0]) { push @$ref, ['402', $args->[0]]; last SWITCH; } my $peer = uc $args->[0]; my $reason = $args->[1] || 'No Reason'; $args->[0] = $self->_state_peer_name($peer); $args->[1] = $reason; if ( !grep { $_ eq $peer } keys %{ $self->{state}{peers}{uc $server}{peers} }) { $self->send_output( { prefix => $nick, command => 'SQUIT', params => $args, }, $self->_state_peer_route($args->[0]), ); last SWITCH; } my $conn_id = $self->_state_peer_route($peer); $self->disconnect($conn_id, $reason); $self->send_output( { command => 'ERROR', params => [ join ' ', 'Closing Link:', $self->_client_ip($conn_id), $args->[0], "($nick)" ], }, $conn_id, ); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_rkline { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; # RKLINE [time] [ON ] :[reason] SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count || $count < 1) { push @$ref, ['461', 'RKLINE']; last SWITCH; } my $duration = 0; if ($args->[0] =~ /^\d+$/) { $duration = shift @$args; $duration = 14400 if $duration > 14400; } my $mask = shift @$args; if (!$mask) { push @$ref, ['461', 'RKLINE']; last SWITCH; } my ($user, $host) = split /\@/, $mask; if (!$user || !$host) { last SWITCH; } my $full = $self->state_user_full($nick); my $us = 0; my $ucserver = uc $server; if ($args->[0] && uc $args->[0] eq 'ON' && @$args < 2) { push @$ref, ['461', 'RKLINE']; last SWITCH; } my ($target, $reason); if ($args->[0] && uc $args->[0] eq 'ON') { $target = shift @$args; $reason = shift @{ $args } || 'No Reason'; my %targets; for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask($target, $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{ $self->_state_peer_route($peer) }++; } } } $self->send_output( { prefix => $nick, command => 'RKLINE', params => [$target, $duration, $user, $host, $reason], colonify => 0, }, grep { $self->_state_peer_capab($_, 'KLN') } keys %targets, ); } else { $us = 1; } if ($us) { $target = $server if !$target; if (!$reason) { $reason = pop @$args || 'No Reason'; } $self->send_event( "daemon_rkline", $full, $target, $duration, $user, $host, $reason, ); push @{ $self->{state}{rklines} }, { setby => $full, setat => time(), target => $target, duration => $duration, user => $user, host => $host, reason => $reason, }; for ($self->_state_local_users_match_rkline($user, $host)) { $self->_terminate_conn_error($_, 'K-Lined'); } } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_kline { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; # KLINE [time] [ ON ] :[reason] SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count || $count < 1) { push @$ref, ['461', 'KLINE']; last SWITCH; } my $duration = 0; if ($args->[0] =~ /^\d+$/) { $duration = shift @$args; $duration = 14400 if $duration > 14400; } my $mask = shift @$args; if (!$mask) { push @$ref, ['461', 'KLINE']; last SWITCH; } my ($user, $host); if ($mask !~ /\@/) { if (my $rogue = $self->_state_user_full($mask)) { ($user, $host) = (split /[!\@]/, $rogue )[1..2]; } else { push @$ref, ['401', $mask]; last SWITCH; } } else { ($user, $host) = split /\@/, $mask; } my $full = $self->state_user_full($nick); my $us = 0; my $ucserver = uc $server; if ($args->[0] && uc $args->[0] eq 'ON' && scalar @$args < 2) { push @$ref, ['461', 'KLINE']; last SWITCH; } my ($target, $reason); if ($args->[0] && uc $args->[0] eq 'ON') { $target = shift @$args; $reason = shift @$args || 'No Reason'; my %targets; for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask($target, $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{ $self->_state_peer_route($peer) }++; } } } $self->send_output( { prefix => $nick, command => 'KLINE', params => [ $target, $duration, $user, $host, $reason, ], colonify => 0, }, grep { $self->_state_peer_capab($_, 'KLN') } keys %targets, ); } else { $us = 1; } if ($us) { $target = $server if !$target; if (!$reason) { $reason = pop @$args || 'No Reason'; } $self->send_event( "daemon_kline", $full, $target, $duration, $user, $host, $reason, ); push @{ $self->{state}{klines} }, { setby => $full, setat => time, target => $target, duration => $duration, user => $user, host => $host, reason => $reason, }; for ($self->_state_local_users_match_gline($user, $host)) { $self->_terminate_conn_error($_, 'K-Lined'); } } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_unkline { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; # UNKLINE [ ON ] SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count || $count < 1) { push @$ref, ['461', 'UNKLINE']; last SWITCH; } my ($user, $host); if ($args->[0] !~ /\@/) { if (my $rogue = $self->state_user_full($args->[0])) { ($user, $host) = (split /[!\@]/, $rogue)[1..2] } else { push @$ref, ['401', $args->[0]]; last SWITCH; } } else { ($user, $host) = split /\@/, $args->[0]; } my $full = $self->state_user_full($nick); my $us = 0; my $ucserver = uc $server; if ($count > 1 && uc $args->[2] eq 'ON' && $count < 3) { push @$ref, ['461', 'UNKLINE']; last SWITCH; } if ($count > 1 && $args->[2] && uc $args->[2] eq 'ON') { my $target = $args->[2]; my %targets; for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask($target, $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{ $self->_state_peer_route( $peer ) }++; } } } $self->send_output( { prefix => $nick, command => 'UNKLINE', params => [$target, $user, $host], colonify => 0, }, grep { $self->_state_peer_capab($_, 'UNKLN') } keys %targets, ); } else { $us = 1; } if ($us) { my $target = $args->[3] || $server; $self->send_event( "daemon_unkline", $full, $target, $user, $host, ); my $i = 0; for (@{ $self->{state}{klines} }) { if ($_->{user} eq $user && $_->{host} eq $host) { splice @{ $self->{state}{klines} }, $i, 1; last; } ++$i; } } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_gline { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; # :klanker GLINE * meep.com :Fuckers SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count || $count < 2) { push @$ref, ['461', 'GLINE']; last SWITCH; } if ($args->[0] !~ /\@/ && !$self->state_nick_exists($args->[0])) { push @$ref, ['401', $args->[0]]; last SWITCH; } my ($user_part, $host_part); if ($args->[0] =~ /\@/) { ($user_part, $host_part) = (split /[!@]/, $self->state_user_full($args->[0]))[1..2]; } else { ($user_part, $host_part) = split /\@/, $args->[0]; } my $time = time; my $reason = join ' ', $args->[1], strftime('(%c)', localtime $time); my $full = $self->state_user_full($nick); push @{ $self->{state}{glines} }, { setby => $full, setat => time, user => $user_part, host => $host_part, reason => $reason, }; $self->send_output( { prefix => $nick, command => 'GLINE', params => [$user_part, $host_part, $reason], colonify => 0, }, grep { $self->_state_peer_capab($_, 'GLN') } $self->_state_connected_peers() ); $self->send_event( "daemon_gline", $full, $user_part, $host_part, $reason, ); for ($self->_state_local_users_match_gline($user_part, $host_part)) { $self->_terminate_conn_error($_, 'G-Lined'); } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_kill { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; last SWITCH; } if (!$count) { push @$ref, ['461', 'KILL']; last SWITCH; } if ($self->state_peer_exists($args->[0])) { push @$ref, ['483']; last SWITCH; } if (!$self->state_nick_exists($args->[0])) { push @$ref, ['401', $args->[0]]; last SWITCH; } my $target = $self->state_user_nick($args->[0]); my $comment = $args->[1] || ''; if ($self->_state_is_local_user($target)) { my $route_id = $self->_state_user_route($target); $self->send_output( { prefix => $nick, command => 'KILL', params => [ $target, join('!', $server, $nick )." ($comment)", ] }, $self->_state_connected_peers(), ); $self->send_output( { prefix => $self->state_user_full($nick), command => 'KILL', params => [$target, $comment], }, $route_id, ); if ($route_id eq 'spoofed') { $self->call('del_spoofed_nick', $target, "Killed ($comment)"); } else { $self->{state}{conns}{$route_id}{killed} = 1; $self->_terminate_conn_error($route_id, "Killed ($comment)"); } } else { $self->{state}{users}{uc_irc($target)}{killed} = 1; $self->send_output( { prefix => $nick, command => 'KILL', params => [ $target, join('!', $server, $nick )." ($comment)", ], }, $self->_state_connected_peers(), ); $self->send_output( @{ $self->_daemon_peer_quit( $target, "Killed ($nick ($comment))" )} ); } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_nick { my $self = shift; my $nick = shift || return; my $new = shift; my $server = uc $self->server_name(); my $ref = [ ]; SWITCH: { if (!$new) { push @$ref, ['431']; last SWITCH; } my $nicklen = $self->server_config('NICKLEN'); $new = substr($new, 0, $nicklen) if length($new) > $nicklen; if ($nick eq $new) { last SWITCH; } if (!is_valid_nick_name($new)) { push @$ref, ['432', $new]; last SWITCH; } my $unick = uc_irc($nick); my $unew = uc_irc($new); if ($self->state_nick_exists($new) && $unick ne $unew) { push @$ref, ['433', $new]; last SWITCH; } my $full = $self->state_user_full($nick); my $record = $self->{state}{users}{$unick}; my $common = { $nick => $record->{route_id} }; for my $chan (keys %{ $record->{chans} }) { for my $user ($self->state_chan_list($chan)) { next if !$self->_state_is_local_user($user); $common->{$user} = $self->_state_user_route($user); } } if ($unick eq $unew) { $record->{nick} = $new; $record->{ts} = time; } else { $record->{nick} = $new; $record->{ts} = time; # Remove from peoples accept lists for (keys %{ $record->{accepts} }) { delete $self->{state}{users}{$_}{accepts}{$unick}; } delete $record->{accepts}; delete $self->{state}{users}{$unick}; $self->{state}{users}{$unew} = $record; delete $self->{state}{peers}{$server}{users}{$unick}; $self->{state}{peers}{$server}{users}{$unew} = $record; for my $chan (keys %{ $record->{chans} }) { $self->{state}{chans}{$chan}{users}{$unew} = delete $self->{state}{chans}{$chan}{users}{$unick}; } } my @peers = $self->_state_connected_peers(); $self->send_output( { prefix => $nick, command => 'NICK', params => [$new, $record->{ts}], }, @peers, ); $self->send_output( { prefix => $full, command => 'NICK', params => [$new], }, map{ $common->{$_} } keys %$common, ); $self->send_event("daemon_nick", $full, $new); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_away { my $self = shift; my $nick = shift || return; my $msg = shift; my $server = $self->server_name(); my $ref = [ ]; SWITCH: { my $record = $self->{state}{users}{uc_irc($nick)}; if (!$msg) { delete $record->{away}; $self->send_output( { prefix => $nick, command => 'AWAY', colonify => 0, }, $self->_state_connected_peers(), ); push @$ref, { prefix => $server, command => '305', params => ['You are no longer marked as being away'], }; last SWITCH; } $record->{away} = $msg; $self->send_output( { prefix => $nick, command => 'AWAY', params => [$msg], colonify => 0, }, $self->_state_connected_peers(), ); push @$ref, { prefix => $server, command => '306', params => ['You have been marked as being away'], }; } return @$ref if wantarray; return $ref; } # Pseudo cmd for ISupport 005 numerics sub _daemon_cmd_isupport { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; push @$ref, { prefix => $server, command => '005', params => [ $nick, join(' ', map { (defined $self->{config}{isupport}{$_} ? join '=', $_, $self->{config}{isupport}{$_} : $_ ) } qw(CALLERID EXCEPTS INVEX MAXCHANNELS MAXBANS MAXTARGETS NICKLEN TOPICLEN KICKLEN) ), 'are supported by this server', ], }; push @$ref, { prefix => $server, command => '005', params => [ $nick, join(' ', map { (defined $self->{config}{isupport}{$_} ? join '=', $_, $self->{config}{isupport}{$_} : $_ ) } qw(CHANTYPES PREFIX CHANMODES NETWORK CASEMAPPING DEAF) ), 'are supported by this server', ], }; return @$ref if wantarray; return $ref; } sub _daemon_cmd_info { my $self = shift; my $nick = shift || return; my $target = shift; my $server = $self->server_name(); my $ref = [ ]; SWITCH: { if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'INFO', params => [$self->_state_peer_name($target)], }, $self->_state_peer_route($target), ); last SWITCH; } for my $info (@{ $self->server_config('Info') }) { push @$ref, { prefix => $server, command => '371', params => [$nick, $info], }; } push @$ref, { prefix => $server, command => '374', params => [$nick, 'End of /INFO list.'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_version { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $target = shift; SWITCH: { if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'VERSION', params => [$self->_state_peer_name($target)], }, $self->_state_peer_route($target) ); last SWITCH; } push @$ref, { prefix => $server, command => '351', params => [ $nick, $self->server_version(), $server, 'eGHIMZ TS5ow', ], }; push @$ref, $_ for @{ $self->_daemon_cmd_isupport($nick) }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_admin { my $self = shift; my $nick = shift || return; my $target = shift; my $server = $self->server_name(); my $ref = [ ]; my $admin = $self->server_config('Admin'); SWITCH: { if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'ADMIN', params => [$self->_state_peer_name($target)], }, $self->_state_peer_route($target), ); last SWITCH; } push @$ref, { prefix => $server, command => '256', params => [$nick, $server, 'Administrative Info'], }; push @$ref, { prefix => $server, command => '257', params => [$nick, $admin->[0]], }; push @$ref, { prefix => $server, command => '258', params => [$nick, $admin->[1]], }; push @$ref, { prefix => $server, command => '259', params => [$nick, $admin->[2]], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_summon { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; push @$ref, '445'; return @$ref if wantarray; return $ref; } sub _daemon_cmd_time { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $target = shift; my $ref = [ ]; SWITCH: { if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'TIME', params => [$self->_state_peer_name($target)], }, $self->_state_peer_route($target), ); last SWITCH; } push @$ref, { prefix => $server, command => '391', params => [ $nick, $server, strftime("%A %B %e %Y -- %T %z", localtime), ], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_users { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $global = keys %{ $self->{state}{users} }; my $local = keys %{ $self->{state}{peers}{uc $server}{users} }; push @$ref, { prefix => $server, command => '265', params => [ $nick, "Current local users: $local Max: " . $self->{state}{stats}{maxlocal}, ], }; push @$ref, { prefix => $server, command => '266', params => [ $nick, "Current global users: $global Max: " . $self->{state}{stats}{maxglobal}, ], }; return @$ref if wantarray; return $ref; } sub _daemon_cmd_lusers { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $invisible = $self->{state}{stats}{invisible}; my $users = keys(%{ $self->{state}{users} }) - $invisible; my $servers = keys %{ $self->{state}{peers} }; my $chans = keys %{ $self->{state}{chans} }; my $local = keys %{ $self->{state}{peers}{uc $server}{users} }; my $peers = keys %{ $self->{state}{peers}{uc $server}{peers} }; my $totalconns = $self->{state}{stats}{conns_cumlative}; my $mlocal = $self->{state}{stats}{maxlocal}; my $conns = $self->{state}{stats}{maxconns}; push @$ref, { prefix => $server, command => '251', params => [ $nick, "There are $users users and $invisible invisible on " . "$servers servers", ], }; $servers--; push @$ref, { prefix => $server, command => '252', params => [ $nick, $self->{state}{stats}{ops_online}, "IRC Operators online", ] } if $self->{state}{stats}{ops_online}; push @$ref, { prefix => $server, command => '254', params => [$nick, $chans, "channels formed"], } if $chans; push @$ref, { prefix => $server, command => '255', params => [$nick, "I have $local clients and $peers servers"], }; push @$ref, $_ for $self->_daemon_cmd_users($nick); push @$ref, { prefix => $server, command => '250', params => [ $nick, "Highest connection count: $conns ($mlocal clients) " . "($totalconns connections received)", ], }; return @$ref if wantarray; return $ref; } sub _daemon_cmd_motd { my $self = shift; my $nick = shift || return; my $target = shift; my $server = $self->server_name(); my $ref = [ ]; my $motd = $self->server_config('MOTD'); SWITCH: { if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'MOTD', params => [$self->_state_peer_name($target)], }, $self->_state_peer_route($target), ); last SWITCH; } if ($motd && ref $motd eq 'ARRAY') { push @$ref, { prefix => $server, command => '375', params => [$nick, "- $server Message of the day - "], }; push @$ref, { prefix => $server, command => '372', params => [$nick, "- $_"] } for @$motd; push @$ref, { prefix => $server, command => '376', params => [$nick, "End of MOTD command"], }; } else { push @$ref, '422'; } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_stats { my $self = shift; my $nick = shift || return; my $char = shift; my $target = shift; my $server = $self->server_name(); my $ref = [ ]; SWITCH: { if (!$char) { push @$ref, ['461', 'STATS']; last SWITCH; } $char = substr $char, 0, 1; if ($char !~ /[ump]/) { push @$ref, { prefix => $server, command => '263', params => [ $nick, 'Server load is temporarily too heavy. ' .'Please wait a while and try again.' ], }; last SWITCH; } if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'STATS', params => [ $char, $self->_state_peer_name($target), ], }, $self->_state_peer_route($target), ); last SWITCH; } SWITCH2: { if ($char eq 'u') { my $uptime = time - $self->server_config('created'); my $days = int $uptime / 86400; my $remain = $uptime % 86400; my $hours = int $remain / 3600; $remain %= 3600; my $mins = int $remain / 60; $remain %= 60; push @$ref, { prefix => $server, command => '242', params => [ $nick, sprintf("Server Up %d days, %2.2d:%2.2d:%2.2d", $days, $hours, $mins, $remain), ], }; my $totalconns = $self->{state}{stats}{conns_cumlative}; my $local = $self->{state}{stats}{maxlocal}; my $conns = $self->{state}{stats}{maxconns}; push @$ref, { prefix => $server, command => '250', params => [ $nick, "Highest connection count: $conns ($local " ."clients) ($totalconns connections received)", ], }; last SWITCH2; } if ($char eq 'm') { my $cmds = $self->{state}{stats}{cmds}; push @$ref, { prefix => $server, command => '212', params => [ $nick, $_, $cmds->{$_}{local}, $cmds->{$_}{bytes}, $cmds->{$_}{remote}, ], } for sort keys %$cmds; last SWITCH2; } if ($char eq 'p') { my @ops = map { $self->_client_nickname( $_ ) } keys %{ $self->{state}{localops} }; for my $op (sort @ops) { my $record = $self->{state}{users}{uc_irc($op)}; push @$ref, { prefix => $server, command => '249', params => [ $nick, sprintf("[O] %s (%s\@%s) Idle: %u", $record->{nick}, $record->{auth}{ident}, $record->{auth}{hostname}, time - $record->{idle_time}), ], }; } push @$ref, { prefix => $server, command => '249', params => [$nick, scalar @ops . " OPER(s)"], }; last SWITCH2; } } push @$ref, { prefix => $server, command => '219', params => [$nick, $char, 'End of /STATS report'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_userhost { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $str = ''; for my $query (@_) { my ($proper, $userhost) = split /!/, $self->state_user_full($query); if ($proper && $userhost) { $str = join(' ', $str, $proper . ($self->state_user_is_operator($proper) ? '*' : '' ) . '=' . ($self->_state_user_away($proper) ? '-' : '+' ) . $userhost); } } push @$ref, { prefix => $server, command => '302', params => [$nick, ($str ? $str : ':')], }; return @$ref if wantarray; return $ref; } sub _daemon_cmd_ison { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$count) { push @$ref, ['461', 'ISON']; last SWITCH; } my $string = ''; $string = join ' ', map { $self->{state}{users}{uc_irc($_)}{nick} } grep { $self->state_nick_exists($_) } @$args; push @$ref, { prefix => $server, command => '303', params => [$nick, ($string =~ /\s+/ ? $string : ":$string")], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_list { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { my @chans; if (!$count) { @chans = map { $self->_state_chan_name($_) } keys %{ $self->{state}{chans} }; } my $last = pop @$args; if ($count && $last !~ /^[#&]/ && !$self->state_peer_exists($last)) { push @$ref, ['401', $last]; last SWITCH; } if ($count && $last !~ /^[#&]/ && uc $last ne uc $server) { $self->send_output( { prefix => $self->state_user_full($nick), command => 'LIST', params => [ @$args, $self->_state_peer_name($last), ], }, $self->_state_peer_route($last), ); last SWITCH; } if ($count && $last !~ /^[#&]/ && @$args == 0) { @chans = map { $self->_state_chan_name($_) } keys %{ $self->{state}{chans} }; } if ($count && $last !~ /^[#&]/ && @$args == 1) { $last = pop @$args; } if ($count && $last =~ /^[#&]/) { @chans = split /,/, $last; } push @$ref, { prefix => $server, command => '321', params => [$nick, 'Channel', 'Users Name'], }; my $count = 0; INNER: for my $chan (@chans) { if (!is_valid_chan_name($chan) || !$self->state_chan_exists($chan)) { if (!$count) { push @$ref, ['401', $chan]; last INNER; } $count++; next INNER; } $count++; if ($self->state_chan_mode_set( $chan, 'p') || $self->state_chan_mode_set($chan, 's') && !$self->state_is_chan_member($nick, $chan)) { next INNER; } my $record = $self->{state}{chans}{uc_irc($chan)}; push @$ref, { prefix => $server, command => '322', params => [ $nick, $record->{name}, scalar keys %{ $record->{users} }, (defined $record->{topic} ? $record->{topic}[0] : '' ), ], }; } push @$ref, { prefix => $server, command => '323', params => [$nick, 'End of /LIST'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_names { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { my (@chans, $query); if (!$count) { @chans = $self->state_user_chans($nick); $query = '*'; } my $last = pop @$args; if ($count && $last !~ /^[#&]/ && !$self->state_peer_exists($last)) { push @$ref, ['401', $last]; last SWITCH; } if ($count && $last !~ /^[#&]/ & uc $last ne uc $server) { $self->send_output( { prefix => $nick, command => 'NAMES', params => [@$args, $self->_state_peer_name($last)], }, $self->_state_peer_route($last), ); last SWITCH; } if ($count && $last !~ /^[#&]/ && @$args == 0) { @chans = $self->state_user_chans($nick); $query = '*'; } if ($count && $last !~ /^[#&]/ && @$args == 1) { $last = pop @$args; } if ($count && $last =~ /^[#&]/) { my ($chan) = grep { $_ && $self->state_chan_exists($_) && $self->state_is_chan_member($nick, $_) } split /,/, $last; @chans = (); if ($chan) { push @chans, $chan; $query = $self->_state_chan_name($chan); } else { $query = '*'; } } for my $chan (@chans) { my $record = $self->{state}{chans}{uc_irc($chan)}; my $type = '='; $type = '@' if $record->{mode} =~ /s/; $type = '*' if $record->{mode} =~ /p/; my $length = length($server)+3+length($chan)+length($nick)+7; my $buffer = ''; for my $name (sort $self->state_chan_list_prefixed($record->{name})) { if (length(join ' ', $buffer, $name) + $length > 510) { push @$ref, { prefix => $server, command => '353', params => [$nick, $type, $record->{name}, $buffer] }; $buffer = $name; next; } if ($buffer) { $buffer = join ' ', $buffer, $name; } else { $buffer = $name; } } push @$ref, { prefix => $server, command => '353', params => [$nick, $type, $record->{name}, $buffer], }; } push @$ref, { prefix => $server, command => '366', params => [$nick, $query, 'End of NAMES list'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_whois { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my ($first, $second) = @_; SWITCH: { if (!$first && !$second) { push @$ref, ['431']; last SWITCH; } if (!$second && $first) { $second = (split /,/, $first)[0]; $first = $server; } if ($first && $second) { $second = (split /,/, $second)[0]; } if (uc_irc($first) eq uc_irc($second) && $self->state_nick_exists($second)) { $first = $self->state_user_server($second); } my $query; my $target; $query = $first if !$second; $query = $second if $second; $target = $first if $second && uc $first ne uc$server; if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target) { $self->send_output( { prefix => $nick, command => 'WHOIS', params => [ $self->_state_peer_name($target), $second, ], }, $self->_state_peer_route($target), ); last SWITCH; } # Okay we got here *phew* if (!$self->state_nick_exists($query)) { push @$ref, ['401', $query]; } else { my $record = $self->{state}{users}{uc_irc($query)}; push @$ref, { prefix => $server, command => '311', params => [ $nick, $record->{nick}, $record->{auth}{ident}, $record->{auth}{hostname}, '*', $record->{ircname}, ], }; my @chans; LOOP: for my $chan (keys %{ $record->{chans} }) { if ($self->{state}{chans}{$chan}{mode} =~ /[ps]/ && !$self->state_is_chan_member($nick, $chan)) { next LOOP; } my $prefix = ''; $prefix .= '@' if $record->{chans}{$chan} =~ /o/; $prefix .= '%' if $record->{chans}{$chan} =~ /h/; $prefix .= '+' if $record->{chans}{$chan} =~ /v/; push @chans, $prefix . $self->{state}{chans}{$chan}{name}; } if (@chans) { my $buffer = ''; my $length = length($server) + 3 + length($nick) + length($record->{nick}) + 7; LOOP2: for my $chan (@chans) { if (length(join ' ', $buffer, $chan) + $length > 510) { push @$ref, { prefix => $server, command => '319', params => [$nick, $record->{nick}, $buffer], }; $buffer = $chan; next LOOP2; } if ($buffer) { $buffer = join ' ', $buffer, $chan; } else { $buffer = $chan; } } push @$ref, { prefix => $server, command => '319', params => [$nick, $record->{nick}, $buffer], }; } push @$ref, { prefix => $server, command => '312', params => [ $nick, $record->{nick}, $record->{server}, $self->_state_peer_desc($record->{server}), ], }; push @$ref, { prefix => $server, command => '301', params => [ $nick, $record->{nick}, $record->{away}, ], } if $record->{type} eq 'c' && $record->{away}; push @$ref, { prefix => $server, command => '313', params => [$nick, $record->{nick}, 'is an IRC Operator'], } if $record->{umode} && $record->{umode} =~ /o/; if ($record->{type} eq 'c' && ($self->server_config('whoisactually') or $self->state_user_is_operator($nick))) { push @$ref, { prefix => $server, command => '338', params => [ $nick, $record->{nick}, $record->{socket}[0], 'actually using host', ], }; } push @$ref, { prefix => $server, command => '317', params => [ $nick, $record->{nick}, time - $record->{idle_time}, $record->{conn_time}, 'seconds idle, signon time', ], } if $record->{type} eq 'c'; } push @$ref, { prefix => $server, command => '318', params => [$nick, $query, 'End of /WHOIS list.'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_who { my $self = shift; my $nick = shift || return; my ($who, $op_only) = @_; my $server = $self->server_name(); my $ref = [ ]; my $orig = $who; SWITCH: { if (!$who) { push @$ref, ['461', 'WHO']; last SWITCH; } if ($self->state_chan_exists($who) && $self->state_is_chan_member($nick, $who)) { my $record = $self->{state}{chans}{uc_irc($who)}; $who = $record->{name}; for my $member (keys %{ $record->{users} }) { my $rpl_who = { prefix => $server, command => '352', params => [$nick, $who], }; my $memrec = $self->{state}{users}{$member}; push @{ $rpl_who->{params} }, $memrec->{auth}{ident}; push @{ $rpl_who->{params} }, $memrec->{auth}{hostname}; push @{ $rpl_who->{params} }, $memrec->{server}; push @{ $rpl_who->{params} }, $memrec->{nick}; my $status = ($memrec->{away} ? 'G' : 'H'); $status .= '*' if $memrec->{umode} =~ /o/; $status .= '@' if $record->{users}{$member} =~ /o/; $status .= '%' if $record->{users}{$member} =~ /h/; $status .= '+' if $record->{users}{$member} !~ /o/ and $record->{users}{$member} =~ /v/; push @{ $rpl_who->{params} }, $status; push @{ $rpl_who->{params} }, "$memrec->{hops} " . $memrec->{ircname}; push @$ref, $rpl_who; } } if ($self->state_nick_exists($who)) { my $nickrec = $self->{state}{users}{uc_irc($who)}; $who = $nickrec->{nick}; my $rpl_who = { prefix => $server, command => '352', params => [$nick, '*'], }; push @{ $rpl_who->{params} }, $nickrec->{auth}{ident}; push @{ $rpl_who->{params} }, $nickrec->{auth}{hostname}; push @{ $rpl_who->{params} }, $nickrec->{server}; push @{ $rpl_who->{params} }, $nickrec->{nick}; my $status = ($nickrec->{away} ? 'G' : 'H'); $status .= '*' if $nickrec->{umode} =~ /o/; push @{ $rpl_who->{params} }, $status; push @{ $rpl_who->{params} }, "$nickrec->{hops} " . $nickrec->{ircname}; push @$ref, $rpl_who; } push @$ref, { prefix => $server, command => '315', params => [$nick, $orig, 'End of WHO list'], }; } return @$ref if wantarray; return $ref; } sub _daemon_cmd_mode { my $self = shift; my $nick = shift || return; my $chan = shift; my $server = $self->server_name(); my $maxmodes = $self->server_config('MODES'); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$self->state_chan_exists($chan)) { push @$ref, ['403', $chan]; last SWITCH; } my $record = $self->{state}{chans}{uc_irc($chan)}; $chan = $record->{name}; if (!$count && !$self->state_is_chan_member($nick, $chan)) { push @$ref, { prefix => $server, command => '324', params => [$nick, $chan, '+' . $record->{mode}], colonify => 0, }; push @$ref, { prefix => $server, command => '329', params => [$nick, $chan, $record->{ts}], colonify => 0, }; last SWITCH; } if (!$count) { push @$ref, { prefix => $server, command => '324', params => [ $nick, $chan, '+' . $record->{mode}, ($record->{ckey} || ()), ($record->{climit} || ()), ], colonify => 0, }; push @$ref, { prefix => $server, command => '329', params => [$nick, $chan, $record->{ts}], colonify => 0, }; last SWITCH; } my $unknown = 0; my $notop = 0; my $nick_is_op = $self->state_is_chan_op($nick, $chan); my $nick_is_hop = $self->state_is_chan_hop($nick, $chan); my $reply; my @reply_args; my $parsed_mode = parse_mode_line(@$args); my $mode_count = 0; while (my $mode = shift @{ $parsed_mode->{modes} }) { if ($mode !~ /[eIbklimnpstohv]/) { push @$ref, [ '472', (split //, $mode)[1], $chan, ] if !$unknown; $unknown++; next; } my $arg; if ($mode =~ /^(\+[ohvklbIe]|-[ohvbIe])/) { $arg = shift @{ $parsed_mode->{args} }; } if ($mode =~ /[-+]b/ && !defined $arg) { push @$ref, { prefix => $server, command => '367', params => [ $nick, $chan, @{ $record->{bans}{$_} }, ] } for keys %{ $record->{bans} }; push @$ref, { prefix => $server, command => '368', params => [$nick, $chan, 'End of Channel Ban List'], }; next; } if (!$nick_is_op && !$nick_is_hop) { push @$ref, ['482', $chan] if !$notop; $notop++; next; } if ($mode =~ /[-+]I/ && !defined $arg) { push @$ref, { prefix => $server, command => '346', params => [ $nick, $chan, @{ $record->{invex}{$_} }, ], } for keys %{ $record->{invex} }; push @$ref, { prefix => $server, command => '347', params => [$nick, $chan, 'End of Channel Invite List'] }; next; } if ($mode =~ /[-+]e/ && !defined $arg) { push @$ref, { prefix => $server, command => '348', params => [$nick, $chan, @{ $record->{excepts}{$_} } ] } for keys %{ $record->{excepts} }; push @$ref, { prefix => $server, command => '349', params => [ $nick, $chan, 'End of Channel Exception List', ], }; next; } if (!$nick_is_op && $nick_is_hop && $mode =~ /[op]/) { push @$ref, ['482', $chan] if !$notop; $notop++; next; } if (!$nick_is_op && $nick_is_hop && $record->{mode} =~ /p/ && $mode =~ /h/) { push @$ref, ['482', $chan] if !$notop; $notop++; next; } if (($mode =~ /^[-+][ohv]/ || $mode =~ /^\+[lk]/) && !defined $arg) { next; } if ($mode =~ /^[-+][ohv]/ && !$self->state_nick_exists($arg)) { next if ++$mode_count > $maxmodes; push @$ref, ['401', $arg]; next; } if ($mode =~ /^[-+][ohv]/ && !$self->state_is_chan_member($arg, $chan)) { next if ++$mode_count > $maxmodes; push @$ref, ['441', $chan, $self->state_user_nick($arg)]; next; } if (my ($flag, $char) = $mode =~ /^([-+])([ohv])/ ) { next if ++$mode_count > $maxmodes; if ($flag eq '+' && $record->{users}{uc_irc($arg)} !~ /$char/) { # Update user and chan record $arg = uc_irc($arg); if ($mode eq '+h' && $record->{users}{$arg} =~ /o/) { next; } if ($char eq 'h' && $record->{users}{$arg} =~ /v/) { $record->{users}{$arg} =~ s/v//g; $reply .= '-v'; push @reply_args, $self->state_user_nick($arg); } if ($char eq 'o' && $record->{users}{$arg} =~ /h/ ) { $record->{users}{$arg} =~ s/h//g; $reply .= '-h'; push @reply_args, $self->state_user_nick($arg); } $record->{users}{$arg} = join('', sort split //, $record->{users}{$arg} . $char); $self->{state}{users}{$arg}{chans}{uc_irc($chan)} = $record->{users}{$arg}; $reply .= $mode; push @reply_args, $self->state_user_nick($arg); } if ($flag eq '-' && $record->{users}{uc_irc($arg)} =~ /$char/) { # Update user and chan record $arg = uc_irc($arg); $record->{users}{$arg} =~ s/$char//g; $self->{state}{users}{$arg}{chans}{uc_irc($chan)} = $record->{users}{$arg}; $reply .= $mode; push @reply_args, $self->state_user_nick($arg); } next; } if ($mode eq '+l' && $arg =~ /^\d+$/ && $arg > 0) { next if ++$mode_count > $maxmodes; $reply .= $mode; push @reply_args, $arg; if ($record->{mode} !~ /l/) { $record->{mode} = join('', sort split //, $record->{mode} . 'l'); } $record->{climit} = $arg; next; } if ($mode eq '-l' && $record->{mode} =~ /l/) { $record->{mode} =~ s/l//g; delete $record->{climit}; $reply .= $mode; next; } if ($mode eq '+k' && $arg) { next if ++$mode_count > $maxmodes; $reply .= $mode; push @reply_args, $arg; if ($record->{mode} !~ /k/) { $record->{mode} = join('', sort split //, $record->{mode} . 'k'); } $record->{ckey} = $arg; next; } if ($mode eq '-k' && $record->{mode} =~ /k/) { $reply .= $mode; push @reply_args, '*'; $record->{mode} =~ s/k//g; delete $record->{ckey}; next; } # Bans if (my ($flag) = $mode =~ /([-+])b/) { next if ++$mode_count > $maxmodes; my $mask = normalize_mask($arg); my $umask = uc_irc $mask; if ($flag eq '+' && !$record->{bans}{$umask}) { $record->{bans}{$umask} = [$mask, $self->state_user_full($nick), time]; $reply .= $mode; push @reply_args, $mask; } if ($flag eq '-' && $record->{bans}{$umask}) { delete $record->{bans}{$umask}; $reply .= $mode; push @reply_args, $mask; } next; } # Invex if (my ($flag) = $mode =~ /([-+])I/) { next if ++$mode_count > $maxmodes; my $mask = normalize_mask( $arg ); my $umask = uc_irc $mask; if ($flag eq '+' && !$record->{invex}{$umask}) { $record->{invex}{$umask} = [$mask, $self->state_user_full($nick), time]; $reply .= $mode; push @reply_args, $mask; } if ($flag eq '-' && $record->{invex}{$umask}) { delete $record->{invex}{$umask}; $reply .= $mode; push @reply_args, $mask; } next; } # Exceptions if (my ($flag) = $mode =~ /([-+])e/) { next if ++$mode_count > $maxmodes; my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{excepts}{$umask}) { $record->{excepts}{$umask} = [$mask, $self->state_user_full($nick), time]; $reply .= $mode; push @reply_args, $mask; } if ($flag eq '-' && $record->{excepts}{$umask}) { delete $record->{excepts}{$umask}; $reply .= $mode; push @reply_args, $mask; } next; } # The rest should be argumentless. my ($flag, $char) = split //, $mode; if ($flag eq '+' && $record->{mode} !~ /$char/) { $reply .= $mode; $record->{mode} = join('', sort split //, $record->{mode} . $char); next; } if ($flag eq '-' && $record->{mode} =~ /$char/) { $reply .= $mode; $record->{mode} =~ s/$char//g; next; } } # while if ($reply) { $reply = unparse_mode_line($reply); my $output = { prefix => $self->state_user_full($nick), command => 'MODE', params => [$chan, $reply, @reply_args], colonify => 0, }; $self->_send_output_to_channel($chan, $output); } } # SWITCH return @$ref if wantarray; return $ref; } sub _daemon_cmd_join { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; my $route_id = $self->_state_user_route($nick); my $unick = uc_irc($nick); SWITCH: { my (@channels, @chankeys); if (!$count) { push @$ref, ['461', 'JOIN']; last SWITCH; } @channels = split /,/, $args->[0]; @chankeys = split /,/, $args->[1] if $args->[1]; my $channel_length = $self->server_config('CHANNELLEN'); LOOP: for my $channel (@channels) { my $uchannel = uc_irc($channel); if ($channel eq '0' and my @chans = $self->state_user_chans($nick)) { $self->_send_output_to_client( $route_id, (ref $_ eq 'ARRAY' ? @$_ : $_), ) for map { $self->_daemon_cmd_part($nick, $_) } @chans; next LOOP; } # Channel isn't valid if (!is_valid_chan_name($channel) || length $channel > $channel_length) { $self->_send_output_to_client( $route_id, '403', $channel, ); next LOOP; } # Too many channels if ($self->state_user_chans($nick) >= $self->server_config('MAXCHANNELS') && !$self->state_user_is_operator($nick)) { $self->_send_output_to_client( $route_id, '405', $channel, ); next LOOP; } # Channel doesn't exist if (!$self->state_chan_exists($channel)) { my $record = { name => $channel, ts => time, mode => 'nt', users => { $unick => 'o' }, }; $self->{state}{chans}{$uchannel} = $record; $self->{state}{users}{$unick}{chans}{$uchannel} = 'o'; my @peers = $self->_state_connected_peers(); $self->send_output( { command => 'SJOIN', params => [ $record->{ts}, $channel, '+' . $record->{mode}, '@' . $nick, ], }, @peers, ) if $channel !~ /^&/; my $output = { prefix => $self->state_user_full($nick), command => 'JOIN', params => [$channel], }; $self->send_output($output, $route_id); $self->send_event( "daemon_join", $output->{prefix}, $channel, ); $self->send_output( { prefix => $server, command => 'MODE', params => [$channel, '+' . $record->{mode}], }, $route_id, ); $self->_send_output_to_client( $route_id, (ref $_ eq 'ARRAY' ? @$_ : $_), ) for $self->_daemon_cmd_names($nick, $channel); $self->_send_output_to_client( $route_id, (ref $_ eq 'ARRAY' ? @$_ : $_ ), ) for $self->_daemon_cmd_topic($nick, $channel); next LOOP; } # Numpty user is already on channel if ($self->state_is_chan_member($nick, $channel)) { next LOOP; } my $chanrec = $self->{state}{chans}{$uchannel}; my $bypass; if ($self->state_user_is_operator($nick) && $self->{config}{OPHACKS}) { $bypass = 1; } # Channel is full if (!$bypass && $chanrec->{mode} =~ /l/ && keys %$chanrec >= $chanrec->{climit}) { $self->_send_output_to_client($route_id, '471', $channel); next LOOP; } my $chankey; $chankey = shift @chankeys if $chanrec->{mode} =~ /k/; # Channel +k and no key or invalid key provided if (!$bypass && $chanrec->{mode} =~ /k/ && (!$chankey || $chankey ne $chanrec->{ckey})) { $self->_send_output_to_client($route_id, '475', $channel); next LOOP; } # Channel +i and not INVEX if (!$bypass && $chanrec->{mode} =~ /i/ && !$self->_state_user_invited($nick, $channel)) { $self->_send_output_to_client($route_id, '473', $channel); next LOOP; } # Channel +b and no exception if (!$bypass && $self->_state_user_banned($nick, $channel)) { $self->_send_output_to_client($route_id, '474', $channel); next LOOP; } # JOIN the channel delete $self->{state}{users}{$unick}{invites}{$uchannel}; # Add user $self->{state}{users}{$unick}{chans}{$uchannel} = ''; $self->{state}{chans}{$uchannel}{users}{$unick} = ''; # Send JOIN message to peers and local users. $self->send_output( { prefix => $server, command => 'SJOIN', params => [$chanrec->{ts}, $channel, '+', $nick], }, $self->_state_connected_peers(), ) if $channel !~ /^&/; my $output = { prefix => $self->state_user_full($nick), command => 'JOIN', params => [$channel], }; $self->_send_output_to_client($route_id, $output); $self->_send_output_to_channel($channel, $output, $route_id); # Send NAMES and TOPIC to client $self->_send_output_to_client( $route_id, (ref $_ eq 'ARRAY' ? @$_ : $_), ) for $self->_daemon_cmd_names($nick, $channel); $self->_send_output_to_client( $route_id, (ref $_ eq 'ARRAY' ? @$_ : $_), ) for $self->_daemon_cmd_topic($nick, $channel); } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_part { my $self = shift; my $nick = shift || return; my $chan = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$chan) { push @$ref, ['461', 'PART']; last SWITCH; } if (!$self->state_chan_exists($chan)) { push @$ref, ['403', $chan]; last SWITCH; } if (!$self->state_is_chan_member($nick, $chan)) { push @$ref, ['442', $chan]; last SWITCH; } $self->_send_output_to_channel( $chan, { prefix => $self->state_user_full($nick), command => 'PART', params => [$chan, ($args->[0] || $nick)], }, ); $nick = uc_irc($nick); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$nick}; delete $self->{state}{users}{$nick}{chans}{$chan}; if (! keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_kick { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$count || $count < 2) { push @$ref, ['461', 'KICK']; last SWITCH; } my $chan = (split /,/, $args->[0])[0]; my $who = (split /,/, $args->[1])[0]; if (!$self->state_chan_exists($chan)) { push @$ref, ['403', $chan]; last SWITCH; } $chan = $self->_state_chan_name($chan); if (!$self->state_nick_exists($who) ) { push @$ref, ['401', $who]; last SWITCH; } $who = $self->state_user_nick($who); if (!$self->state_is_chan_op($nick, $chan)) { push @$ref, ['482', $chan]; last SWITCH; } if (!$self->state_is_chan_member($who, $chan)) { push @$ref, ['441', $who, $chan]; last SWITCH; } my $comment = $args->[2] || $who; $self->_send_output_to_channel( $chan, { prefix => $self->state_user_full($nick), command => 'KICK', params => [$chan, $who, $comment], }, ); $who = uc_irc($who); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$who}; delete $self->{state}{users}{$who}{chans}{$chan}; if (!keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_remove { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$count || $count < 2) { push @$ref, ['461', 'REMOVE']; last SWITCH; } my $chan = (split /,/, $args->[0])[0]; my $who = (split /,/, $args->[1])[0]; if (!$self->state_chan_exists($chan)) { push @$ref, ['403', $chan]; last SWITCH; } $chan = $self->_state_chan_name($chan); if (!$self->state_nick_exists($who)) { push @$ref, ['401', $who]; last SWITCH; } my $fullwho = $self->state_user_full($who); $who = (split /!/, $fullwho)[0]; if (!$self->state_is_chan_op($nick, $chan)) { push @$ref, ['482', $chan]; last SWITCH; } if (!$self->state_is_chan_member($who, $chan)) { push @$ref, ['441', $who, $chan]; last SWITCH; } my $comment = "Requested by $nick"; $comment .= qq{ "$args->[2]"} if $args->[2]; $self->_send_output_to_channel( $chan, { prefix => $fullwho, command => 'PART', params => [$chan, $comment], }, ); $who = uc_irc($who); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$who}; delete $self->{state}{users}{$who}{chans}{$chan}; if (! keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_invite { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH: { if (!$count || $count < 2) { push @$ref, ['461', 'INVITE']; last SWITCH; } my ($who, $chan) = @$args; if (!$self->state_nick_exists($who)) { push @$ref, ['401', $who]; last SWITCH; } $who = $self->state_user_nick($who); if (!$self->state_chan_exists($chan)) { push @$ref, ['403', $chan]; last SWITCH; } $chan = $self->_state_chan_name($chan); if (!$self->state_is_chan_member($nick, $chan)) { push @$ref, ['442', $chan]; last SWITCH; } if ($self->state_is_chan_member($who, $chan)) { push @$ref, ['443', $who, $chan]; last SWITCH; } if ($self->state_chan_mode_set($chan, 'i') && !$self->state_is_chan_op($nick, $chan)) { push @$ref, ['482', $chan]; last SWITCH; } my $local; if ($self->_state_is_local_user($who)) { my $record = $self->{state}{users}{uc_irc($who)}; $record->{invites}{uc_irc($chan)} = time; $local = 1; } my $away = $self->_state_user_away_msg($who); my $route_id = $self->_state_user_route($who); my $output = { prefix => $self->state_user_full($nick), command => 'INVITE', params => [$who, $chan], colonify => 0, }; if ($route_id eq 'spoofed') { $self->send_event( "daemon_invite", $output->{prefix}, @{ $output->{params} } ); } else { if (!$local) { $output->{prefix} = $nick; push @{ $output->{params} }, time; } $self->send_output($output, $route_id); } push @$ref, { prefix => $server, command => '341', params => [$chan, $who], }; if (defined $away) { push @$ref, { prefix => $server, command => '301', params => [$nick, $who, $away], }; } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_umode { my $self = shift; my $nick = shift || return; my $umode = shift; my $server = $self->server_name(); my $ref = [ ]; my $record = $self->{state}{users}{uc_irc($nick)}; if (!$umode) { push @$ref, { prefix => $server, command => '221', params => [$nick, '+' . $record->{umode}], }; } else { my $peer_ignore; my $parsed_mode = parse_mode_line($umode); my $route_id = $self->_state_user_route($nick); my $previous = $record->{umode}; while (my $mode = shift @{ $parsed_mode->{modes} }) { next if $mode eq '+o'; my ($action, $char) = split //, $mode; if ($action eq '+' && $record->{umode} !~ /$char/) { next if $char =~ /[wzl]a/ && $record->{umode} !~ /o/; $record->{umode} .= $char; if ($char eq 'i') { $self->{state}{stats}{invisible}++; $peer_ignore = delete $record->{_ignore_i_umode}; } if ($char eq 'w') { $self->{state}{wallops}{$route_id} = time; } if ($char eq 'z') { $self->{state}{operwall}{$route_id} = time; } if ($char eq 'l') { $self->{state}{locops}{$route_id} = time; } } if ($action eq '-' && $record->{umode} =~ /$char/) { $record->{umode} =~ s/$char//g; $self->{state}{stats}{invisible}-- if $char eq 'i'; if ($char eq 'o') { $self->{state}{stats}{ops_online}--; delete $self->{state}{localops}{$route_id}; $self->antiflood( $route_id, 1); } if ($char eq 'w') { delete $self->{state}{wallops}{$route_id}; } if ($char eq 'z') { delete $self->{state}{operwall}{$route_id}; } if ($char eq 'l') { delete $self->{state}{locops}{$route_id}; } } } $record->{umode} = join '', sort split //, $record->{umode}; my $peerprev = $previous; my $peerumode = $record->{umode}; $peerprev =~ s/[^aiow]//g; $peerumode =~ s/[^aiow]//g; my $pset = gen_mode_change($peerprev, $peerumode); my $set = gen_mode_change($previous, $record->{umode}); if ($pset && !$peer_ignore ) { my $hashref = { prefix => $nick, command => 'MODE', params => [$nick, $pset], }; $self->send_output( $hashref, $self->_state_connected_peers(), ); } if ($set) { my $hashref = { prefix => $nick, command => 'MODE', params => [$nick, $set], }; $self->send_event( "daemon_umode", $self->state_user_full($nick), $set ) if !$peer_ignore; push @$ref, $hashref; } } return @$ref if wantarray; return $ref; } sub _daemon_cmd_topic { my $self = shift; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [@_]; my $count = @$args; SWITCH:{ if (!$count) { push @$ref, ['461', 'TOPIC']; last SWITCH; } if (!$self->state_chan_exists($args->[0])) { push @$ref, ['403', $args->[0]]; last SWITCH; } if ($self->state_chan_mode_set($args->[0], 's') && !$self->state_is_chan_member($nick, $args->[0])) { push @$ref, ['442', $args->[0]]; last SWITCH; } my $chan_name = $self->_state_chan_name($args->[0]); if ($count == 1 and my $topic = $self->state_chan_topic($args->[0])) { push @$ref, { prefix => $server, command => '332', params => [$nick, $chan_name, $topic->[0]], }; push @$ref, { prefix => $server, command => '333', params => [$nick, $chan_name, @{ $topic }[1..2]], }; last SWITCH; } if ($count == 1) { push @$ref, { prefix => $server, command => '331', params => [$nick, $chan_name, 'No topic is set'], }; last SWITCH; } if (!$self->state_is_chan_member($nick, $args->[0])) { push @$ref, ['442', $args->[0]]; last SWITCH; } if ($self->state_chan_mode_set($args->[0], 't') && !$self->state_is_chan_op($nick, $args->[0])) { push @$ref, ['482', $args->[0]]; last SWITCH; } my $record = $self->{state}{chans}{uc_irc($args->[0])}; my $topic_length = $self->server_config('TOPICLEN'); if (length $args->[0] > $topic_length) { $args->[1] = substr $args->[0], 0, $topic_length; } if ($args->[1] eq '') { delete $record->{topic}; } else { $record->{topic} = [ $args->[1], $self->state_user_full($nick), time, ]; } $self->_send_output_to_channel( $args->[0], { prefix => $self->state_user_full($nick), command => 'TOPIC', params => [$chan_name, $args->[1]], }, ); } return @$ref if wantarray; return $ref; } sub _daemon_cmd_links { my $self = shift; my $nick = shift || return; my $target = shift; my $server = $self->server_name(); my $ref = [ ]; SWITCH:{ if ($target && !$self->state_peer_exists($target)) { push @$ref, ['402', $target]; last SWITCH; } if ($target && uc $server ne uc $target) { $self->send_output( { prefix => $nick, command => 'LINKS', params => [$self->_state_peer_name($target)], }, $self->_state_peer_route($target) ); last SWITCH; } for ($self->_state_server_links($server, $server, $nick)) { push @$ref, $_; } push @$ref, { prefix => $server, command => '364', params => [ $nick, $server, $server, join( ' ', '0', $self->server_config('serverdesc')) ], }; push @$ref, { prefix => $server, command => '365', params => [$nick, '*', 'End of /LINKS list.'], }; } return @$ref if wantarray; return $ref; } sub _daemon_peer_squit { my $self = shift; my $peer_id = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; return if !$self->state_peer_exists($args->[0]); SWITCH: { if ($peer_id ne $self->_state_peer_route($args->[0])) { $self->send_output( { command => 'SQUIT', params => $args, }, $self->_state_peer_route($args->[0]), ); last SWITCH; } if ($peer_id eq $self->_state_peer_route($args->[0])) { $self->send_output( { command => 'SQUIT', params => $args, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_event("daemon_squit", @$args); my $quit_msg = join ' ', $self->_state_peer_for_peer($args->[0]), $args->[0]; for my $nick ($self->_state_server_squit($args->[0])) { my $output = { prefix => $self->state_user_full($nick), command => 'QUIT', params => [$quit_msg], }; my $common = { }; for my $uchan ($self->state_user_chans($nick)) { $uchan = uc_irc($uchan); delete $self->{state}{chans}{$uchan}{users}{$nick}; for my $user ($self->state_chan_list($uchan)) { next if !$self->_state_is_local_user($user); $common->{$user} = $self->_state_user_route($user); } if (!keys %{ $self->{state}{chans}{$uchan}{users} }) { delete $self->{state}{chans}{$uchan}; } } $self->send_output($output, values %$common); $self->send_event( "daemon_quit", $output->{prefix}, $output->{params}[0], ); my $record = delete $self->{state}{users}{$nick}; if ($record->{umode} =~ /o/) { $self->{state}{stats}{ops_online}--; } if ($record->{umode} =~ /i/) { $self->{state}{stats}{invisible}--; } } last SWITCH; } } return @$ref if wantarray; return $ref; } sub _daemon_peer_rkline { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; # :klanker RKLINE logserv.gumbynet.org.uk 600 ^m.*\ foo\.(com|uk|net)$ :Foo SWITCH: { if (!$count || $count < 5) { last SWITCH; } my $full = $self->state_user_full($nick); my $target = $args->[0]; my $us = 0; my $ucserver = uc $server; my %targets; for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask( $target, $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{$self->_state_peer_route($peer)}++; } } } delete $targets{$peer_id}; $self->send_output( { prefix => $nick, command => 'RKLINE', params => $args, colonify => 0, }, grep { $self->_state_peer_capab($_, 'KLN') } keys %targets, ); if ($us) { $self->send_event("daemon_rkline", $full, @$args); push @{ $self->{state}{rklines} }, { setby => $full, setat => time, target => $args->[0], duration => $args->[1], user => $args->[2], host => $args->[3], reason => $args->[4], }; $self->_terminate_conn_error($_, 'K-Lined') for $self->_state_local_users_match_rkline($args->[2], $args->[3]); } } return @$ref if wantarray; return $ref; } sub _daemon_peer_kline { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count || $count < 5) { last SWITCH; } my $full = $self->state_user_full($nick); my $target = $args->[0]; my $us = 0; my $ucserver = uc $server; my %targets; for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask($target, $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{$self->_state_peer_route($peer)}++; } } } delete $targets{$peer_id}; $self->send_output( { prefix => $nick, command => 'KLINE', params => $args, colonify => 0, }, grep { $self->_state_peer_capab($_, 'KLN') } keys %targets, ); if ($us) { $self->send_event("daemon_kline", $full, @$args); push @{ $self->{state}{klines} }, { setby => $full, setat => time(), target => $args->[0], duration => $args->[1], user => $args->[2], host => $args->[3], reason => $args->[4], }; $self->_terminate_conn_error($_, 'K-Lined') for $self->_state_local_users_match_gline($args->[2], $args->[3]); } } return @$ref if wantarray; return $ref; } sub _daemon_peer_unkline { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; # :klanker UNKLINE logserv.gumbynet.org.uk * moos.loud.me.uk SWITCH: { if (!$count || $count < 3) { last SWITCH; } my $full = $self->state_user_full($nick); my $target = $args->[0]; my $us = 0; my $ucserver = uc $server; my %targets; for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask($target, $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{$self->_state_peer_route($peer)}++; } } } delete $targets{$peer_id}; $self->send_output( { prefix => $nick, command => 'UNKLINE', params => $args, colonify => 0, }, grep { $self->_state_peer_capab($_, 'UNKLN') } keys %targets, ); if ($us) { $self->send_event("daemon_unkline", $full, @$args); my $i = 0; for (@{ $self->{state}{klines} }) { if ($_->{user} eq $args->[1] && $_->{host} eq $args->[2]) { splice (@{ $self->{state}{klines} }, $i, 1); last; } ++$i; } } } return @$ref if wantarray; return $ref; } sub _daemon_peer_gline { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; # :klanker GLINE * meep.com :Fuckers SWITCH: { if (!$count || $count < 3) { last SWITCH; } my $full = $self->state_user_full($nick); push @{ $self->{state}{glines} }, { setby => $full, setat => time, user => $args->[0], host => $args->[1], reason => $args->[2], }; $self->send_output( { prefix => $nick, command => 'GLINE', params => $args, colonify => 0, }, grep { $_ ne $peer_id && $self->_state_peer_capab($_, 'GLN') } $self->_state_connected_peers(), ); $self->send_event("daemon_gline", $full, @$args); $self->_terminate_conn_error($_, 'G-Lined') for $self->_state_local_users_match_gline($args->[0], $args->[1]); } return @$ref if wantarray; return $ref; } sub _daemon_peer_wallops { my $self = shift; my $peer_id = shift || return; my $prefix = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { my $full = $self->state_user_full($prefix) || $prefix; $self->send_output( { prefix => $prefix, command => 'WALLOPS', params => [$args->[0]], }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); if ($self->state_peer_exists($full)) { $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['OPERWALL - ' . $args->[0]], }, keys %{ $self->{state}{wallops} }, ); $self->send_event("daemon_wallops", $full, $args->[0]); } else { $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['OPERWALL - ' . $args->[0]], }, keys %{ $self->{state}{operwall} }, ); $self->send_event("daemon_operwall", $full, $args->[0]); } } return @$ref if wantarray; return $ref; } sub _daemon_peer_operwall { my $self = shift; my $peer_id = shift || return; my $prefix = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { my $full = $self->state_user_full($prefix) || $prefix; $self->send_output( { prefix => $prefix, command => 'WALLOPS', params => [$args->[0]], }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); if ($self->state_peer_exists($full)) { $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['OPERWALL - ' . $args->[0]], }, keys %{ $self->{state}{wallops} }, ); $self->send_event("daemon_wallops", $full, $args->[0]); } else { $self->send_output( { prefix => $full, command => 'WALLOPS', params => ['OPERWALL - ' . $args->[0]], }, keys %{ $self->{state}{operwall} }, ); $self->send_event("daemon_operwall", $full, $args->[0]); } } return @$ref if wantarray; return $ref; } sub _daemon_peer_eob { my $self = shift; my $peer_id = shift || return; my $peer = shift || return; my $ref = [ ]; $self->send_event("daemon_eob", $peer); return @$ref if wantarray; return $ref; } sub _daemon_peer_kill { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if ($self->state_peer_exists($args->[0])) { last SWITCH; } if (!$self->state_nick_exists($args->[0])) { last SWITCH; } my $target = $self->state_user_nick($args->[0]); my $comment = $args->[1]; if ($self->_state_is_local_user($target)) { my $route_id = $self->_state_user_route($target); $self->send_output( { prefix => $nick, command => 'KILL', params => [ $target, join('!', $server, $comment), ], }, grep { $_ ne $peer_id } $self->_state_connected_peers() ); $self->send_output( { prefix => $self->state_user_full($nick), command => 'KILL', params => [ $target, join('!', $server, $comment), ], }, $route_id, ); if ($route_id eq 'spoofed') { $self->call( 'del_spoofed_nick', $target, "Killed ($comment)", ); } else { $self->{state}{conns}{$route_id}{killed} = 1; $self->_terminate_conn_error( $route_id, "Killed ($comment)", ); } } else { $self->{state}{users}{uc_irc($target)}{killed} = 1; $self->send_output( { prefix => $nick, command => 'KILL', params => [$target, join('!', $server, $comment)], }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_output( @{ $self->_daemon_peer_quit( $target, "Killed ($nick ($comment))" ) }, ); } } return @$ref if wantarray; return $ref; } sub _daemon_peer_svinfo { my $self = shift; my $peer_id = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; $self->{state}{conns}{$peer_id}{svinfo} = $args; return @$ref if wantarray; return $ref; } sub _daemon_peer_ping { my $self = shift; my $peer_id = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count) { last SWITCH; } if ($count >= 2 && uc $server ne uc $args->[1]) { $self->send_output( { command => 'PING', params => $args, }, $self->_state_peer_route($args->[1]), ) if $self->state_peer_exists($args->[1]); $self->send_output( { command => 'PING', params => $args, }, $self->_state_user_route($args->[1]), ) if $self->state_nick_exists($args->[1]); last SWITCH; } $self->send_output( { command => 'PONG', params => [$server, $args->[0]], }, $peer_id, ); } return @$ref if wantarray; return $ref; } sub _daemon_peer_pong { my $self = shift; my $peer_id = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count) { last SWITCH; } if ($count >= 2 && uc $self->server_name() ne uc $args->[1]) { $self->send_output( { command => 'PONG', params => $args, }, $self->_state_peer_route($args->[1]), ) if $self->state_peer_exists($args->[1]); $self->send_output( { command => 'PONG', params => $args, }, $self->_state_user_route($args->[1]), ) if $self->state_nick_exists($args->[1]); last SWITCH; } delete $self->{state}{conns}{$peer_id}{pinged}; } return @$ref if wantarray; return $ref; } sub _daemon_peer_server { my $self = shift; my $peer_id = shift || return; my $prefix = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; my $peer = $self->{state}{conns}{$peer_id}{name}; SWITCH: { if (!$count || $count < 2) { last SWITCH; } if ($self->state_peer_exists($args->[0])) { $self->_terminate_conn_error($peer_id, 'Server exists'); last SWITCH; } my $record = { name => $args->[0], hops => $args->[1], desc => ( $args->[2] || '' ), route_id => $peer_id, type => 'r', peer => $prefix, peers => { }, users => { }, }; my $uname = uc $record->{name}; $self->{state}{peers}{$uname} = $record; $self->{state}{peers}{uc $prefix}{peers}{$uname} = $record; $self->send_output( { prefix => $prefix, command => 'SERVER', params => [ $record->{name}, $record->{hops} + 1, $record->{desc}, ], }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_event( "daemon_server", $record->{name}, $prefix, $record->{hops}, $record->{desc}, ); } return @$ref if wantarray; return $ref; } sub _daemon_peer_quit { my $self = shift; my $nick = shift || return; my $qmsg = shift || 'Client Quit'; my $conn_id = shift; my $ref = [ ]; my $full = $self->state_user_full($nick); $nick = uc_irc($nick); my $record = delete $self->{state}{users}{$nick}; return $ref if !$record; $self->send_output( { prefix => $record->{nick}, command => 'QUIT', params => [$qmsg], }, grep { !$conn_id || $_ ne $conn_id } $self->_state_connected_peers(), ) if !$record->{killed}; push @$ref, { prefix => $full, command => 'QUIT', params => [$qmsg], }; $self->send_event("daemon_quit", $full, $qmsg); # Remove for peoples accept lists delete $self->{state}{users}{$_}{accepts}{uc_irc($nick)} for keys %{ $record->{accepts} }; # Okay, all 'local' users who share a common channel with user. my $common = { }; for my $uchan (keys %{ $record->{chans} }) { delete $self->{state}{chans}{$uchan}{users}{$nick}; for my $user ($self->state_chan_list($uchan)) { next if !$self->_state_is_local_user($user); $common->{$user} = $self->_state_user_route($user); } if (!keys %{ $self->{state}{chans}{$uchan}{users} }) { delete $self->{state}{chans}{$uchan}; } } push @$ref, $common->{$_} for keys %$common; $self->{state}{stats}{ops_online}-- if $record->{umode} =~ /o/; $self->{state}{stats}{invisible}-- if $record->{umode} =~ /i/; delete $self->{state}{peers}{uc $record->{server}}{users}{$nick}; return @$ref if wantarray; return $ref; } sub _daemon_peer_nick { my $self = shift; my $peer_id = shift || return; my $prefix = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; my $peer = $self->{state}{conns}{$peer_id}{name}; my $nicklen = $self->server_config('NICKLEN'); SWITCH: { if (!$count || $count < 8 && !$prefix) { $self->_terminate_conn_error( $peer_id, 'Not enough arguments to server command.', ); last SWITCH; } if ($prefix && $self->state_nick_exists($args->[0])) { $self->send_output( { prefix => $server, command => 'KILL', params => [$args->[0], "$server (Nick exists)"], }, $peer_id, ); my $unick = uc_irc($prefix); $self->{state}{users}{$unick}{nick_collision} = 1; $self->daemon_server_kill($prefix, 'Nick Collision', $peer_id); last SWITCH; } if ($prefix && length($args->[0]) > $nicklen) { $self->send_output( { prefix => $server, command => 'KILL', params => [$args->[0], "$server (Bad nickname)"], }, $peer_id, ); my $unick = uc_irc($prefix); $self->{state}{users}{$unick}{nick_collision} = 1; $self->daemon_server_kill($prefix, 'Nick Collision', $peer_id); last SWITCH; } if ($prefix) { my $full = $self->state_user_full($prefix); my $unick = uc_irc($prefix); my $new = $args->[0]; my $unew = uc_irc($new); my $ts = $args->[1] || time; my $record = $self->{state}{users}{$unick}; my $server = uc $record->{server}; if ($unick eq $unew) { $record->{nick} = $new; $record->{ts} = $ts; } else { $record->{nick} = $new; $record->{ts} = $ts; # Remove from peoples accept lists delete $self->{state}{users}{$_}{accepts}{$unick} for keys %{ $record->{accepts} }; delete $record->{accepts}; delete $self->{state}{users}{$unick}; $self->{state}{users}{$unew} = $record; delete $self->{state}{peers}{$server}{users}{$unick}; $self->{state}{peers}{$server}{users}{$unew} = $record; for my $chan (keys %{ $record->{chans} }) { $self->{state}{chans}{$chan}{users}{$unew} = delete $self->{state}{chans}{$chan}{users}{$unick}; } } my $common = { }; for my $chan (keys %{ $record->{chans} }) { for my $user ($self->state_chan_list($chan)) { next if !$self->_state_is_local_user($user); $common->{$user} = $self->_state_user_route($user); } } $self->send_output( { prefix => $prefix, command => 'NICK', params => $args, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_output( { prefix => $full, command => 'NICK', params => [$new], }, map{ $common->{$_} } keys %{ $common }, ); $self->send_event("daemon_nick", $full, $new); last SWITCH; } if ($self->state_nick_exists($args->[0]) and my ($nick, $userhost) = split /!/, $self->state_user_full($args->[0])) { my $unick = uc_irc $nick; my $incoming = join '@', @{ $args }[4..5]; if ($userhost eq $incoming) { my $ts = $self->{state}{users}{$unick}{ts}; if ($args->[2] > $ts) { $self->{state}{users}{$unick}{nick_collision} = 1; $self->daemon_server_kill( $nick, 'Nick Collision', $peer_id, ); } else { last SWITCH; } } else { my $ts = $self->{state}{users}{$unick}{ts}; if ($args->[2] < $ts) { $self->{state}{users}{$unick}{nick_collision} = 1; $self->daemon_server_kill( $nick, 'Nick Collision', $peer_id, ); } else { last SWITCH; } } } if (!$self->state_peer_exists($args->[6])) { last SWITCH; } if (length( $args->[0] ) > $nicklen) { $self->send_output( { prefix => $server, command => 'KILL', params => [$args->[0], "$server (Bad nickname)"], }, $peer_id, ); last SWITCH; } my $unick = uc_irc($args->[0]); $args->[3] =~ s/^\+//g; my $record = { nick => $args->[0], hops => $args->[1], ts => $args->[2], type => 'r', umode => $args->[3], auth => { ident => $args->[4], hostname => $args->[5], }, route_id => $peer_id, server => $args->[6], ircname => ( $args->[7] || '' ), }; $self->{state}{users}{ $unick } = $record; $self->{state}{stats}{ops_online}++ if $record->{umode} =~ /o/; $self->{state}{stats}{invisible}++ if $record->{umode} =~ /i/; $self->{state}{peers}{uc $record->{server}}{users}{$unick} = $record; $self->_state_update_stats(); $self->send_output( { command => 'NICK', params => $args, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_event("daemon_nick", @$args); } return @$ref if wantarray; return $ref; } sub _daemon_peer_part { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $chan = shift; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$chan) { last SWITCH; } if (!$self->state_chan_exists($chan)) { last SWITCH; } if (!$self->state_is_chan_member($nick, $chan)) { last SWITCH; } $self->_send_output_to_channel( $chan, { prefix => $self->state_user_full($nick), command => 'PART', params => [$chan, ($args->[0] || $nick)], }, $peer_id, ); $nick = uc_irc($nick); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$nick}; delete $self->{state}{users}{$nick}{chans}{$chan}; if (!keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub _daemon_peer_kick { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count || $count < 2) { last SWITCH; } my $chan = (split /,/, $args->[0])[0]; my $who = (split /,/, $args->[1])[0]; if (!$self->state_chan_exists($chan)) { last SWITCH; } $chan = $self->_state_chan_name($chan); if ( !$self->state_nick_exists($who)) { last SWITCH; } $who = $self->state_user_nick($who); if (!$self->state_is_chan_op($nick, $chan)) { last SWITCH; } if (!$self->state_is_chan_member($who, $chan)) { last SWITCH; } my $comment = $args->[2] || $who; $self->_send_output_to_channel( $chan, { prefix => $self->state_user_full($nick), command => 'KICK', params => [$chan, $who, $comment], }, $peer_id, ); $who = uc_irc($who); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$who}; delete $self->{state}{users}{$who}{chans}{$chan}; if (! keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub _daemon_peer_sjoin { my $self = shift; my $peer_id = shift || return; my $prefix = shift; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; #my $peer = $self->{state}{conns}{$peer_id}{name}; SWITCH: { if (!$count || $count < 4) { last SWITCH; } my $ts = $args->[0]; my $chan = $args->[1]; my $nicks = pop @{ $args }; my $ignore_modes = 0; if (!$self->state_chan_exists($chan)) { my $server = $self->server_name(); my $chanrec = { name => $chan, ts => $ts }; my @args = @{ $args }[2..$#{ $args }]; my $cmode = shift @args; $cmode =~ s/^\+//g; $chanrec->{mode} = $cmode; for my $mode (split //, $cmode) { my $arg; $arg = shift @args if $mode =~ /[lk]/; $chanrec->{climit} = $arg if $mode eq 'l'; $chanrec->{ckey} = $arg if $mode eq 'k'; } push @$args, $nicks; my $uchan = uc_irc($chanrec->{name}); for my $nick (split /\s+/, $nicks) { my $umode = ''; $umode .= 'o' if $nick =~ s/\@//g; $umode = 'h' if $nick =~ s/\%//g; $umode .= 'v' if $nick =~ s/\+//g; my $unick = uc_irc($nick); $chanrec->{users}{$unick} = $umode; $self->{state}{users}{$unick}{chans}{$uchan} = $umode; $self->send_event( "daemon_join", $self->state_user_full($nick), $chan, ); $self->send_event( "daemon_mode", $server, $chan, '+' . $umode, $nick, ) if $umode; } $self->{state}{chans}{$uchan} = $chanrec; $self->send_output( { prefix => $prefix, command => 'SJOIN', params => $args, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); last SWITCH; } my $chanrec = $self->{state}{chans}{uc_irc($chan)}; my @local_users = map { $self->_state_user_route($_) } grep { $self->_state_is_local_user($_) } keys %{ $chanrec->{users} }; if ($ts < $chanrec->{ts}) { # Incoming is older if ($nicks =~ /^\@/) { # Remove all modes expect bans/invex/excepts # deop/dehalfop/devoice all existing users my @deop; my @deop_list; my $common = { }; for my $user (keys %{ $chanrec->{users} }) { $common->{$user} = $self->_state_user_route($user) if $self->_state_is_local_user($user); next if !$chanrec->{users}{$user}; my $current = $chanrec->{users}{$user}; my $proper = $self->state_user_nick($user); $chanrec->{users}{$user} = ''; $self->{state}{users}{$user}{chans}{uc_irc($chanrec->{name})} = ''; push @deop, "-$current"; push @deop_list, $proper for split //, $current; } if (keys %$common && @deop) { my $server = $self->server_name(); $self->send_event( "daemon_mode", $server, $chanrec->{name}, unparse_mode_line(join '', @deop), @deop_list, ); my @output_modes; my $length = length($server) + 4 + length($chan) + 4; my @buffer = ('', ''); for my $deop (@deop) { my $arg = shift @deop_list; my $mode_line = unparse_mode_line($buffer[0].$deop); if (length(join ' ', $mode_line, $buffer[1], $arg) + $length > 510) { push @output_modes, { prefix => $server, command => 'MODE', colonify => 0, params => [ $chanrec->{name}, $buffer[0], split /\s+/, $buffer[1], ], }; $buffer[0] = $deop; $buffer[1] = $arg; next; } $buffer[0] = $mode_line; if ($buffer[1]) { $buffer[1] = join ' ', $buffer[1], $arg; } else { $buffer[1] = $arg; } } push @output_modes, { prefix => $server, command => 'MODE', colonify => 0, params => [ $chanrec->{name}, $buffer[0], split /\s+/, $buffer[1], ], }; $self->send_output($_, values %$common) for @output_modes; } my $origmode = $chanrec->{mode}; my @args = @{ $args }[2..$#{ $args }]; my $chanmode = shift @args; my $reply = ''; my @reply_args; for my $mode (grep { $_ ne '+' } split //, $chanmode) { my $arg; $arg = shift @args if $mode =~ /[lk]/; if ($mode eq 'l' && ($chanrec->{mode} !~ /l/ || $arg ne $chanrec->{climit})) { $reply .= '+' . $mode; push @reply_args, $arg; if ($chanrec->{mode} !~ /$mode/) { $chanrec->{mode} .= $mode; } $chanrec->{mode} = join '', sort split //, $chanrec->{mode}; $chanrec->{climit} = $arg; } elsif ($mode eq 'k' && ($chanrec->{mode} !~ /k/ || $arg ne $chanrec->{ckey})) { $reply .= '+' . $mode; push @reply_args, $arg; if ($chanrec->{mode} !~ /$mode/) { $chanrec->{mode} .= $mode; } $chanrec->{mode} = join '', sort split //, $chanrec->{mode}; $chanrec->{ckey} = $arg; } elsif ($chanrec->{mode} !~ /$mode/) { $reply .= '+' . $mode; $chanrec->{mode} = join '', sort split //, $chanrec->{mode}; } } if (keys %$common && ($reply || $origmode)) { $origmode = join '', grep { $chanmode !~ /$_/ } split //, ($origmode || ''); $chanrec->{mode} =~ s/[$origmode]//g if $origmode; $reply = '-' . $origmode . $reply if $origmode; if ($origmode && $origmode =~ /k/) { unshift @reply_args, '*'; delete $chanrec->{ckey}; } if ($origmode and $origmode =~ /l/) { delete $chanrec->{climit}; } $self->send_output( { prefix => $self->server_name(), command => 'MODE', colonify => 0, params => [ $chanrec->{name}, unparse_mode_line($reply), @reply_args, ], }, values %$common, ) if $reply; } # NOTICE HERE $self->send_output( { prefix => $self->server_name(), command => 'NOTICE', params => [ $chanrec->{name}, "*** Notice -- TS for " . $chanrec->{name} . " changed from " . $chanrec->{ts} . " to $ts", ], }, @local_users, ); $chanrec->{ts} = $ts; } elsif (grep { /^\@/ } $self->state_chan_list_prefixed($chan)) { $args->[0] = $chanrec->{ts}; } else { # NOTICE HERE $self->send_output( { prefix => $self->server_name(), command => 'NOTICE', params => [ $chanrec->{name}, "*** Notice -- TS for " . $chanrec->{name} . " changed from " . $chanrec->{ts} . " to $ts", ], }, @local_users, ); $chanrec->{ts} = $ts; } } elsif ($ts > $chanrec->{ts}) { # Incoming is younger if ($nicks !~ /^\@/) { $args->[0] = $chanrec->{ts}; } elsif (grep { /^\@/ } $self->state_chan_list_prefixed($chan)) { pop @$args while $#{ $args } > 2; $args->[2] = '+'; $args->[0] = $chanrec->{ts}; $nicks = join ' ', map { my $s = $_; $s =~ s/[@%+]//g; $s; } split /\s+/, $nicks; } else { $chanrec->{ts} = $ts; } } # Propagate SJOIN to connected peers except the one that told us. push @$args, $nicks; $self->send_output( { prefix => $prefix, command => 'SJOIN', params => $args, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); # Generate appropriate JOIN messages for all local # channel members my $uchan = uc_irc($chanrec->{name}); #my @local_users = map { $self->_state_user_route($_) } # grep { $self->_state_is_local_user($_) } # keys %{ $chanrec->{users} }; my $modes; my @mode_parms; for my $nick (split /\s+/, $nicks) { my $proper = $nick; $proper =~ s/[@%+]//g; $nick = uc_irc($nick); my $umode = ''; my @op_list; $umode .= 'o' if $nick =~ s/\@//g; $umode = 'h' if $nick =~ s/\%//g; $umode .= 'v' if $nick =~ s/\+//g; $chanrec->{users}{$nick} = $umode; $self->{state}{users}{$nick}{chans}{$uchan} = $umode; push @op_list, $proper for split //, $umode; my $output = { prefix => $self->state_user_full($nick), command => 'JOIN', params => [$chanrec->{name}], }; $self->send_output($output, @local_users); $self->send_event( "daemon_join", $output->{prefix}, $chanrec->{name}, ); if ($umode) { $modes .= $umode; push @mode_parms, @op_list; } } if ($modes) { my $server = $self->server_name(); $self->send_event( "daemon_mode", $server, $chanrec->{name}, '+' . $modes, @mode_parms, ); my @output_modes; my $length = length($server) + 4 + length($chan) + 4; my @buffer = ('+', ''); for my $umode (split //, $modes) { my $arg = shift @mode_parms; if (length(join ' ', @buffer, $arg) + $length > 510) { push @output_modes, { prefix => $server, command => 'MODE', colonify => 0, params => [ $chanrec->{name}, $buffer[0], split /\s+/, $buffer[1], ], }; $buffer[0] = "+$umode"; $buffer[1] = $arg; next; } $buffer[0] .= $umode; if ($buffer[1]) { $buffer[1] = join ' ', $buffer[1], $arg; } else { $buffer[1] = $arg; } } push @output_modes, { prefix => $server, command => 'MODE', colonify => 0, params => [ $chanrec->{name}, $buffer[0], split /\s+/, $buffer[1], ], }; $self->send_output($_, @local_users) for @output_modes; } } return @$ref if wantarray; return $ref; } sub _daemon_peer_mode { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $chan = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = scalar @$args; SWITCH: { if (!$self->state_chan_exists($chan)) { last SWITCH; } my $record = $self->{state}{chans}{uc_irc($chan)}; $chan = $record->{name}; my $full; $full = $self->state_user_full($nick) if $self->state_nick_exists($nick); my $reply; my @reply_args; my $parsed_mode = parse_mode_line(@$args); while (my $mode = shift (@{ $parsed_mode->{modes} })) { my $arg; $arg = shift @{ $parsed_mode->{args} } if $mode =~ /^(\+[ohvklbIe]|-[ohvbIe])/; if (my ($flag,$char) = $mode =~ /^(\+|-)([ohv])/) { if ($flag eq '+' && $record->{users}{uc_irc($arg)} !~ /$char/) { # Update user and chan record $arg = uc_irc($arg); next if $mode eq '+h' && $record->{users}{$arg} =~ /o/; if ($char eq 'h' && $record->{users}{$arg} =~ /v/) { $record->{users}{$arg} =~ s/v//g; $reply .= '-v'; push @reply_args, $self->state_user_nick($arg); } if ($char eq 'o' && $record->{users}{$arg} =~ /h/) { $record->{users}{$arg} =~ s/h//g; $reply .= '-h'; push @reply_args, $self->state_user_nick($arg); } $record->{users}{$arg} = join('', sort split //, $record->{users}{$arg} . $char); $self->{state}{users}{$arg}{chans}{uc_irc($chan)} = $record->{users}{$arg}; $reply .= "+$char"; push @reply_args, $self->state_user_nick($arg); } if ($flag eq '-' && $record->{users}{uc_irc($arg)} =~ /$char/) { # Update user and chan record $arg = uc_irc($arg); $record->{users}{$arg} =~ s/$char//g; $self->{state}{users}{$arg}{chans}{uc_irc($chan)} = $record->{users}{$arg}; $reply .= "-$char"; push @reply_args, $self->state_user_nick($arg); } next; } if ($mode eq '+l' && $arg =~ /^\d+$/ && $arg > 0) { $record->{mode} = join('', sort split //, $record->{mode} . 'l' ) if $record->{mode} !~ /l/; $record->{climit} = $arg; $reply .= '+l'; push @reply_args, $arg; next; } if ($mode eq '-l' && $record->{mode} =~ /l/) { $record->{mode} =~ s/l//g; delete $record->{climit}; $reply .= '-l'; next; } if ($mode eq '+k' && $arg) { $record->{mode} = join('', sort split //, $record->{mode} . 'k') if $record->{mode} !~ /k/; $record->{ckey} = $arg; $reply .= '+k'; push @reply_args, $arg; next; } if ($mode eq '-k' && $record->{mode} =~ /k/) { $record->{mode} =~ s/k//g; delete $record->{ckey}; $reply .= '-k'; next; } # Bans if (my ($flag) = $mode =~ /(\+|-)b/) { my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{bans}{$umask} ) { $record->{bans}{$umask} = [$mask, ($full || $server), time]; $reply .= '+b'; push @reply_args, $mask; } if ($flag eq '-' && $record->{bans}{$umask}) { delete $record->{bans}{$umask}; $reply .= '-b'; push @reply_args, $mask; } next; } # Invex if (my ($flag) = $mode =~ /(\+|-)I/) { my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{invex}{$umask}) { $record->{invex}{$umask} = [$mask, ($full || $server), time]; $reply .= '+I'; push @reply_args, $mask; } if ($flag eq '-' && $record->{invex}{$umask}) { delete $record->{invex}{$umask}; $reply .= '-I'; push @reply_args, $mask; } next; } # Exceptions if (my ($flag) = $mode =~ /(\+|-)e/) { my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{excepts}{$umask}) { $record->{excepts}{$umask} = [$mask, ($full || $server), time]; $reply .= '+e'; push @reply_args, $mask; } if ($flag eq '-' && $record->{excepts}{$umask}) { delete $record->{excepts}{$umask}; $reply .= '-e'; push @reply_args, $mask; } next; } # The rest should be argumentless. my ($flag, $char) = split //, $mode; if ( $flag eq '+' && $record->{mode} !~ /$char/) { $record->{mode} = join('', sort split //, $record->{mode} . $char); $reply .= "+$char"; next; } if ($flag eq '-' && $record->{mode} =~ /$char/) { $record->{mode} =~ s/$char//g; $reply .= "-$char"; next; } } # while unshift @$args, $record->{name}; if ($reply) { my $parsed_line = unparse_mode_line($reply); $self->send_output( { prefix => $nick, command => 'MODE', colonify => 0, params => [ $record->{name}, $parsed_line, @reply_args, ], }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_output( { prefix => ($full || $server), command => 'MODE', colonify => 0, params => [ $record->{name}, $parsed_line, @reply_args, ], }, map { $self->_state_user_route($_) } grep { $self->_state_is_local_user($_) } keys %{ $record->{users} }, ); $self->send_event( "daemon_mode", ($full || $server), $record->{name}, $parsed_line, @reply_args, ); } } # SWITCH return @$ref if wantarray; return $ref; } sub _daemon_peer_umode { my $self = shift; my $peer_id = shift || return; my $prefix = shift || return; my $nick = shift || return; my $umode = shift; my $server = $self->server_name(); my $ref = [ ]; my $record = $self->{state}{users}{uc_irc($nick)}; my $parsed_mode = parse_mode_line($umode); while (my $mode = shift @{ $parsed_mode->{modes} }) { my ($action, $char) = split //, $mode; if ($action eq '+' && $record->{umode} !~ /$char/) { $record->{umode} .= $char; $self->{state}{stats}{invisible}++ if $char eq 'i'; if ($char eq 'o') { $self->{state}{stats}{ops_online}++; } } if ($action eq '-' && $record->{umode} =~ /$char/) { $record->{umode} =~ s/$char//g; $self->{state}{stats}{invisible}-- if $char eq 'i'; if ($char eq 'o') { $self->{state}{stats}{ops_online}--; } } } $self->send_output( { prefix => $prefix, command => 'MODE', params => [$nick, $umode], }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); $self->send_event( "daemon_umode", $self->state_user_full($nick), $umode, ); return @$ref if wantarray; return $ref; } sub _daemon_peer_message { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $type = shift || return; my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count) { push @$ref, ['461', $type]; last SWITCH; } if ($count < 2 || !$args->[1]) { push @$ref, ['412']; last SWITCH; } my $targets = 0; my $max_targets = $self->server_config('MAXTARGETS'); my $full = $self->state_user_full($nick); my $targs = $self->_state_parse_msg_targets($args->[0]); LOOP: for my $target (keys %$targs) { my $targ_type = shift @{ $targs->{$target} }; if ($targ_type =~ /(server|host)mask/ && !$self->state_user_is_operator($nick)) { push @$ref, ['481']; next LOOP; } if ($targ_type =~ /(server|host)mask/ && $targs->{$target}[0] !~ /\./) { push @$ref, ['413', $target]; next LOOP; } if ($targ_type =~ /(server|host)mask/ && $targs->{$target}[0] !~ /\x2E.*[\x2A\x3F]+.*$/) { push @$ref, ['414', $target]; next LOOP; } if ($targ_type eq 'channel_ext' && !$self->state_chan_exists($targs->{$target}[1])) { push @$ref, ['401', $targs->{$target}[1]]; next LOOP; } if ($targ_type eq 'channel' && !$self->state_chan_exists($target)) { push @$ref, ['401', $target]; next LOOP; } if ($targ_type eq 'nick' && !$self->state_nick_exists($target)) { push @$ref, ['401', $target]; next LOOP; } if ($targ_type eq 'nick_ext' && !$self->state_peer_exists($targs->{$target}[1])) { push @$ref, ['402', $targs->{$target}[1]]; next LOOP; } $targets++; if ($targets > $max_targets) { push @$ref, ['407', $target]; last SWITCH; } # $$whatever if ($targ_type eq 'servermask') { my $us = 0; my %targets; my $ucserver = uc $self->server_name(); for my $peer (keys %{ $self->{state}{peers} }) { if (matches_mask($targs->{$target}[0], $peer)) { if ($ucserver eq $peer) { $us = 1; } else { $targets{ $self->_state_peer_route($peer) }++; } } } delete $targets{$peer_id}; $self->send_output( { prefix => $nick, command => $type, params => [$target, $args->[1]], }, keys %targets, ); if ($us) { my $local = $self->{state}{peers}{uc $self->server_name()}{users}; my @local; my $spoofed = 0; for my $luser (values %$local) { if ($luser->{route_id} eq 'spoofed') { $spoofed = 1; } else { push @local, $luser->{route_id}; } } $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, @local, ); $self->send_event( "daemon_" . lc $type, $full, $target, $args->[1], ) if $spoofed; } next LOOP; } # $#whatever if ($targ_type eq 'hostmask') { my $spoofed = 0; my %targets; my @local; HOST: for my $luser (values %{ $self->{state}{users} }) { next HOST if !matches_mask( $targs->{$target}[0], $luser->{auth}{hostname}); if ($luser->{route_id} eq 'spoofed') { $spoofed = 1; } elsif ( $luser->{type} eq 'r') { $targets{$luser->{route_id}}++; } else { push @local, $luser->{route_id}; } } delete $targets{$peer_id}; $self->send_output( { prefix => $nick, command => $type, params => [$target, $args->[1]], }, keys %targets, ); $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, @local, ); $self->send_event( "daemon_" . lc $type, $full, $target, $args->[1], ) if $spoofed; next LOOP; } if ($targ_type eq 'nick_ext') { $targs->{$target}[1] = $self->_state_peer_name($targs->{$target}[1]); if ($targs->{$target}[2] && !$self->state_user_is_operator($nick)) { push @$ref, ['481']; next LOOP; } if ($targs->{$target}[1] ne $self->server_name()) { $self->send_output( { prefix => $nick, command => $type, params => [$target, $args->[1]], }, $self->_state_peer_route($targs->{$target}[1]), ); next LOOP; } if (uc $targs->{$target}[0] eq 'OPERS') { if (!$self->state_user_is_operator($nick)) { push @$ref, ['481']; next LOOP; } $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, keys %{ $self->{state}{localops} }, ); next LOOP; } my @local = $self->_state_find_user_host( $targs->{$target}[0], $targs->{$target}[2], ); if (@local == 1) { my $ref = shift @local; if ($ref->[0] eq 'spoofed') { $self->send_event( "daemon_" . lc $type, $full, $ref->[1], $args->[1], ); } else { $self->send_output( { prefix => $full, command => $type, params => [$target, $args->[1]], }, $ref->[0], ); } } else { push @$ref, ['407', $target]; next LOOP; } } my $channel; my $status_msg; if ($targ_type eq 'channel') { $channel = $self->_state_chan_name($target); } if ($targ_type eq 'channel_ext') { $channel = $self->_state_chan_name($targs->{target}[1]); $status_msg = $targs->{target}[0]; } if ($channel && $status_msg && !$self->state_user_chan_mode($nick, $channel)) { push @$ref, ['482', $target]; next LOOP; } if ($channel && $self->state_chan_mode_set($channel, 'n') && !$self->state_is_chan_member($nick, $channel)) { push @$ref, ['404', $channel]; next LOOP; } if ($channel && $self->state_chan_mode_set($channel, 'm') && !$self->state_user_chan_mode($nick, $channel)) { push @$ref, ['404', $channel]; next LOOP; } if ($channel && $self->_state_user_banned($nick, $channel) && !$self->state_user_chan_mode($nick, $channel)) { push @$ref, ['404', $channel]; next LOOP; } if ($channel) { my $common = { }; my $msg = { command => $type, params => [ ($status_msg ? $target : $channel), $args->[1], ], }; for my $member ($self->state_chan_list($channel, $status_msg)) { next if $self->_state_user_is_deaf($member); $common->{ $self->_state_user_route($member) }++; } delete $common->{$peer_id}; for my $route_id (keys %$common) { $msg->{prefix} = $nick; if ($self->_connection_is_client($route_id)) { $msg->{prefix} = $full; } if ($route_id ne 'spoofed') { $self->send_output($msg, $route_id); } else { my $tmsg = $type eq 'PRIVMSG' ? 'public' : 'notice'; $self->send_event( "daemon_$tmsg", $full, $channel, $args->[1], ); } } next LOOP; } my $server = $self->server_name(); if ($self->state_nick_exists($target)) { $target = $self->state_user_nick($target); if (my $away = $self->_state_user_away_msg($target)) { push @$ref, { prefix => $server, command => '301', params => [$nick, $target, $away], }; } my $targ_umode = $self->state_user_umode($target); # Target user has CALLERID on if ($targ_umode && $targ_umode =~ /[Gg]/) { my $targ_rec = $self->{state}{users}{uc_irc($target) }; if (($targ_umode =~ /G/ && ( !$self->state_users_share_chan($target, $nick) || !$targ_rec->{accepts}{uc_irc($nick)})) || ($targ_umode =~ /g/ && !$targ_rec->{accepts}{uc_irc($nick)})) { push @$ref, { prefix => $server, command => '716', params => [ $nick, $target, 'is in +g mode (server side ignore)', ], }; if (!$targ_rec->{last_caller} || (time - $targ_rec->{last_caller} ) >= 60) { my ($n, $uh) = split /!/, $self->state_user_full($nick); $self->send_output( { prefix => $server, command => '718', params => [ $target, "$n\[$uh\]", 'is messaging you, and you are umode +g.' ], }, $targ_rec->{route_id}, ) if $targ_rec->{route_id} ne 'spoofed'; push @$ref, { prefix => $server, command => '717', params => [ $nick, $target, 'has been informed that you messaged them.', ], }; } $targ_rec->{last_caller} = time(); next LOOP; } } my $msg = { prefix => $nick, command => $type, params => [$target, $args->[1]], }; my $route_id = $self->_state_user_route($target); if ($route_id eq 'spoofed') { $msg->{prefix} = $full; $self->send_event( "daemon_" . lc $type, $full, $target, $args->[1], ); } else { if ($self->_connection_is_client($route_id)) { $msg->{prefix} = $full; } $self->send_output($msg, $route_id); } next LOOP; } } } return @$ref if wantarray; return $ref; } sub _daemon_peer_topic { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH:{ if (!$count) { last SWITCH; } if (!$self->state_chan_exists($args->[0])) { last SWITCH; } my $chan_name = $self->_state_chan_name($args->[0]); my $record = $self->{state}{chans}{uc_irc($args->[0])}; $record->{topic} = [$args->[1], $self->state_user_full($nick), time]; $self->_send_output_to_channel( $args->[0], { prefix => $self->state_user_full($nick), command => 'TOPIC', params => [$chan_name, $args->[1]], }, $peer_id, ); } return @$ref if wantarray; return $ref; } sub _daemon_peer_invite { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count || $count < 3) { last SWITCH; } my ($who, $chan) = @$args; $who = $self->state_user_nick($who); $chan = $self->_state_chan_name($chan); my $local; if ($self->_state_is_local_user($who)) { my $record = $self->{state}{users}{uc_irc($who)}; $record->{invites}{uc_irc($chan)} = time; $local = 1; } my $route_id = $self->_state_user_route($who); my $output = { prefix => $self->state_user_full($nick), command => 'INVITE', params => [$who, $chan], colonify => 0, }; if ($route_id eq 'spoofed') { $self->send_event( "daemon_invite", $output->{prefix}, @{ $output->{params} }, ); } else { if (!$local) { $output->{prefix} = $nick; push @{ $output->{params} }, $args->[2]; } $self->send_output($output, $route_id); } } return @$ref if wantarray; return $ref; } sub _daemon_peer_away { my $self = shift; my $peer_id = shift || return; my $nick = shift || return; my $msg = shift; my $server = $self->server_name(); my $ref = [ ]; SWITCH: { my $record = $self->{state}{users}{uc_irc($nick)}; if (!$msg) { delete $record->{away}; $self->send_output( { prefix => $nick, command => 'AWAY', colonify => 0, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); last SWITCH; } $record->{away} = $msg; $self->send_output( { prefix => $nick, command => 'AWAY', params => [$msg], colonify => 0, }, grep { $_ ne $peer_id } $self->_state_connected_peers(), ); } return @$ref if wantarray; return $ref; } sub _state_create { my $self = shift; $self->_state_delete(); # Connection specific tables $self->{state}{conns} = { }; # IRC State specific $self->{state}{users} = { }; $self->{state}{peers} = { }; $self->{state}{chans} = { }; # Register ourselves as a peer. $self->{state}{peers}{uc $self->server_name()} = { name => $self->server_name(), hops => 0, desc => $self->{config}{SERVERDESC}, }; $self->{state}{stats} = { maxconns => 0, maxlocal => 0, maxglobal => 0, ops_online => 0, invisible => 0, cmds => { }, }; return 1; } sub _state_delete { my $self = shift; delete $self->{state}; return 1; } sub _state_update_stats { my $self = shift; my $server = $self->server_name(); my $global = keys %{ $self->{state}{users} }; my $local = keys %{ $self->{state}{peers}{uc $server}{users} }; $self->{state}{stats}{maxglobal} = $global if $global > $self->{state}{stats}{maxglobal}; $self->{state}{stats}{maxlocal} = $local if $local > $self->{state}{stats}{maxlocal}; return 1; } sub _state_conn_stats { my $self = shift; $self->{state}{stats}{conns_cumlative}++; my $conns = keys %{ $self->{state}{conns} }; $self->{state}{stats}{maxconns} = $conns if $conns > $self->{state}{stats}{maxconns}; return 1; } sub _state_cmd_stat { my $self = shift; my $cmd = shift || return; my $line = shift || return; my $remote = shift; my $record = $self->{state}{stats}{cmds}{$cmd} || { remote => 0, local => 0, bytes => 0, }; $record->{local}++ if !$remote; $record->{remote}++ if $remote; $record->{bytes} += length $line; $self->{state}{stats}{cmds}{$cmd} = $record; return 1; } sub _state_find_user_host { my $self = shift; my $luser = shift || return; my $host = shift || '*'; my $local = $self->{state}{peers}{uc $self->server_name()}{users}; my @conns; for my $user (values %$local) { if (matches_mask($host, $user->{auth}{hostname}) && matches_mask($luser, $user->{auth}{ident})) { push @conns, [$user->{route_id}, $user->{nick}]; } } return @conns; } sub _state_local_users_match_rkline { my $self = shift; my $luser = shift || return; my $host = shift || return; my $local = $self->{state}{peers}{uc $self->server_name()}{users}; my @conns; for my $user (values %$local) { next if $user->{route_id} eq 'spoofed'; next if $user->{umode} && $user->{umode} =~ /o/; if (($user->{socket}[0] =~ /$host/ || $user->{auth}{hostname} =~ /$host/) && $user->{auth}{ident} =~ /$luser/) { push @conns, $user->{route_id}; } } return @conns; } sub _state_local_users_match_gline { my $self = shift; my $luser = shift || return; my $host = shift || return; my $local = $self->{state}{peers}{uc $self->server_name()}{users}; my @conns; if (my $netmask = Net::Netmask->new2($host)) { for my $user (values %$local) { next if $user->{route_id} eq 'spoofed'; next if $user->{umode} && $user->{umode} =~ /o/; if ($netmask->match($user->{socket}[0]) && matches_mask($luser, $user->{auth}{ident})) { push @conns, $user->{route_id}; } } } else { for my $user (values %$local) { next if $user->{route_id} eq 'spoofed'; next if $user->{umode} && $user->{umode} =~ /o/; if ((matches_mask($host, $user->{socket}[0]) || matches_mask($host, $user->{auth}{hostname})) && matches_mask($luser, $user->{auth}{ident})) { push @conns, $user->{route_id}; } } } return @conns; } sub _state_user_matches_rkline { my $self = shift; my $conn_id = shift || return; my $record = $self->{state}{conns}{$conn_id}; my $host = $record->{auth}{hostname} || $record->{socket}[0]; my $user = $record->{auth}{ident} || "~" . $record->{user}; my $ip = $record->{socket}[0]; for my $gline (@{ $self->{state}{rklines} }) { if (($host =~ /$gline->{host}/ || $ip =~ /$gline->{host}/) && $user =~ /$gline->{user}/) { return 1; } } return 0; } sub _state_user_matches_kline { my $self = shift; my $conn_id = shift || return; my $record = $self->{state}{conns}{$conn_id}; my $host = $record->{auth}{hostname} || $record->{socket}[0]; my $user = $record->{auth}{ident} || "~" . $record->{user}; my $ip = $record->{socket}[0]; for my $gline (@{ $self->{state}{klines} }) { if (my $netmask = Net::Netmask->new2($gline->{host})) { if ($netmask->match($ip) && matches_mask($gline->{user}, $user)) { return 1; } } elsif ((matches_mask($gline->{host}, $host) || matches_mask($gline->{host}, $ip)) && matches_mask($gline->{user}, $user)) { return 1; } } return 0; } sub _state_user_matches_gline { my $self = shift; my $conn_id = shift || return; my $record = $self->{state}{conns}{$conn_id}; my $host = $record->{auth}{hostname} || $record->{socket}[0]; my $user = $record->{auth}{ident} || "~" . $record->{user}; my $ip = $record->{socket}[0]; for my $gline (@{ $self->{state}{glines} }) { if (my $netmask = Net::Netmask->new2($gline->{host})) { if ($netmask->match($ip) && matches_mask($gline->{user}, $user)) { return 1; } elsif ((matches_mask($gline->{host}, $host) || matches_mask($gline->{host}, $ip)) && matches_mask($gline->{user}, $user)) { return 1; } } } return 0; } sub _state_auth_client_conn { my $self = shift; my $conn_id = shift || return; if (!$self->{config}{auth} || !@{ $self->{config}{auth} }) { return 1; } my $record = $self->{state}{conns}{$conn_id}; my $host = $record->{auth}{hostname} || $record->{socket}[0]; my $user = $record->{auth}{ident} || "~" . $record->{user}; my $uh = join '@', $user, $host; my $ui = join '@', $user, $record->{socket}[0]; for my $auth (@{ $self->{config}{auth} }) { if (matches_mask($auth->{mask}, $uh) || matches_mask($auth->{mask}, $ui)) { if ($auth->{password} && (!$record->{pass} || $auth->{password} ne $record->{pass})) { return 0; } $record->{auth}{hostname} = $auth->{spoof} if $auth->{spoof}; if (!$record->{auth}{ident} && $auth->{no_tilde}) { $record->{auth}{ident} = $record->{user}; } return 1; } } return 0; } sub _state_auth_peer_conn { my $self = shift; my ($conn_id, $name, $pass) = @_; if (!$conn_id || !$self->_connection_exists($conn_id)) { return; } return if !$name || !$pass; my $peers = $self->{config}{peers}; if (!$peers->{uc $name} || $peers->{uc $name}{pass} ne $pass) { return 0; } my $conn = $self->{state}{conns}{$conn_id}; if (!$peers->{uc $name}{ipmask} && $conn->{socket}[0] =~ /^127\./) { return 1; } return 0 if !$peers->{uc $name}{ipmask}; my $client_ip = $conn->{socket}[0]; if (ref $peers->{uc $name}{ipmask} eq 'ARRAY') { for my $block (grep { $_->isa('Net::Netmask') } @{ $peers->{uc $name}{ipmask} }) { return 1 if $block->match($client_ip); } } return 1 if matches_mask( '*!*@'.$peers->{uc $name}{ipmask}, "*!*\@$client_ip", ); return 0; } sub _state_send_credentials { my $self = shift; my $conn_id = shift || return; my $name = shift || return; return if !$self->_connection_exists($conn_id); return if !$self->{config}{peers}{uc $name}; my $peer = $self->{config}{peers}{uc $name}; $self->send_output( { command => 'PASS', params => [$peer->{rpass}, 'TS'], }, $conn_id, ); $self->send_output( { command => 'CAPAB', params => [ join (' ', @{ $self->{config}{capab} }, ($peer->{zip} ? 'ZIP' : ()) ), ], }, $conn_id, ); my $rec = $self->{state}{peers}{uc $self->server_name()}; $self->send_output( { command => 'SERVER', params => [$rec->{name}, $rec->{hops} + 1, $rec->{desc}], }, $conn_id, ); $self->send_output( { command => 'SVINFO', params => [5, 5, 0, time], }, $conn_id, ); $self->{state}{conns}{$conn_id}{zip} = $peer->{zip}; return 1; } sub _state_send_burst { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); my $server = $self->server_name(); my $conn = $self->{state}{conns}{$conn_id}; my $burst = grep { /^EOB$/i } @{ $conn->{capab} }; my $invex = grep { /^IE$/i } @{ $conn->{capab} }; my $excepts = grep { /^EX$/i } @{ $conn->{capab} }; my %map = qw(bans b excepts e invex I); my @lists = qw(bans); push @lists, 'excepts' if $excepts; push @lists, 'invex' if $invex; # Send SERVER burst for ($self->_state_server_burst($server, $conn->{name})) { $self->send_output($_, $conn_id ); } # Send NICK burst for my $nick (keys %{ $self->{state}{users} }) { my $record = $self->{state}{users}{$nick}; next if $record->{route_id} eq $conn_id; my $umode_fixed = $record->{umode}; $umode_fixed =~ s/[^aiow]//g; my $arrayref = [ $record->{nick}, $record->{hops} + 1, $record->{ts}, '+' . $umode_fixed, $record->{auth}{ident}, $record->{auth}{hostname}, $record->{server}, $record->{ircname}, ]; $self->send_output( { command => 'NICK', params => $arrayref, }, $conn_id, ); } # Send SJOIN+MODE burst for my $chan (keys %{ $self->{state}{chans} }) { next if $chan =~ /^\&/; my $chanrec = $self->{state}{chans}{$chan}; my @nicks = map { $_->[1] } sort { $a->[0] cmp $b->[0] } map { my $w = $_; $w =~ tr/@%+/ABC/; [$w, $_] } $self->state_chan_list_prefixed($chan); my $arrayref2 = [ $chanrec->{ts}, $chanrec->{name}, '+' . $chanrec->{mode}, ($chanrec->{ckey} || ()), ($chanrec->{climit} || ()), join ' ', @nicks, ]; $self->send_output( { prefix => $server, command => 'SJOIN', params => $arrayref2, }, $conn_id, ); # TODO: MODE burst # Banlist|Exceptions|Invex my @output_modes; OUTER: for my $type (@lists) { my $length = length($server) + 4 + length($chan) + 4; my @buffer = ( '', '' ); INNER: for my $thing (keys %{ $chanrec->{$type} }) { $thing = $chanrec->{$type}{$thing}[0]; if (length(join ' ', @buffer, $thing)+$length+1 > 510) { $buffer[0] = '+' . $buffer[0]; push @output_modes, { prefix => $server, command => 'MODE', colonify => 0, params => [ $chanrec->{name}, $buffer[0], split /\s+/, $buffer[1], ], }; $buffer[0] = '+' . $map{$type}; $buffer[1] = $thing; next INNER; } if ($buffer[1]) { $buffer[0] .= $map{$type}; $buffer[1] = join ' ', $buffer[1], $thing; } else { $buffer[0] = '+' . $map{$type}; $buffer[1] = $thing; } } push @output_modes, { prefix => $server, command => 'MODE', colonify => 0, params => [ $chanrec->{name}, $buffer[0], split /\s+/, $buffer[1], ], } if $buffer[0]; } $self->send_output($_, $conn_id) for @output_modes; } $self->send_output( { prefix => $server, command => 'EOB', }, $conn_id, ) if $burst; return 1; } sub _state_server_burst { my $self = shift; my $peer = shift || return; my $targ = shift || return; if (!$self->state_peer_exists( $peer ) || !$self->state_peer_exists($targ)) { } my $ref = [ ]; $peer = $self->_state_peer_name($peer); my $upeer = uc $peer; my $utarg = uc $targ; for my $server (keys %{ $self->{state}{peers}{$upeer}{peers} }) { next if $server eq $utarg; my $rec = $self->{state}{peers}{$server}; push @$ref, { prefix => $peer, command => 'SERVER', params => [$rec->{name}, $rec->{hops} + 1, $rec->{desc}], }; push @$ref, $_ for $self->_state_server_burst($rec->{name}, $targ); } return @$ref if wantarray; return $ref; } sub _state_server_links { my $self = shift; my $peer = shift || return; my $orig = shift || return; my $nick = shift || return; return if !$self->state_peer_exists($peer); my $ref = [ ]; $peer = $self->_state_peer_name($peer); my $upeer = uc $peer; for my $server (keys %{ $self->{state}{peers}{$upeer}{peers} }) { my $rec = $self->{state}{peers}{$server}; for ($self->_state_server_links($rec->{name}, $orig, $nick)) { push @$ref, $_; } push @$ref, { prefix => $orig, command => '364', params => [ $nick, $rec->{name}, $peer, join( ' ', $rec->{hops}, $rec->{desc}), ], }; } return @$ref if wantarray; return $ref; } sub _state_peer_for_peer { my $self = shift; my $peer = shift || return; return if !$self->state_peer_exists($peer); $peer = uc $peer; return $self->{state}{peers}{$peer}{peer}; } sub _state_server_squit { my $self = shift; my $peer = shift || return; return if !$self->state_peer_exists($peer); my $ref = [ ]; my $upeer = uc $peer; push @$ref, $_ for keys %{ $self->{state}{peers}{$upeer}{users} }; for my $server (keys %{ $self->{state}{peers}{$upeer}{peers} }) { push @$ref, $_ for $self->_state_server_squit($server); } delete $self->{state}{peers}{$upeer}; delete $self->{state}{peers}{uc $self->server_name()}{peers}{$upeer}; return @$ref if wantarray; return $ref; } sub _state_register_peer { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); my $server = $self->server_name(); my $record = $self->{state}{conns}{$conn_id}; if (!$record->{cntr}) { $self->_state_send_credentials($conn_id, $record->{name}); } $record->{burst} = $record->{registered} = 1; $record->{type} = 'p'; $record->{route_id} = $conn_id; $record->{peer} = $server; $record->{users} = { }; $record->{peers} = { }; $self->{state}{peers}{uc $server}{peers}{uc $record->{name}} = $record; $self->{state}{peers}{ uc $record->{name} } = $record; $self->antiflood($conn_id, 0); $self->send_output( { prefix => $server, command => 'SERVER', params => [ $record->{name}, $record->{hops} + 1, $record->{desc}, ], }, grep { $_ ne $conn_id } $self->_state_connected_peers(), ); $self->send_event( "daemon_server", $record->{name}, $server, $record->{hops}, $record->{desc}, ); return 1; } sub _state_register_client { my $self = shift; my $conn_id = shift || return; return if !$self->_connection_exists($conn_id); my $record = $self->{state}{conns}{$conn_id}; $record->{ts} = $record->{idle_time} = $record->{conn_time} = time; $record->{_ignore_i_umode} = 1; $record->{server} = $self->server_name(); $record->{hops} = 0; $record->{route_id} = $conn_id; $record->{umode} = ''; if (!$record->{auth}{ident}) { $record->{auth}{ident} = '~' . $record->{user}; } if ($record->{auth}{hostname} eq 'localhost' || !$record->{auth}{hostname} && $record->{socket}[0] =~ /^127\./) { $record->{auth}{hostname} = $self->server_name(); } if (!$record->{auth}{hostname}) { $record->{auth}{hostname} = $record->{socket}[0]; } $self->{state}{users}{uc_irc($record->{nick})} = $record; $self->{state}{peers}{uc $record->{server}}{users}{uc_irc($record->{nick})} = $record; my $arrayref = [ $record->{nick}, $record->{hops} + 1, $record->{ts}, '+i', $record->{auth}{ident}, $record->{auth}{hostname}, $record->{server}, $record->{ircname}, ]; delete $self->{state}{pending}{uc_irc($record->{nick})}; $self->send_output( { command => 'NICK', params => $arrayref, }, $self->_state_connected_peers(), ); $self->send_event("daemon_nick", @$arrayref); $self->_state_update_stats(); return 1; } sub state_nicks { my $self = shift; return map { $self->{state}{users}{$_}{nick} } keys %{ $self->{state}{users} }; } sub state_nick_exists { my $self = shift; my $nick = shift || return 1; $nick = uc_irc($nick); if (!defined $self->{state}{users}{$nick} && !defined $self->{state}{pending}{$nick}) { return 0; } return 1; } sub state_chans { my $self = shift; return map { $self->{state}{chans}{$_}{name} } keys %{ $self->{state}{chans} }; } sub state_chan_exists { my $self = shift; my $chan = shift || return; return 0 if !defined $self->{state}{chans}{uc_irc($chan)}; return 1; } sub state_peers { my $self = shift; return map { $self->{state}{peers}{$_}{name} } keys %{ $self->{state}{peers} }; } sub state_peer_exists { my $self = shift; my $peer = shift || return; return 0 if !defined $self->{state}{peers}{uc $peer}; return 1; } sub _state_peer_name { my $self = shift; my $peer = shift || return; return if !$self->state_peer_exists($peer); return $self->{state}{peers}{uc $peer}{name}; } sub _state_peer_desc { my $self = shift; my $peer = shift || return; return if !$self->state_peer_exists($peer); return $self->{state}{peers}{uc $peer}{desc}; } sub _state_peer_capab { my $self = shift; my $conn_id = shift || return; my $capab = shift || return; $capab = uc $capab; return if !$self->_connection_is_peer($conn_id); my $conn = $self->{state}{conns}{$conn_id}; return scalar grep { $_ eq $capab } @{ $conn->{capab} }; } sub state_user_full { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); my $record = $self->{state}{users}{uc_irc($nick)}; return $record->{nick} . '!' . $record->{auth}{ident} . '@' . $record->{auth}{hostname}; } sub state_user_nick { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); return $self->{state}{users}{uc_irc($nick)}{nick}; } sub _state_user_ip { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick) || !$self->_state_is_local_user($nick); my $record = $self->{state}{users}{uc_irc($nick)}; return $record->{socket}[0]; } sub _state_user_away { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); return 1 if defined $self->{state}{users}{uc_irc($nick)}{away}; return 0; } sub _state_user_away_msg { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); return $self->{state}{users}{uc_irc($nick)}{away}; } sub state_user_umode { my $self = shift; my $nick = shift || return; return if! $self->state_nick_exists($nick); return $self->{state}{users}{uc_irc($nick)}{umode}; } sub state_user_is_operator { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); return 0 if $self->{state}{users}{uc_irc($nick)}{umode} !~ /o/; return 1; } sub _state_user_is_deaf { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); return 0 if $self->{state}{users}{uc_irc($nick)}{umode} !~ /D/; return 1; } sub state_user_chans { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); my $record = $self->{state}{users}{uc_irc($nick)}; return map { $self->{state}{chans}{$_}{name} } keys %{ $record->{chans} }; } sub _state_user_route { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); my $record = $self->{state}{users}{uc_irc($nick)}; return $record->{route_id}; } sub state_user_server { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); my $record = $self->{state}{users}{uc_irc($nick)}; return $record->{server}; } sub _state_peer_route { my $self = shift; my $peer = shift || return; return if !$self->state_peer_exists($peer); my $record = $self->{state}{peers}{uc $peer}; return $record->{route_id}; } sub _state_connected_peers { my $self = shift; my $server = uc $self->server_name(); return if !keys %{ $self->{state}{peers} } > 1; my $record = $self->{state}{peers}{$server}; return map { $record->{peers}{$_}{route_id} } keys %{ $record->{peers} }; } sub state_chan_list { my $self = shift; my $chan = shift || return; my $status_msg = shift || ''; return if !$self->state_chan_exists($chan); $status_msg =~ s/[^@%+]//g; my $record = $self->{state}{chans}{uc_irc($chan)}; return map { $self->{state}{users}{$_}{nick} } keys %{ $record->{users} } if !$status_msg; my %map = qw(o 3 h 2 v 1); my %sym = qw(@ 3 % 2 + 1); my $lowest = (sort map { $sym{$_} } split //, $status_msg)[0]; return map { $self->{state}{users}{$_}{nick} } grep { $record->{users}{ $_ } and (reverse sort map { $map{$_} } split //, $record->{users}{$_})[0] >= $lowest } keys %{ $record->{users} }; } sub state_chan_list_prefixed { my $self = shift; my $chan = shift || return; return if !$self->state_chan_exists($chan); my $record = $self->{state}{chans}{uc_irc($chan)}; return map { my $n = $self->{state}{users}{$_}{nick}; my $m = $record->{users}{$_}; my $p = ''; $p = '@' if $m =~ /o/; $p = '%' if $m =~ /h/ && !$p; $p = '+' if $m =~ /v/ && !$p; $p . $n; } keys %{ $record->{users} }; } sub _state_chan_timestamp { my $self = shift; my $chan = shift || return; return if !$self->state_chan_exists($chan); return $self->{state}{chans}{uc_irc($chan)}{ts}; } sub state_chan_topic { my $self = shift; my $chan = shift || return; return if !$self->state_chan_exists($chan); my $record = $self->{state}{chans}{uc_irc($chan)}; return if !$record->{topic}; return [@{ $record->{topic} }]; } sub _state_is_local_user { my $self = shift; my $nick = shift || return; return if !$self->state_nick_exists($nick); my $record = $self->{state}{peers}{uc $self->server_name()}; return 1 if defined $record->{users}{uc_irc($nick)}; return 0; } sub _state_chan_name { my $self = shift; my $chan = shift || return; return if !$self->state_chan_exists($chan); return $self->{state}{chans}{uc_irc($chan)}{name}; } sub state_chan_mode_set { my $self = shift; my $chan = shift || return; my $mode = shift || return; return if !$self->state_chan_exists($chan); $mode =~ s/[^a-zA-Z]+//g; $mode = (split //, $mode )[0] if length $mode > 1; my $record = $self->{state}{chans}{uc_irc($chan)}; return 1 if $record->{mode} =~ /$mode/; return 0; } sub _state_user_invited { my $self = shift; my $nick = shift || return; my $chan = shift || return; return if !$self->state_nick_exists($nick); return 0 if !$self->state_chan_exists($chan); my $nickrec = $self->{state}{users}{uc_irc($nick)}; return 1 if $nickrec->{invites}{uc_irc($chan)}; # Check if user matches INVEX return 1 if $self->_state_user_matches_list($nick, $chan, 'invex'); return 0; } sub _state_user_banned { my $self = shift; my $nick = shift || return; my $chan = shift || return; return 0 if !$self->_state_user_matches_list($nick, $chan, 'bans'); return 1 if !$self->_state_user_matches_list($nick, $chan, 'excepts'); return 0; } sub _state_user_matches_list { my $self = shift; my $nick = shift || return; my $chan = shift || return; my $list = shift || 'bans'; return if !$self->state_nick_exists($nick); return 0 if !$self->state_chan_exists($chan); my $full = $self->state_user_full($nick); my $record = $self->{state}{chans}{uc_irc($chan)}; for my $mask (keys %{ $record->{$list} }) { return 1 if matches_mask($mask, $full); } return 0; } sub state_is_chan_member { my $self = shift; my $nick = shift || return; my $chan = shift || return; return if !$self->state_nick_exists($nick); return 0 if !$self->state_chan_exists($chan); my $record = $self->{state}{users}{uc_irc($nick)}; return 1 if defined $record->{chans}{uc_irc($chan)}; return 0; } sub state_user_chan_mode { my $self = shift; my $nick = shift || return; my $chan = shift || return; return if !$self->state_is_chan_member($nick, $chan); return $self->{state}{users}{uc_irc($nick)}{chans}{uc_irc($chan)}; } sub state_is_chan_op { my $self = shift; my $nick = shift || return; my $chan = shift || return; return if !$self->state_is_chan_member($nick, $chan); my $record = $self->{state}{users}{uc_irc($nick)}; return 1 if $record->{chans}{uc_irc($chan)} =~ /o/; return 1 if $self->{config}{OPHACKS} && $record->{umode} =~ /o/; return 0; } sub state_is_chan_hop { my $self = shift; my $nick = shift || return; my $chan = shift || return; return if !$self->state_is_chan_member($nick, $chan); my $record = $self->{state}{users}{uc_irc($nick)}; return 1 if $record->{chans}{uc_irc($chan)} =~ /h/; return 0; } sub state_has_chan_voice { my $self = shift; my $nick = shift || return; my $chan = shift || return; return if !$self->state_is_chan_member($nick, $chan); my $record = $self->{state}{users}{uc_irc($nick)}; return 1 if $record->{chans}{uc_irc($chan)} =~ /v/; return 0; } sub _state_o_line { my $self = shift; my $nick = shift || return; my ($user, $pass) = @_; return if !$self->state_nick_exists($nick); return if !$user || !$pass; my $ops = $self->{config}{ops}; return if !$ops->{$user}; return -1 if !chkpasswd ($pass, $ops->{$user}{password}); my $client_ip = $self->_state_user_ip($nick); return if !$client_ip; if (!$ops->{$user}{ipmask} && ($client_ip && $client_ip =~ /^127\./)) { return 1; } return 0 if !$ops->{$user}{ipmask}; if (ref $ops->{$user}{ipmask} eq 'ARRAY') { for my $block (grep { $_->isa('Net::Netmask') } @{ $ops->{$user}{ipmask} }) { return 1 if $block->match($client_ip); } } return 1 if matches_mask($ops->{$user}{ipmask}, $client_ip); return 0; } sub _state_users_share_chan { my $self = shift; my $nick1 = shift || return; my $nick2 = shift || return; return if !$self->state_nick_exists($nick1) || !$self->state_nick_exists($nick2); my $rec1 = $self->{state}{users}{uc_irc($nick1)}; my $rec2 = $self->{state}{users}{uc_irc($nick2)}; for my $chan (keys %{ $rec1->{chans} }) { return 1 if $rec2->{chans}{$chan}; } return 0; } sub _state_parse_msg_targets { my $self = shift; my $targets = shift || return; my %results; for my $target (split /,/, $targets) { if ($target =~ /^[#&]/) { $results{$target} = ['channel']; next; } if ($target =~ /^([@%+]+)([#&].+)$/ ) { $results{$target} = ['channel_ext', $1, $2]; next; } if ( $target =~ /^\${2}(.+)$/ ) { $results{$target} = ['servermask', $1]; next; } if ( $target =~ /^\$#(.+)$/ ) { $results{$target} = ['hostmask', $1]; next; } if ($target =~ /@/ ) { my ($nick, $server) = split /@/, $target, 2; my $host; ($nick, $host) = split ( /%/, $nick, 2 ) if $nick =~ /%/; $results{$target} = ['nick_ext', $nick, $server, $host]; next; } $results{$target} = ['nick']; } return \%results; } sub server_name { return $_[0]->server_config('ServerName'); } sub server_version { return $_[0]->server_config('Version'); } sub server_created { return strftime("This server was created %a %h %d %Y at %H:%M:%S %Z", localtime($_[0]->server_config('created'))); } sub _client_nickname { my $self = shift; my $wheel_id = $_[0] || return; return '*' if !$self->{state}{conns}{$wheel_id}{nick}; return $self->{state}{conns}{$wheel_id}{nick}; } sub _client_ip { my $self = shift; my $wheel_id = shift || return ''; return $self->{state}{conns}{$wheel_id}{socket}[0]; } sub server_config { my $self = shift; my $value = shift || return; return $self->{config}{uc $value}; } sub configure { my $self = shift; my $opts = ref $_[0] eq 'HASH' ? $_[0] : { @_ }; $opts->{uc $_} = delete $opts->{$_} for keys %$opts; my %defaults = ( CREATED => time(), CASEMAPPING => 'rfc1459', SERVERNAME => 'poco.server.irc', SERVERDESC => 'Poco? POCO? POCO!', VERSION => do { no strict 'vars'; ref($self) . '-' . (defined $VERSION ? $VERSION : 'dev-git'); }, NETWORK => 'poconet', HOSTLEN => 63, NICKLEN => 9, USERLEN => 10, REALLEN => 50, KICKLEN => 120, TOPICLEN => 80, AWAYLEN => 160, CHANNELLEN => 50, PASSWDLEN => 20, KEYLEN => 23, MAXCHANNELS => 15, MAXACCEPT => 20, MODES => 4, MAXTARGETS => 4, MAXBANS => 25, MAXBANLENGTH => 1024, AUTH => 1, ANTIFLOOD => 1, WHOISACTUALLY => 1, OPHACKS => 0, ); $self->{config}{$_} = $defaults{$_} for keys %defaults; for my $opt (qw(HOSTLEN NICKLEN USERLEN REALLEN TOPICLEN CHANNELLEN PASSWDLEN KEYLEN MAXCHANNELS MAXACCEPT MODES MAXTARGETS MAXBANS)) { my $new = delete $opts->{$opt}; if (defined $new && $new > $self->{config}{$opt}) { $self->{config}{$opt} = $new; } } for my $opt (qw(KICKLEN AWAYLEN)) { my $new = delete $opts->{$opt}; if (defined $new && $new < $self->{config}{$opt}) { $self->{config}{$opt} = $new; } } for my $opt (keys %$opts) { $self->{config}{$opt} = $opts->{$opt} if defined $opts->{$opt}; } $self->{config}{BANLEN} = sum(@{ $self->{config} }{qw(NICKLEN USERLEN HOSTLEN)}, 3); $self->{config}{USERHOST_REPLYLEN} = sum(@{ $self->{config} }{qw(NICKLEN USERLEN HOSTLEN)}, 5); $self->{config}{SERVERNAME} =~ s/[^a-zA-Z0-9\-.]//g; if ($self->{config}{SERVERNAME} !~ /\./) { $self->{config}{SERVERNAME} .= '.'; } if (!defined $self->{config}{ADMIN} || ref $self->{config}{ADMIN} ne 'ARRAY' || @{ $self->{config}{ADMIN} } != 3) { $self->{config}{ADMIN} = []; $self->{config}{ADMIN}[0] = 'Somewhere, Somewhere, Somewhere'; $self->{config}{ADMIN}[1] = 'Some Institution'; $self->{config}{ADMIN}[2] = 'someone@somewhere'; } if (!defined $self->{config}{INFO} || ref $self->{config}{INFO} ne 'ARRAY' || !@{ $self->{config}{INFO} } == 1) { $self->{config}{INFO} = [split /\n/, <<'EOF']; # POE::Component::Server::IRC # # Author: Chris "BinGOs" Williams # # Filter-IRCD Written by Hachi # # This module may be used, modified, and distributed under the same # terms as Perl itself. Please see the license that came with your Perl # distribution for details. # EOF } $self->{Error_Codes} = { 401 => [1, "No such nick/channel"], 402 => [1, "No such server"], 403 => [1, "No such channel"], 404 => [1, "Cannot send to channel"], 405 => [1, "You have joined too many channels"], 406 => [1, "There was no such nickname"], 407 => [1, "Too many targets"], 408 => [1, "No such service"], 409 => [1, "No origin specified"], 411 => [0, "No recipient given (%s)"], 412 => [0, "No text to send"], 413 => [1, "No toplevel domain specified"], 414 => [1, "Wildcard in toplevel domain"], 415 => [1, "Bad server/host mask"], 421 => [1, "Unknown command"], 422 => [0, "MOTD File is missing"], 423 => [1, "No administrative info available"], 424 => [1, "File error doing % on %"], 431 => [1, "No nickname given"], 432 => [1, "Erroneous nickname"], 433 => [1, "Nickname is already in use"], 436 => [1, "Nickname collision KILL from %s\@%s"], 437 => [1, "Nick/channel is temporarily unavailable"], 441 => [1, "They aren\'t on that channel"], 442 => [1, "You\'re not on that channel"], 443 => [2, "is already on channel"], 444 => [1, "User not logged in"], 445 => [0, "SUMMON has been disabled"], 446 => [0, "USERS has been disabled"], 451 => [0, "You have not registered"], 461 => [1, "Not enough parameters"], 462 => [0, "Unauthorised command (already registered)"], 463 => [0, "Your host isn\'t among the privileged"], 464 => [0, "Password mismatch"], 465 => [0, "You are banned from this server"], 466 => [0, "You will be banned from this server"], 467 => [1, "Channel key already set"], 471 => [1, "Cannot join channel (+l)"], 472 => [1, "is unknown mode char to me for %s"], 473 => [1, "Cannot join channel (+i)"], 474 => [1, "Cannot join channel (+b)"], 475 => [1, "Cannot join channel (+k)"], 476 => [1, "Bad Channel Mask"], 477 => [1, "Channel doesn\'t support modes"], 478 => [2, "Channel list is full"], 481 => [0, "Permission Denied- You\'re not an IRC operator"], 482 => [1, "You\'re not channel operator"], 483 => [0, "You can\'t kill a server!"], 484 => [0, "Your connection is restricted!"], 485 => [0, "You\'re not the original channel operator"], 491 => [0, "No O-lines for your host"], 501 => [0, "Unknown MODE flag"], 502 => [0, "Cannot change mode for other users"], }; $self->{config}{isupport} = { INVEX => undef, EXCEPT => undef, CALLERID => undef, CHANTYPES => '#&', PREFIX => '(ohv)@%+', CHANMODES => 'eIb,k,l,imnpst', STATUSMSG => '@%+', DEAF => 'D', MAXLIST => 'beI:' . $self->{config}{MAXBANS}, map { ($_, $self->{config}{$_}) } qw(MAXCHANNELS MAXTARGETS NICKLEN TOPICLEN KICKLEN CASEMAPPING NETWORK MODES AWAYLEN), }; $self->{config}{capab} = [qw(QS EX CHW IE HOPS UNKLN KLN GLN EOB)]; return 1; } sub _send_output_to_client { my $self = shift; my $wheel_id = shift || return 0; my $nick = $self->_client_nickname($wheel_id); $nick = shift if $self->_connection_is_peer($wheel_id); my $err = shift || return 0; return if !$self->_connection_exists($wheel_id); SWITCH: { if (ref $err eq 'HASH') { $self->send_output($err, $wheel_id); last SWITCH; } if (defined $self->{Error_Codes}{$err}) { my $input = { command => $err, prefix => $self->server_name(), params => [$nick], }; if ($self->{Error_Codes}{$err}[0] > 0) { for (my $i = 1; $i <= $self->{Error_Codes}{$err}[0]; $i++) { push @{ $input->{params} }, shift; } } if ($self->{Error_Codes}{$err}[1] =~ /%/) { push @{ $input->{params} }, sprintf($self->{Error_Codes}{$err}[1], @_); } else { push @{ $input->{params} }, $self->{Error_Codes}{$err}[1]; } $self->send_output($input, $wheel_id); } } return 1; } sub _send_output_to_channel { my $self = shift; my $channel = shift || return; my $output = shift || return; my $conn_id = shift || ''; return if !$self->state_chan_exists($channel); # Get conn_ids for each of our peers. my $ref = [ ]; my $peers = { }; $peers->{$_}++ for $self->_state_connected_peers(); delete $peers->{$conn_id} if $conn_id; push @$ref, $self->_state_user_route($_) for grep { $self->_state_is_local_user($_) } $self->state_chan_list($channel); @$ref = grep { $_ ne $conn_id } @$ref; if ($channel !~ /^\&/ && scalar keys %$peers && $output->{command} ne 'JOIN') { my $full = $output->{prefix}; my $nick = (split /!/, $full)[0]; my $output2 = { %$output }; $output2->{prefix} = $nick; $self->send_output($output2, keys %$peers); } $self->send_output($output, @$ref); $self->send_event( "daemon_" . lc $output->{command}, $output->{prefix}, @{ $output->{params} }, ); return 1; } sub add_operator { my $self = shift; my $ref; if (ref $_[0] eq 'HASH') { $ref = $_[0]; } else { $ref = { @_ }; } $ref->{lc $_} = delete $ref->{$_} for keys %$ref; if (!defined $ref->{username} || !defined $ref->{password}) { warn "Not enough parameters\n"; return; } my $record = $self->{state}{peers}{uc $self->server_name()}; my $user = delete $ref->{username}; $self->{config}{ops}{$user} = $ref; return 1; } sub del_operator { my $self = shift; my $user = shift || return; return if !defined $self->{config}{ops}{$user}; delete $self->{config}{ops}{$user}; return; } sub add_auth { my $self = shift; my $parms; if (ref $_[0] eq 'HASH') { $parms = $_[0]; } else { $parms = { @_ }; } $parms->{lc $_} = delete $parms->{$_} for keys %$parms; if (!$parms->{mask}) { warn "Not enough parameters specified\n"; return; } push @{ $self->{config}{auth} }, $parms; return 1; } sub del_auth { my $self = shift; my $mask = shift || return; my $i = 0; for (@{ $self->{config}{auth} }) { if ($_->{mask} eq $mask) { splice( @{ $self->{config}{auth} }, $i, 1 ); last; } ++$i; } return; } sub add_peer { my $self = shift; my $parms; if (ref $_[0] eq 'HASH') { $parms = $_[0]; } else { $parms = { @_ }; } $parms->{lc $_} = delete $parms->{$_} for keys %$parms; if (!defined $parms->{name} || !defined $parms->{pass} || !defined $parms->{rpass}) { croak((caller(0))[3].": Not enough parameters specified\n"); return; } $parms->{type} = 'c' if !$parms->{type} || lc $parms->{type} ne 'r'; $parms->{type} = lc $parms->{type}; $parms->{rport} = 6667 if $parms->{type} eq 'r' && !$parms->{rport}; for (qw(sockport sockaddr)) { $parms->{ $_ } = '*' if !$parms->{ $_ }; } $parms->{ipmask} = $parms->{raddress} if $parms->{raddress}; $parms->{zip} = 0 if !$parms->{zip}; my $name = $parms->{name}; $self->{config}{peers}{uc $name} = $parms; $self->add_connector( remoteaddress => $parms->{raddress}, remoteport => $parms->{rport}, name => $name, ) if $parms->{type} eq 'r' && $parms->{auto}; return 1; } sub del_peer { my $self = shift; my $name = shift || return; return if !defined $self->{config}{peers}{uc $name}; delete $self->{config}{peers}{uc $name}; return; } sub _terminate_conn_error { my $self = shift; my $conn_id = shift || return; my $msg = shift; return if !$self->_connection_exists($conn_id); $self->disconnect($conn_id, $msg); $self->send_output( { command => 'ERROR', params => [ 'Closing Link: ' . $self->_client_ip($conn_id) . ' (' . $msg . ')', ], }, $conn_id, ); while (my ($nick, $id) = each %{ $self->{state}{pending} }) { if ($id == $conn_id) { delete $self->{state}{pending}{$nick}; last; } } return 1; } sub daemon_server_kill { my $self = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count) { last SWITCH; } if ($self->state_peer_exists($args->[0])) { last SWITCH; } if (!$self->state_nick_exists($args->[0])) { last SWITCH; } my $target = $self->state_user_nick($args->[0]); my $comment = $args->[1] || ''; my $conn_id = ($args->[2] && $self->_connection_exists($args->[2]) ? $args->[2] : ''); if ($self->_state_is_local_user($target)) { my $route_id = $self->_state_user_route($target); $self->send_output( { prefix => $server, command => 'KILL', params => [$target, $comment], }, $route_id, ); $self->_terminate_conn_error( $route_id, "Killed ($server ($comment))", ); if ($route_id eq 'spoofed') { $self->call( 'del_spoofed_nick', $target, "Killed ($server ($comment))", ); } else { $self->{state}{conns}{$route_id}{killed} = 1; $self->_terminate_conn_error( $route_id, "Killed ($server ($comment))", ); } } else { $self->{state}{users}{uc_irc($target)}{killed} = 1; $self->send_output( { prefix => $server, command => 'KILL', params => [$target, "$server ($comment)"], }, grep { !$conn_id || $_ ne $conn_id } $self->_state_connected_peers(), ); $self->send_output( @{ $self->_daemon_peer_quit( $target, "Killed ($server ($comment))" ) }); } } return @$ref if wantarray; return $ref; } sub daemon_server_mode { my $self = shift; my $chan = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$self->state_chan_exists($chan)) { last SWITCH; } my $record = $self->{state}{chans}{uc_irc($chan)}; $chan = $record->{name}; my $full = $server; my $parsed_mode = parse_mode_line(@$args); while(my $mode = shift (@{ $parsed_mode->{modes} })) { my $arg; if ($mode =~ /^(\+[ohvklbIe]|-[ohvbIe])/) { $arg = shift @{ $parsed_mode->{args} }; } if (my ($flag, $char) = $mode =~ /^(\+|-)([ohv])/) { next if !$self->state_is_chan_member($arg, $chan); if ($flag eq '+' && $record->{users}{uc_irc($arg)} !~ /$char/) { # Update user and chan record $arg = uc_irc $arg; next if $mode eq '+h' && $record->{users}{$arg} =~ /o/; if ($char eq 'h' && $record->{users}{$arg} =~ /v/) { $record->{users}{$arg} =~ s/v//g; } if ($char eq 'o' && $record->{users}{$arg} =~ /h/) { $record->{users}{$arg} =~ s/h//g; } $record->{users}{$arg} = join('', sort split //, $record->{users}{$arg} . $char); $self->{state}{users}{$arg}{chans}{uc_irc($chan)} = $record->{users}{$arg}; } if ($flag eq '-' && $record->{users}{uc_irc($arg)} =~ /$char/) { # Update user and chan record $arg = uc_irc($arg); $record->{users}{$arg} =~ s/$char//g; $self->{state}{users}{$arg}{chans}{uc_irc($chan)} = $record->{users}{$arg}; } next; } if ($mode eq '+l' && $arg =~ /^\d+$/ && $arg > 0) { if ($record->{mode} !~ /l/) { $record->{mode} = join('', sort split //, $record->{mode} . 'l'); } $record->{climit} = $arg; next; } if ($mode eq '-l' && $record->{mode} =~ /l/) { $record->{mode} =~ s/l//g; delete $record->{climit}; next; } if ($mode eq '+k' && $arg) { if ($record->{mode} !~ /k/) { $record->{mode} = join('', sort split //, $record->{mode} . 'k'); } $record->{ckey} = $arg; next; } if ($mode eq '-k' && $record->{mode} =~ /k/) { $record->{mode} =~ s/k//g; delete $record->{ckey}; next; } # Bans if (my ($flag) = $mode =~ /(\+|-)b/) { my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{bans}{$umask}) { $record->{bans}{$umask} = [$mask, ($full || $server), time]; } if ($flag eq '-' and $record->{bans}{$umask}) { delete $record->{bans}{$umask}; } next; } # Invex if (my ($flag) = $mode =~ /(\+|-)I/) { my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{invex}{$umask}) { $record->{invex}{$umask} = [$mask, ($full || $server), time]; } if ($flag eq '-' && $record->{invex}{$umask}) { delete $record->{invex}{$umask}; } next; } # Exceptions if (my ($flag) = $mode =~ /(\+|-)e/) { my $mask = normalize_mask($arg); my $umask = uc_irc($mask); if ($flag eq '+' && !$record->{excepts}{$umask}) { $record->{excepts}{$umask} = [$mask, ($full || $server), time]; } if ($flag eq '-' && $record->{excepts}{$umask}) { delete $record->{excepts}{$umask}; } next; } # The rest should be argumentless. my ($flag, $char) = split //, $mode; if ($flag eq '+' && $record->{mode} !~ /$char/) { $record->{mode} = join('', sort split //, $record->{mode} . $char); next; } if ($flag eq '-' && $record->{mode} =~ /$char/) { $record->{mode} =~ s/$char//g; next; } } # while unshift @$args, $record->{name}; $self->send_output( { prefix => $server, command => 'MODE', params => $args, colonify => 0, }, $self->_state_connected_peers(), ); $self->send_output( { prefix => ($full || $server), command => 'MODE', params => $args, colonify => 0, }, map { $self->_state_user_route($_) } grep { $self->_state_is_local_user($_) } keys %{ $record->{users} }, ); $self->send_event("daemon_mode", $server, @$args); } # SWITCH return @$ref if wantarray; return $ref; } sub daemon_server_kick { my $self = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count || $count < 2) { last SWITCH; } my $chan = (split /,/, $args->[0])[0]; my $who = (split /,/, $args->[1])[0]; if (!$self->state_chan_exists($chan)) { last SWITCH; } $chan = $self->_state_chan_name($chan); if (!$self->state_nick_exists($who)) { last SWITCH; } $who = $self->state_user_nick($who); if (!$self->state_is_chan_member($who, $chan)) { last SWITCH; } my $comment = $args->[2] || $who; $self->_send_output_to_channel( $chan, { prefix => $server, command => 'KICK', params => [$chan, $who, $comment], }, ); $who = uc_irc($who); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$who}; delete $self->{state}{users}{$who}{chans}{$chan}; if (!keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub daemon_server_remove { my $self = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; SWITCH: { if (!$count || $count < 2) { last SWITCH; } my $chan = (split /,/, $args->[0])[0]; my $who = (split /,/, $args->[1])[0]; if (!$self->state_chan_exists($chan)) { last SWITCH; } $chan = $self->_state_chan_name($chan); if (!$self->state_nick_exists($who)) { last SWITCH; } my $fullwho = $self->state_user_full($who); $who = (split /!/, $who)[0]; if (!$self->state_is_chan_member($who, $chan)) { last SWITCH; } my $comment = 'Enforced PART'; $comment .= " \"$args->[2]\"" if $args->[2]; $self->_send_output_to_channel( $chan, { prefix => $fullwho, command => 'PART', params => [$chan, $comment], }, ); $who = uc_irc($who); $chan = uc_irc($chan); delete $self->{state}{chans}{$chan}{users}{$who}; delete $self->{state}{users}{$who}{chans}{$chan}; if (!keys %{ $self->{state}{chans}{$chan}{users} }) { delete $self->{state}{chans}{$chan}; } } return @$ref if wantarray; return $ref; } sub daemon_server_wallops { my $self = shift; my $server = $self->server_name(); my $ref = [ ]; my $args = [ @_ ]; my $count = @$args; if ($count) { $self->send_output( { prefix => $server, command => 'WALLOPS', params => [$args->[0]], }, $self->_state_connected_peers(), keys %{ $self->{state}{operwall} }, ); $self->send_event("daemon_wallops", $server, $args->[0]); } return @$ref if wantarray; return $ref; } sub add_spoofed_nick { my ($kernel, $self) = @_[KERNEL, OBJECT]; my $ref; if (ref $_[ARG0] eq 'HASH') { $ref = $_[ARG0]; } else { $ref = { @_[ARG0..$#_] }; } $ref->{ lc $_ } = delete $ref->{$_} for keys %$ref; return if !$ref->{nick}; return if $self->state_nick_exists($ref->{nick}); my $record = $ref; $record->{ts} = time if !$record->{ts}; $record->{type} = 's'; $record->{server} = $self->server_name(); $record->{hops} = 0; $record->{route_id} = 'spoofed'; $record->{umode} = 'i' if !$record->{umode}; if (!defined $record->{ircname}) { $record->{ircname} = "* I'm too lame to read the documentation *"; } $self->{state}{stats}{invisible}++ if $record->{umode} =~ /i/; $self->{state}{stats}{ops_online}++ if $record->{umode} =~ /o/; $record->{idle_time} = $record->{conn_time} = $record->{ts}; $record->{auth}{ident} = delete $record->{user} || $record->{nick}; $record->{auth}{hostname} = delete $record->{hostname} || $self->server_name(); $self->{state}{users}{uc_irc($record->{nick})} = $record; $self->{state}{peers}{uc $record->{server}}{users}{uc_irc($record->{nick})} = $record; my $arrayref = [ $record->{nick}, $record->{hops} + 1, $record->{ts}, '+' . $record->{umode}, $record->{auth}{ident}, $record->{auth}{hostname}, $record->{server}, $record->{ircname}, ]; $self->send_output( { command => 'NICK', params => $arrayref, }, $self->_state_connected_peers(), ); $self->send_event("daemon_nick", @$arrayref); $self->_state_update_stats(); return; } sub del_spoofed_nick { my ($kernel, $self, $nick) = @_[KERNEL, OBJECT, ARG0]; return if !$self->state_nick_exists($nick); return if $self->_state_user_route($nick) ne 'spoofed'; my $message = $_[ARG1] || 'Client Quit'; $self->send_output( @{ $self->_daemon_cmd_quit($nick, qq{"$message"}) }, qq{"$message"}, ); return; } sub _spoofed_command { my ($kernel, $self, $state, $nick) = @_[KERNEL, OBJECT, STATE, ARG0]; return if !$self->state_nick_exists($nick); return if $self->_state_user_route($nick) ne 'spoofed'; $nick = $self->state_user_nick($nick); $state =~ s/daemon_cmd_//; my $command = "_daemon_cmd_" . $state; if ($state =~ /^(privmsg|notice)$/) { my $type = uc $1; $self->_daemon_cmd_message($nick, $type, @_[ARG1 .. $#_]); return; } elsif ($state eq 'sjoin') { my $chan = $_[ARG1]; return if !$chan || !$self->state_chan_exists($chan); return if $self->state_is_chan_member($nick, $chan); $chan = $self->_state_chan_name($chan); my $ts = $self->_state_chan_timestamp($chan) - 10; $self->_daemon_peer_sjoin( 'spoofed', $self->server_name(), $ts, $chan, '+nt', '@' . $nick, ); return; } $self->$command($nick, @_[ARG1 .. $#_]) if $self->can($command); return; } 1; =encoding utf8 =head1 NAME POE::Component::Server::IRC - A fully event-driven networkable IRC server daemon module. =head1 SYNOPSIS # A fairly simple example: use strict; use warnings; use POE qw(Component::Server::IRC); my %config = ( servername => 'simple.poco.server.irc', nicklen => 15, network => 'SimpleNET' ); my $pocosi = POE::Component::Server::IRC->spawn( config => \%config ); POE::Session->create( package_states => [ 'main' => [qw(_start _default)], ], heap => { ircd => $pocosi }, ); $poe_kernel->run(); sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{ircd}->yield('register', 'all'); # Anyone connecting from the loopback gets spoofed hostname $heap->{ircd}->add_auth( mask => '*@localhost', spoof => 'm33p.com', no_tilde => 1, ); # We have to add an auth as we have specified one above. $heap->{ircd}->add_auth(mask => '*@*'); # Start a listener on the 'standard' IRC port. $heap->{ircd}->add_listener(port => 6667); # Add an operator who can connect from localhost $heap->{ircd}->add_operator( { username => 'moo', password => 'fishdont', } ); } sub _default { my ($event, $args) = @_[ARG0 .. $#_]; print "$event: "; for my $arg (@$args) { if (ref($arg) eq 'ARRAY') { print "[", join ( ", ", @$arg ), "] "; } elsif (ref($arg) eq 'HASH') { print "{", join ( ", ", %$arg ), "} "; } else { print "'$arg' "; } } print "\n"; } =head1 DESCRIPTION POE::Component::Server::IRC is a POE component which implements an IRC server (also referred to as an IRC daemon or IRCd). It should be compliant with the pertient IRC RFCs and is based on reverse engineering Hybrid IRCd behaviour with regards to interactions with IRC clients and other IRC servers. Yes, that's right. POE::Component::Server::IRC is capable of linking to foreign IRC networks. It supports the TS5 server to server protocol and has been tested with linking to Hybrid-7 based networks. It should in theory work with any TS5-based IRC network. POE::Component::Server::IRC also has a services API, which enables one to extend the IRCd to create IRC Services. This is fully event-driven (of course =]). There is also a Plugin system, similar to that sported by L. B This is a subclass of L. You should read its documentation too. =head1 CONSTRUCTOR =head2 C Returns a new instance of the component. Takes the following parameters: =over 4 =item * B<'config'>, a hashref of configuration options, see the L|/configure> method for details. =back Any other parameters will be passed along to L's L|POE::Component::Server::IRC::Backend/create> method. If the component is spawned from within another session then that session will automagically be registered with the component to receive events and be sent an L|POE::Component::IRC::Server::Backend/ircd_registered> event. =head1 METHODS =head2 Information =head3 C No arguments, returns the name of the ircd. =head3 C No arguments, returns the software version of the ircd. =head3 C No arguments, returns a string signifying when the ircd was created. =head3 C Takes one argument, the server configuration value to query. =head2 Configuration These methods provide mechanisms for configuring and controlling the IRCd component. =head3 C Configures your new shiny IRCd. Takes a number of parameters: =over 4 =item * B<'servername'>, a name to bless your shiny new IRCd with, defaults to 'poco.server.irc'; =item * B<'serverdesc'>, a description for your IRCd, defaults to 'Poco? POCO? POCO!'; =item * B<'network'>, the name of the IRC network you will be creating, defaults to 'poconet'; =item * B<'nicklen'>, the max length of nicknames to support, defaults to 9. B: the nicklen must be the same on all servers on your IRC network; =item * B<'maxtargets'>, max number of targets a user can send PRIVMSG/NOTICE's to, defaults to 4; =item * B<'maxchannels'>, max number of channels users may join, defaults to 15; =item * B<'version'>, change the server version that is reported; =item * B<'admin'>, an arrayref consisting of the 3 lines that will be returned by ADMIN; =item * B<'info'>, an arrayref consisting of lines to be returned by INFO; =item * B<'ophacks'>, set to true to enable oper hacks. Default is false; =item * B<'whoisactually'>, setting this to a false value means that only opers can see 338. Defaults to true; =back =head3 C By default the IRCd allows any user to connect to the server without a password. Configuring auths enables you to control who can connect and set passwords required to connect. Takes the following parameters: =over 4 =item * B<'mask'>, a user@host or user@ipaddress mask to match against, mandatory; =item * B<'password'>, if specified, any client matching the mask must provide this to connect; =item * B<'spoof'>, if specified, any client matching the mask will have their hostname changed to this; =item * B<'no_tilde'>, if specified, the '~' prefix is removed from their username; =back Auth masks are processed in order of addition. If auth masks have been defined, then a connecting user *must* match one of the masks in order to be authorised to connect. This is a feature >;) =head3 C Takes a single argument, the mask to remove. =head3 C This adds an O line to the IRCd. Takes a number of parameters: =over 4 =item * B<'username'>, the username of the IRC oper, mandatory; =item * B<'password'>, the password, mandatory; =item * B<'ipmask'>, either a scalar ipmask or an arrayref of Net::Netmask objects; =back A scalar ipmask can contain '*' to match any number of characters or '?' to match one character. If no 'ipmask' is provided, operators are only allowed to OPER from the loopback interface. B<'password'> can be either plain-text, L|crypt>'d or unix/apache md5. See the C function in L for how to generate passwords. =head3 C Takes a single argument, the username to remove. =head3 C Adds peer servers that we will allow to connect to us and who we will connect to. Takes the following parameters: =over 4 =item * B<'name'>, the name of the server. This is the IRC name, not hostname, mandatory; =item * B<'pass'>, the password they must supply to us, mandatory; =item * B<'rpass'>, the password we need to supply to them, mandatory; =item * B<'type'>, the type of server, 'c' for a connecting server, 'r' for one that we will connect to; =item * B<'raddress'>, the remote address to connect to, implies 'type' eq 'r'; =item * B<'rport'>, the remote port to connect to, default is 6667; =item * B<'ipmask'>, either a scalar ipmask or an arrayref of Net::Netmask objects; =item * B<'auto'>, if set to true value will automatically connect to remote server if type is 'r'; =item * B<'zip'>, set to a true value to enable ziplink support. This must be done on both ends of the connection. Requires L; =back =head3 C Takes a single argument, the peer to remove. This does not disconnect the said peer if it is currently connected. =head2 State queries The following methods allow you to query state information regarding nicknames, channels, and peers. =head3 C Takes no arguments, returns a list of all nicknames in the state. =head3 C Takes no arguments, returns a list of all channels in the state. =head3 C Takes no arguments, returns a list of all irc servers in the state. =head3 C Takes one argument, a nickname, returns true or false dependent on whether the given nickname exists or not. =head3 C Takes one argument, a channel name, returns true or false dependent on whether the given channel exists or not. =head3 C Takes one argument, a peer server name, returns true or false dependent on whether the given peer exists or not. =head3 C Takes one argument, a nickname, returns that users full nick!user@host if they exist, undef if they don't. =head3 C Takes one argument, a nickname, returns the proper nickname for that user. Returns undef if the nick doesn't exist. =head3 C Takes one argument, a nickname, returns that users mode setting. =head3 C Takes one argument, a nickname, returns true or false dependent on whether the given nickname is an IRC operator or not. =head3 C Takes one argument, a nickname, returns a list of channels that that nick is a member of. =head3 C Takes one argument, a nickname, returns the name of the peer server that that user is connected from. =head3 C Takes one argument, a channel name, returns a list of the member nicks on that channel. =head3 C Takes one argument, a channel name, returns a list of the member nicks on that channel, nicknames will be prefixed with @%+ if they are +o +h or +v, respectively. =head3 C Takes one argument, a channel name, returns undef if no topic is set on that channel, or an arrayref consisting of the topic, who set it and the time they set it. =head3 C Takes two arguments, a channel name and a channel mode character. Returns true if that channel mode is set, false otherwise. =head3 C Takes two arguments, a nick and a channel name. Returns true if that nick is on channel, false otherwise. =head3 C Takes two arguments, a nick and a channel name. Returns that nicks status (+ohv or '') on that channel. =head3 C Takes two arguments, a nick and a channel name. Returns true if that nick is an channel operator, false otherwise. =head3 C Takes two arguments, a nick and a channel name. Returns true if that nick is an channel half-operator, false otherwise. =head3 C Takes two arguments, a nick and a channel name. Returns true if that nick has channel voice, false otherwise. =head2 Server actions =head3 C Takes two arguments, a nickname and a comment (which is optional); Issues a SERVER KILL of the given nick; =head3 C First argument is a channel name, remaining arguments are channel modes and their parameters to apply. =head3 C Takes two arguments that are mandatory and an optional one: channel name, nickname of the user to kick and a pithy comment. =head3 C Takes two arguments that are mandatory and an optional one: channel name, nickname of the user to remove and a pithy comment. =head3 C Takes one argument, the message text to send. =head1 INPUT EVENTS These are POE events that can be sent to the component. =head2 C Takes a single argument a hashref which should have the following keys: =over 4 =item * B<'nick'>, the nickname to add, mandatory; =item * B<'user'>, the ident you want the nick to have, defaults to the same as the nick; =item * B<'hostname'>, the hostname, defaults to the server name; =item * B<'umode'>, specify whether this is to be an IRCop etc, defaults to 'i'; =item * B<'ts'>, unixtime, default is time(), best not to meddle; =back B spoofed nicks are currently only really functional for use as IRC services. =head2 C Takes a single mandatory argument, the spoofed nickname to remove. Optionally, you may specify a quit message for the spoofed nick. =head2 Spoofed nick commands The following input events are for the benefit of spoofed nicks. All require a nickname of a spoofed nick as the first argument. =head3 C Takes two arguments, a spoofed nick and a channel name to join. =head3 C Takes two arguments, a spoofed nick and a channel name to part from. =head3 C Takes at least three arguments, a spoofed nick, a channel and a channel mode to apply. Additional arguments are parameters for the channel modes. =head3 C Takes at least three arguments, a spoofed nick, a channel name and the nickname of a user to kick from that channel. You may supply a fourth argument which will be the kick comment. =head3 C Takes three arguments, a spoofed nick, a channel name and the topic to set on that channel. If the third argument is an empty string then the channel topic will be unset. =head3 C Takes two arguments, a spoofed nick and a new nickname to change to. =head3 C Takes three arguments, a spoofed nick, a user@host mask to gline and a reason for the gline. =head3 C Takes a number of arguments depending on where the KLINE is to be applied and for how long: To set a permanent KLINE: $ircd->yield( 'daemon_cmd_kline', $spoofed_nick, $nick || $user_host_mask, $reason, ); To set a temporary 10 minute KLINE: $ircd->yield( 'daemon_cmd_kline', $spoofed_nick, 10, $nick || $user_host_mask, $reason, ); To set a temporary 10 minute KLINE on all servers: $ircd->yield( 'daemon_cmd_kline', $spoofed_nick, 10, $nick || $user_host_mask, 'on', '*', $reason, ); =head3 C Removes a KLINE as indicated by the user@host mask supplied. To remove a KLINE: $ircd->yield( 'daemon_cmd_unkline', $spoofed_nick, $user_host_mask, ); To remove a KLINE from all servers: $ircd->yield( 'daemon_cmd_unkline', $spoofed_nick, $user_host_mask, 'on', '*', ); =head3 C Used to set a regex based KLINE. The regex given must be based on a user@host mask. To set a permanent RKLINE: $ircd->yield( 'daemon_cmd_rkline', $spoofed_nick, '^.*$@^(yahoo|google|microsoft)\.com$', $reason, ); To set a temporary 10 minute RKLINE: $ircd->yield( 'daemon_cmd_rkline', $spoofed_nick, 10, '^.*$@^(yahoo|google|microsoft)\.com$', $reason, ); To set a temporary 10 minute RKLINE on all servers: $ircd->yield( 'daemon_cmd_kline', $spoofed_nick, 10, '^.*$@^(yahoo|google|microsoft)\.com$', 'on', '*', $reason, ); =head3 C Takes two arguments a spoofed nickname and an existing channel name. This command will then manipulate the channel timestamp to clear all modes on that channel, including existing channel operators, reset the channel mode to '+nt', the spoofed nick will then join the channel and gain channel ops. =head3 C Takes three arguments, a spoofed nickname, a target (which can be a nickname or a channel name) and whatever text you wish to send. =head3 C Takes three arguments, a spoofed nickname, a target (which can be a nickname or a channel name) and whatever text you wish to send. =head3 C Takes two arguments, a spoofed nickname and the text message to send to local operators. =head3 C Takes two arguments, a spoofed nickname and the text message to send to all operators. =head3 C Takes two arguments, a spoofed nickname and the text message to send to all operators. =head1 OUTPUT EVENTS =head2 C =over =item Emitted: when we fail to register with a peer; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, the server name; =item * C, the reason; =back =back =head2 C =over =item Emitted: when a server is introduced onto the network; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the server name; =item * C, the name of the server that is introducing them; =item * C, the hop count; =item * C, the server description; =back =back =head2 C =over =item Emitted: when a server quits the network; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the server name; =back =back =head2 C =over =item Emitted: when a user is introduced onto the network or changes their nickname =item Target: all plugins and registered sessions; =item Args (new user): =over 4 =item * C, the nickname; =item * C, the hop count; =item * C, the time stamp (TS); =item * C, the user mode; =item * C, the ident; =item * C, the hostname; =item * C, the server name; =item * C, the real name; =back =item Args (nick change): =over 4 =item * C, the full nick!user@host; =item * C, the new nickname; =back =back =head2 C =over =item Emitted: when a user changes their user mode; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the user mode change; =back =back =head2 C =over =item Emitted: when a user quits or the server they are on squits; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the quit message; =back =back =head2 C =over =item Emitted: when a user joins a channel =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the channel name; =back =back =head2 C =over =item Emitted: when a user parts a channel; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the channel name; =item * C, the part message; =back =back =head2 C =over =item Emitted: when a user is kicked from a channel; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the kicker; =item * C, the channel name; =item * C, the nick of the kicked user; =item * C, the kick message; =back =back =head2 C =over =item Emitted: when a channel mode is changed; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host or server name; =item * C, the channel name; =item * C, the modes and their arguments; =back =back =head2 C =over =item Emitted: when a channel topic is changed =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the changer; =item * C, the channel name; =item * C, the new topic; =back =back =head2 C =over =item Emitted: when a channel message is sent (a spoofed nick must be in the channel) =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the sender; =item * C, the channel name; =item * C, the message; =back =back =head2 C =over =item Emitted: when someone sends a private message to a spoofed nick =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the sender; =item * C, the spoofed nick targeted; =item * C, the message; =back =back =head2 C =over =item Emitted: when someone sends a notice to a spoofed nick or channel =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the sender; =item * C, the spoofed nick targeted or channel spoofed nick is in; =item * C, the message; =back =back =head2 C =over =item Emitted: when someone invites a spoofed nick to a channel; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the inviter; =item * C, the spoofed nick being invited; =item * C, the channel being invited to; =back =back =head2 C =over =item Emitted: when an oper issues a REHASH command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the oper; =back =back =head2 C =over =item Emitted: when an oper issues a DIE command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host of the oper; =back =back B the component will shutdown, this is a feature; =head2 C =over =item Emitted: when an oper issues a GLINE command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the user mask; =item * C, the host mask; =item * C, the reason; =back =back =head2 C =over =item Emitted: when an oper issues a KLINE command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the target for the KLINE; =item * C, the duration in seconds; =item * C, the user mask; =item * C, the host mask; =item * C, the reason; =back =back =head2 C =over =item Emitted: when an oper issues an RKLINE command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the target for the RKLINE; =item * C, the duration in seconds; =item * C, the user mask; =item * C, the host mask; =item * C, the reason; =back =back =head2 C =over =item Emitted: when an oper issues an UNKLINE command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the target for the UNKLINE; =item * C, the user mask; =item * C, the host mask; =back =back =head2 C =over =item Emitted: when an oper issues a LOCOPS command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the locops message; =back =back =head2 C =over =item Emitted: when an oper issues a WALLOPS or OPERWALL command; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the full nick!user@host; =item * C, the wallops or operwall message; =back =back =head2 C =over =item Emitted: when a server issues a WALLOPS; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the server name; =item * C, the wallops message; =back =back =head1 BUGS A few have turned up in the past and they are sure to again. Please use L to report any. Alternatively, email the current maintainer. =head1 DEVELOPMENT You can find the latest source on github: L The project's developers usually hang out in the C<#poe> IRC channel on irc.perl.org. Do drop us a line. =head1 MAINTAINER Hinrik Ern SigurEsson =head1 AUTHOR Chris 'BinGOs' Williams =head1 LICENSE Copyright C<(c)> Chris Williams This module may be used, modified, and distributed under the same terms as Perl itself. Please see the license that came with your Perl distribution for details. =head1 KUDOS Rocco Caputo for creating POE. Buu for pestering me when I started to procrastinate =] =head1 SEE ALSO L L L L Hybrid IRCD L TSOra L RFC 2810 L RFC 2811 L RFC 2812 L RFC 2813 L =cut POE-Component-IRC-6.90/t/inc/POE/Component/Server/IRC/0000755000175000017500000000000013153565114021262 5ustar bingosbingosPOE-Component-IRC-6.90/t/inc/POE/Component/Server/IRC/Common.pm0000644000175000017500000000576613153565114023066 0ustar bingosbingospackage POE::Component::Server::IRC::Common; BEGIN { $POE::Component::Server::IRC::Common::AUTHORITY = 'cpan:HINRIK'; } BEGIN { $POE::Component::Server::IRC::Common::VERSION = '1.52'; } use strict; use warnings FATAL => 'all'; use Crypt::PasswdMD5; require Exporter; use base qw(Exporter); our @EXPORT_OK = qw(mkpasswd chkpasswd); our %EXPORT_TAGS = ( ALL => [@EXPORT_OK] ); sub mkpasswd { my ($plain, %opts) = @_; return if !defined $plain || !length $plain; $opts{lc $_} = delete $opts{$_} for keys %opts; return unix_md5_crypt($plain) if $opts{md5}; return apache_md5_crypt($plain) if $opts{apache}; my $salt = join '', ('.','/', 0..9, 'A'..'Z', 'a'..'z')[rand 64, rand 64]; return crypt($plain, $salt); } sub chkpasswd { my ($pass, $chk) = @_; return if !defined $pass || !length $pass; return if !defined $chk || !length $chk; my $md5 = '$1$'; my $apr = '$apr1$'; if (index($chk,$apr) == 0) { my $salt = $chk; $salt =~ s/^\Q$apr//; $salt =~ s/^(.*)\$/$1/; $salt = substr( $salt, 0, 8 ); return 1 if apache_md5_crypt($pass, $salt) eq $chk; } elsif ( index($chk,$md5) == 0 ) { my $salt = $chk; $salt =~ s/^\Q$md5//; $salt =~ s/^(.*)\$/$1/; $salt = substr( $salt, 0, 8 ); return 1 if unix_md5_crypt($pass, $salt) eq $chk; } return 1 if crypt( $pass, $chk ) eq $chk; return 1 if $pass eq $chk; return; } 1; =encoding utf8 =head1 NAME POE::Component::Server::IRC::Common - provides a set of common functions for the POE::Component::Server::IRC suite. =head1 SYNOPSIS use strict; use warnings; use POE::Component::Server::IRC::Common qw( :ALL ); my $passwd = mkpasswd( 'moocow' ); =head1 DESCRIPTION POE::Component::IRC::Common provides a set of common functions for the L suite. =head1 FUNCTIONS =head2 C Takes one mandatory argument a plain string to 'encrypt'. If no further options are specified it uses C to generate the password. Specifying 'md5' option uses L's C function to generate the password. Specifying 'apache' uses Crypt::PasswdMD5 C function to generate the password. my $passwd = mkpasswd( 'moocow' ); # vanilla crypt() my $passwd = mkpasswd( 'moocow', md5 => 1 ) # unix_md5_crypt() my $passwd = mkpasswd( 'moocow', apache => 1 ) # apache_md5_crypt() =head2 C Takes two mandatory arguments, a password string and something to check that password against. The function first tries md5 comparisons (UNIX and Apache), then C and finally plain-text password check. =head1 AUTHOR Chris 'BinGOs' Williams =head1 LICENSE Copyright E Chris Williams This module may be used, modified, and distributed under the same terms as Perl itself. Please see the license that came with your Perl distribution for details. =head1 SEE ALSO L =cut POE-Component-IRC-6.90/t/inc/POE/Component/Server/IRC/Backend.pm0000644000175000017500000012442613153565114023160 0ustar bingosbingospackage POE::Component::Server::IRC::Backend; BEGIN { $POE::Component::Server::IRC::Backend::AUTHORITY = 'cpan:HINRIK'; } BEGIN { $POE::Component::Server::IRC::Backend::VERSION = '1.52'; } use strict; use warnings; use Carp qw(croak); use List::Util qw(first); use POE qw(Wheel::SocketFactory Wheel::ReadWrite Filter::Stackable Filter::Line Filter::IRCD); use Net::Netmask; use Socket qw(unpack_sockaddr_in inet_ntoa); use base qw(POE::Component::Syndicator); use constant { OBJECT_STATES_HASHREF => { syndicator_started => '_start', add_connector => '_add_connector', add_listener => '_add_listener', del_listener => '_del_listener', send_output => '_send_output', shutdown => '_shutdown', }, OBJECT_STATES_ARRAYREF => [qw( _accept_connection _accept_failed _conn_alarm _conn_input _conn_error _conn_flushed _event_dispatcher _sock_failed _sock_up )], }; sub create { my $package = shift; croak("$package requires an even number of parameters") if @_ & 1; my %args = @_; $args{ lc $_ } = delete $args{$_} for keys %args; my $self = bless { }, $package; $self->{raw_events} = $args{raw_events} if defined $args{raw_events}; $self->{prefix} = defined $args{prefix} ? $args{prefix} : 'ircd_'; $self->{antiflood} = defined $args{antiflood} ? $args{antiflood} : 1; $self->{auth} = defined $args{auth} ? $args{auth} : 1; if ($args{sslify_options} && ref $args{sslify_options} eq 'ARRAY') { eval { require POE::Component::SSLify; POE::Component::SSLify->import( qw(SSLify_Options Server_SSLify Client_SSLify) ); }; chomp $@; croak("Can't use ssl: $@") if $@; eval { SSLify_Options(@{ $args{sslify_options} }); }; chomp $@; croak("Can't use ssl: $@") if $@; $self->{got_ssl} = 1; } if ($args{states}) { my $error = $self->_validate_states($args{states}); croak($error) if defined $error; } $self->_syndicator_init( prefix => $self->{prefix}, reg_prefix => 'PCSI_', types => [ SERVER => 'IRCD', USER => 'U' ], object_states => [ $self => OBJECT_STATES_HASHREF, $self => OBJECT_STATES_ARRAYREF, ($args{states} ? map { $self => $_ } @{ $args{states} } : () ), ], ($args{plugin_debug} ? (debug => 1) : () ), (ref $args{options} eq 'HASH' ? (options => $args{options}) : ()), ); if ($self->{auth}) { require POE::Component::Server::IRC::Plugin::Auth; $self->plugin_add( 'Auth_'.$self->session_id(), POE::Component::Server::IRC::Plugin::Auth->new(), ); } return $self; } sub _validate_states { my ($self, $states) = @_; for my $events (@$states) { if (ref $events eq 'HASH') { for my $event (keys %$events) { if (OBJECT_STATES_HASHREF->{$event} || first { $event eq $_ } @{ +OBJECT_STATES_ARRAYREF }) { return "Event $event is reserved by ". __PACKAGE__; } } } elsif (ref $events eq 'ARRAY') { for my $event (@$events) { if (OBJECT_STATES_HASHREF->{$event} || first { $event eq $_ } @{ +OBJECT_STATES_ARRAYREF }) { return "Event $event is reserved by ". __PACKAGE__; } } } } return; } sub _start { my ($kernel, $self, $sender) = @_[KERNEL, OBJECT, SENDER]; $self->{ircd_filter} = POE::Filter::IRCD->new( colonify => 1, ); $self->{line_filter} = POE::Filter::Line->new( InputRegexp => '\015?\012', OutputLiteral => "\015\012", ); $self->{filter} = POE::Filter::Stackable->new( Filters => [$self->{line_filter}, $self->{ircd_filter}], ); return; } sub raw_events { my ($self, $value) = @_; $self->{raw_events} = 1 if $value; return; } sub shutdown { my ($self) = shift; $self->yield('shutdown', @_); return; } sub _shutdown { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->{terminating} = 1; delete $self->{listeners}; delete $self->{connectors}; delete $self->{wheels}; $self->_syndicator_destroy(); return; } sub _accept_failed { my ($kernel, $self, $operation, $errnum, $errstr, $listener_id) = @_[KERNEL, OBJECT, ARG0..ARG3]; my $port = $self->{listeners}{$listener_id}{port}; my $addr = $self->{listeners}{$listener_id}{addr}; delete $self->{listeners}{$listener_id}; $self->send_event( "$self->{prefix}listener_failure", $listener_id, $operation, $errnum, $errstr, $port, $addr, ); return; } sub _accept_connection { my ($kernel, $self, $socket, $peeraddr, $peerport, $listener_id) = @_[KERNEL, OBJECT, ARG0..ARG3]; my $sockaddr = inet_ntoa((unpack_sockaddr_in(getsockname $socket))[1]); my $sockport = (unpack_sockaddr_in(getsockname $socket))[0]; $peeraddr = inet_ntoa($peeraddr); my $listener = $self->{listeners}{$listener_id}; if ($self->{got_ssl} && $listener->{usessl}) { eval { $socket = POE::Component::SSLify::Server_SSLify($socket); }; chomp $@; die "Failed to SSLify server socket: $@" if $@; } return if $self->denied($peeraddr); my $wheel = POE::Wheel::ReadWrite->new( Handle => $socket, Filter => $self->{filter}, InputEvent => '_conn_input', ErrorEvent => '_conn_error', FlushedEvent => '_conn_flushed', ); if ($wheel) { my $wheel_id = $wheel->ID(); my $ref = { wheel => $wheel, peeraddr => $peeraddr, peerport => $peerport, flooded => 0, sockaddr => $sockaddr, sockport => $sockport, idle => time(), antiflood => $listener->{antiflood}, compress => 0 }; my $needs_auth = $listener->{auth} && $self->{auth} ? 1 : 0; $self->send_event( "$self->{prefix}connection", $wheel_id, $peeraddr, $peerport, $sockaddr, $sockport, $needs_auth, ); $ref->{alarm} = $kernel->delay_set( '_conn_alarm', $listener->{idle}, $wheel_id, ); $self->{wheels}{$wheel_id} = $ref; } return; } sub add_listener { my ($self) = shift; croak('add_listener requires an even number of parameters') if @_ & 1; $self->yield('add_listener', @_); return; } sub _add_listener { my ($kernel, $self) = @_[KERNEL, OBJECT]; my %args = @_[ARG0..$#_]; $args{ lc($_) } = delete $args{$_} for keys %args; my $bindaddr = $args{bindaddr} || '0.0.0.0'; my $bindport = $args{port} || 0; my $idle = $args{idle} || 180; my $auth = 1; my $antiflood = 1; my $usessl = 0; $usessl = 1 if $args{usessl}; $auth = 0 if defined $args{auth} && $args{auth} eq '0'; $antiflood = 0 if defined $args{antiflood} && $args{antiflood} eq '0'; my $listener = POE::Wheel::SocketFactory->new( BindAddress => $bindaddr, BindPort => $bindport, SuccessEvent => '_accept_connection', FailureEvent => '_accept_failed', Reuse => 'on', ($args{listenqueue} ? (ListenQueue => $args{listenqueue}) : ()), ); my $id = $listener->ID(); $self->{listeners}{$id}{wheel} = $listener; $self->{listeners}{$id}{port} = $bindport; $self->{listeners}{$id}{addr} = $bindaddr; $self->{listeners}{$id}{idle} = $idle; $self->{listeners}{$id}{auth} = $auth; $self->{listeners}{$id}{antiflood} = $antiflood; $self->{listeners}{$id}{usessl} = $usessl; my ($port, $addr) = unpack_sockaddr_in($listener->getsockname); if ($port) { $self->{listeners}{$id}{port} = $port; $self->send_event( $self->{prefix} . 'listener_add', $port, $id, $bindaddr, ); } return; } sub del_listener { my ($self) = shift; croak("add_listener requires an even number of parameters") if @_ & 1; $self->yield('del_listener', @_); return; } sub _del_listener { my ($kernel, $self) = @_[KERNEL, OBJECT]; my %args = @_[ARG0..$#_]; $args{lc $_} = delete $args{$_} for keys %args; my $listener_id = delete $args{listener}; my $port = delete $args{port}; if ($self->_listener_exists($listener_id)) { my $port = $self->{listeners}{$listener_id}{port}; my $addr = $self->{listeners}{$listener_id}{addr}; delete $self->{listeners}{$listener_id}; $self->send_event( $self->{prefix} . 'listener_del', $port, $listener_id, $addr, ); } elsif (defined $port) { while (my ($id, $listener) = each %{ $self->{listeners } }) { if ($listener->{port} == $port) { my $addr = $listener->{addr}; delete $self->{listeners}{$id}; $self->send_event( $self->{prefix} . 'listener_del', $port, $listener_id, $addr, ); } } } return; } sub _listener_exists { my $self = shift; my $listener_id = shift || return; return 1 if defined $self->{listeners}{$listener_id}; return; } sub add_connector { my $self = shift; croak("add_connector requires an even number of parameters") if @_ & 1; $self->yield('add_connector', @_); return; } sub _add_connector { my ($kernel, $self, $sender) = @_[KERNEL, OBJECT, SENDER]; my %args = @_[ARG0..$#_]; $args{lc $_} = delete $args{$_} for keys %args; my $remoteaddress = $args{remoteaddress}; my $remoteport = $args{remoteport}; return if !$remoteaddress || !$remoteport; my $wheel = POE::Wheel::SocketFactory->new( SocketProtocol => 'tcp', RemoteAddress => $remoteaddress, RemotePort => $remoteport, SuccessEvent => '_sock_up', FailureEvent => '_sock_failed', ($args{bindaddress} ? (BindAddress => $args{bindaddress}) : ()), ); if ($wheel) { $args{wheel} = $wheel; $self->{connectors}{$wheel->ID()} = \%args; } return; } sub _sock_failed { my ($kernel, $self, $op, $errno, $errstr, $connector_id) = @_[KERNEL, OBJECT, ARG0..ARG3]; my $ref = delete $self->{connectors}{$connector_id}; delete $ref->{wheel}; $self->send_event("$self->{prefix}socketerr", $ref, $op, $errno, $errstr); return; } sub _sock_up { my ($kernel, $self, $socket, $peeraddr, $peerport, $connector_id) = @_[KERNEL, OBJECT, ARG0..ARG3]; $peeraddr = inet_ntoa($peeraddr); my $cntr = delete $self->{connectors}{$connector_id}; if ($self->{got_ssl} && $cntr->{usessl}) { eval { $socket = POE::Component::SSLify::Client_SSLify($socket); }; chomp $@; die "Failed to SSLify client socket: $@" if $@; } my $wheel = POE::Wheel::ReadWrite->new( Handle => $socket, InputEvent => '_conn_input', ErrorEvent => '_conn_error', FlushedEvent => '_conn_flushed', Filter => POE::Filter::Stackable->new( Filters => [$self->{filter}], ), ); return if !$wheel; my $wheel_id = $wheel->ID(); my $sockaddr = inet_ntoa((unpack_sockaddr_in(getsockname $socket))[1]); my $sockport = (unpack_sockaddr_in(getsockname $socket))[0]; my $ref = { wheel => $wheel, peeraddr => $peeraddr, peerport => $peerport, sockaddr => $sockaddr, sockport => $sockport, idle => time(), antiflood => 0, compress => 0, }; $self->{wheels}{$wheel_id} = $ref; $self->send_event( "$self->{prefix}connected", $wheel_id, $peeraddr, $peerport, $sockaddr, $sockport, $cntr->{name} ); return; } sub _anti_flood { my ($self, $wheel_id, $input) = @_; my $current_time = time(); return if !$wheel_id || !$self->connection_exists($wheel_id) || !$input; SWITCH: { if ($self->{wheels}->{ $wheel_id }->{flooded}) { last SWITCH; } if (!$self->{wheels}{$wheel_id}{timer} || $self->{wheels}{$wheel_id}{timer} < $current_time) { $self->{wheels}{$wheel_id}{timer} = $current_time; my $event = "$self->{prefix}cmd_" . lc $input->{command}; $self->send_event($event, $wheel_id, $input); last SWITCH; } if ($self->{wheels}{$wheel_id}{timer} <= $current_time + 10) { $self->{wheels}{$wheel_id}{timer} += 1; push @{ $self->{wheels}{$wheel_id}{msq} }, $input; push @{ $self->{wheels}{$wheel_id}{alarm_ids} }, $poe_kernel->alarm_set( '_event_dispatcher', $self->{wheels}{$wheel_id}{timer}, $wheel_id ); last SWITCH; } $self->{wheels}{$wheel_id}{flooded} = 1; $self->send_event("$self->{prefix}connection_flood", $wheel_id); } return 1; } sub _conn_error { my ($self, $errstr, $wheel_id) = @_[OBJECT, ARG2, ARG3]; return if !$self->connection_exists($wheel_id); $self->_disconnected( $wheel_id, $errstr || $self->{wheels}{$wheel_id}{disconnecting} ); return; } sub _conn_alarm { my ($kernel, $self, $wheel_id) = @_[KERNEL, OBJECT, ARG0]; return if !$self->connection_exists($wheel_id); my $conn = $self->{wheels}{$wheel_id}; $self->send_event( "$self->{prefix}connection_idle", $wheel_id, $conn->{idle}, ); $conn->{alarm} = $kernel->delay_set( '_conn_alar', $conn->{idle}, $wheel_id, ); return; } sub _conn_flushed { my ($kernel, $self, $wheel_id) = @_[KERNEL, OBJECT, ARG0]; return if !$self->connection_exists($wheel_id); if ($self->{wheels}{$wheel_id}{disconnecting}) { $self->_disconnected( $wheel_id, $self->{wheels}{$wheel_id}{disconnecting}, ); return; } if ($self->{wheels}{$wheel_id}{compress_pending}) { delete $self->{wheels}{$wheel_id}{compress_pending}; $self->{wheels}{$wheel_id}{wheel}->get_input_filter()->unshift( POE::Filter::Zlib::Stream->new(), ); $self->send_event("$self->{prefix}compressed_conn", $wheel_id); return; } return; } sub _conn_input { my ($kernel, $self, $input, $wheel_id) = @_[KERNEL, OBJECT, ARG0, ARG1]; my $conn = $self->{wheels}{$wheel_id}; if ($self->{raw_events}) { $self->send_event( "$self->{prefix}raw_input", $wheel_id, $input->{raw_line}, ); } $conn->{seen} = time(); $kernel->delay_adjust($conn->{alarm}, $conn->{idle}); # TODO: Antiflood code if ($self->antiflood($wheel_id)) { $self->_anti_flood($wheel_id, $input); } else { my $event = "$self->{prefix}cmd_" . lc $input->{command}; $self->send_event($event, $wheel_id, $input); } return; } sub _event_dispatcher { my ($kernel, $self, $wheel_id) = @_[KERNEL, OBJECT, ARG0]; if (!$self->connection_exists($wheel_id) || $self->{wheels}{$wheel_id}{flooded}) { return; } shift @{ $self->{wheels}{$wheel_id}{alarm_ids} }; my $input = shift @{ $self->{wheels}{$wheel_id}{msq} }; if ($input) { my $event = "$self->{prefix}cmd_" . lc $input->{command}; $self->send_event($event, $wheel_id, $input); } return; } sub send_output { my ($self, $output) = splice @_, 0, 2; if ($output && ref $output eq 'HASH') { for my $id (grep { $self->connection_exists($_) } @_) { if ($self->{raw_events}) { my $out = $self->{filter}->put([$output])->[0]; $out =~ s/\015\012$//; $self->send_event("$self->{prefix}raw_output", $id, $out); } $self->{wheels}{$id}{wheel}->put($output); } } return; } sub _send_output { $_[OBJECT]->send_output(@_[ARG0..$#_]); return; } sub antiflood { my ($self, $wheel_id, $value) = @_; return if !$self->connection_exists($wheel_id); return 0 if !$self->{antiflood}; return $self->{wheels}{$wheel_id}{antiflood} if !defined $value; if (!$value) { # Flush pending messages from that wheel while (my $alarm_id = shift @{ $self->{wheels}{$wheel_id}{alarm_ids} }) { $poe_kernel->alarm_remove($alarm_id); my $input = shift @{ $self->{wheels}{$wheel_id}{msq} }; if ($input) { my $event = "$self->{prefix}cmd_" . lc $input->{command}; $self->send_event($event, $wheel_id, $input); } } } $self->{wheels}{$wheel_id}{antiflood} = $value; return; } sub compressed_link { my ($self, $wheel_id, $value, $cntr) = @_; return if !$self->connection_exists($wheel_id); return $self->{wheels}{$wheel_id}{compress} if !defined $value; if ($value) { if (!$self->{got_zlib}) { eval { require POE::Filter::Zlib::Stream; $self->{got_zlib} = 1; }; chomp $@; croak($@) if !$self->{got_zlib}; } if ($cntr) { $self->{wheels}{$wheel_id}{wheel}->get_input_filter()->unshift( POE::Filter::Zlib::Stream->new() ); $self->send_event( "$self->{prefix}compressed_conn", $wheel_id, ); } else { $self->{wheels}{$wheel_id}{compress_pending} = 1; } } else { $self->{wheels}{$wheel_id}{wheel}->get_input_filter()->shift(); } $self->{wheels}{$wheel_id}{compress} = $value; return; } sub disconnect { my ($self, $wheel_id, $string) = @_; return if !$wheel_id || !$self->connection_exists($wheel_id); $self->{wheels}{$wheel_id}{disconnecting} = $string || 'Client Quit'; return; } sub _disconnected { my ($self, $wheel_id, $errstr) = @_; return if !$wheel_id || !$self->connection_exists($wheel_id); my $conn = delete $self->{wheels}{$wheel_id}; for my $alarm_id ($conn->{alarm}, @{ $conn->{alarm_ids} }) { $poe_kernel->alarm_remove($_); } $self->send_event( "$self->{prefix}disconnected", $wheel_id, $errstr || 'Client Quit', ); if ( $^O =~ /(cygwin|MSWin)/ ) { $conn->{wheel}->shutdown_input(); $conn->{wheel}->shutdown_output(); } return 1; } sub connection_info { my ($self, $wheel_id) = @_; return if !$self->connection_exists($wheel_id); return map { $self->{wheels}{$wheel_id}{$_} } qw(peeraddr peerport sockaddr sockport); } sub connection_exists { my ($self, $wheel_id) = @_; return if !$wheel_id || !defined $self->{wheels}{$wheel_id}; return 1; } sub _conn_flooded { my $self = shift; my $conn_id = shift || return; return if !$self->connection_exists($conn_id); return $self->{wheels}{$conn_id}{flooded}; } sub add_denial { my $self = shift; my $netmask = shift || return; my $reason = shift || 'Denied'; return if !$netmask->isa('Net::Netmask'); $self->{denials}{$netmask} = { blk => $netmask, reason => $reason, }; return 1; } sub del_denial { my $self = shift; my $netmask = shift || return; return if !$netmask->isa('Net::Netmask'); return if !$self->{denials}{$netmask}; delete $self->{denials}{$netmask}; return 1; } sub add_exemption { my $self = shift; my $netmask = shift || return; return if !$netmask->isa('Net::Netmask'); if (!$self->{exemptions}{$netmask}) { $self->{exemptions}{$netmask} = $netmask; } return 1; } sub del_exemption { my $self = shift; my $netmask = shift || return; return if !$netmask->isa('Net::Netmask'); return if !$self->{exemptions}{$netmask}; delete $self->{exemptions}{$netmask}; return 1; } sub denied { my $self = shift; my $ipaddr = shift || return; return if $self->exempted($ipaddr); for my $mask (keys %{ $self->{denials} }) { if ($self->{denials}{$mask}{blk}->match($ipaddr)) { return $self->{denials}{$mask}{reason}; } } return; } sub exempted { my $self = shift; my $ipaddr = shift || return; for my $mask (keys %{ $self->{exemptions} }) { return 1 if $self->{exemptions}{$mask}->match($ipaddr); } return; } 1; =encoding utf8 =head1 NAME POE::Component::Server::IRC::Backend - A POE component class that provides network connection abstraction for POE::Component::Server::IRC =head1 SYNOPSIS package MyIRCD; use strict; use warnings; use base 'POE::Component::Server::IRC::Backend'; sub spawn { my ($package, %args) = @_; my $self = $package->create(prefix => 'ircd_', @_); # process %args ... return $self; } =head1 DESCRIPTION POE::Component::Server::IRC::Backend - A POE component class that provides network connection abstraction for L. It uses a plugin system. See L for details. =head1 CONSTRUCTOR =head2 C Returns an object. Accepts the following parameters, all are optional: =over 4 =item * B<'alias'>, a POE::Kernel alias to set; =item * B<'auth'>, set to a false value to globally disable IRC authentication, default is auth is enabled; =item * B<'antiflood'>, set to a false value to globally disable flood protection, default is true; =item * B<'prefix'>, this is the prefix that is used to generate event names that the component produces. The default is 'ircd_'. =item * B<'states'>, an array reference of extra objects states for the IRC daemon's POE sessions. The elements can be array references of states as well as hash references of state => handler pairs. =item * B<'plugin_debug'>, set to a true value to print plugin debug info. Default is false. =item * B<'options'>, a hashref of options to L =item * B<'raw_events'>, whether to send L events. False by default. Can be enabled later with L|/raw_events>; =back If the component is created from within another session, that session will be automagcially registered with the component to receive events and get an 'ircd_backend_registered' event. =head1 METHODS =head2 General =head3 C Takes no arguments. Terminates the component. Removes all listeners and connectors. Disconnects all current client and server connections. This is a shorthand for C<< $ircd->yield('shutdown') >>. =head3 C I> Takes no arguments. Returns the ID of the component's session. Ideal for posting events to the component. =head3 C I> Takes no arguments. Returns the session alias that has been set through L|/create>'s B<'alias'> argument. =head3 C I> This method provides an alternative object based means of posting events to the component. First argument is the event to post, following arguments are sent as arguments to the resultant post. =head3 C I> This method provides an alternative object based means of calling events to the component. First argument is the event to call, following arguments are sent as arguments to the resultant call. =head3 C I> This method provides a way of posting delayed events to the component. The first argument is an arrayref consisting of the delayed command to post and any command arguments. The second argument is the time in seconds that one wishes to delay the command being posted. Returns an alarm ID that can be used with L|/delay_remove> to cancel the delayed event. This will be undefined if something went wrong. =head3 C I> This method removes a previously scheduled delayed event from the component. Takes one argument, the C that was returned by a L|/delay> method call. Returns an arrayref that was originally requested to be delayed. =head3 C I> Sends an event through the component's event handling system. These will get processed by plugins then by registered sessions. First argument is the event name, followed by any parameters for that event. =head3 C I> This sends an event right after the one that's currently being processed. Useful if you want to generate some event which is directly related to another event so you want them to appear together. This method can only be called when POE::Component::IRC is processing an event, e.g. from one of your event handlers. Takes the same arguments as L|/send_event>. =head3 C I> This will send an event to be processed immediately. This means that if an event is currently being processed and there are plugins or sessions which will receive it after you do, then an event sent with C will be received by those plugins/sessions I the current event. Takes the same arguments as L|/send_event>. =head3 C If called with a true value, raw events (L|/ircd_raw_input> and L|/ircd_raw_output>) will be enabled. =head2 Connections =head3 C Takes two arguments, a connection id and true/false value. If value is specified antiflood protection is enabled or disabled accordingly for the specified connection. If a value is not specified the current status of antiflood protection is returned. Returns undef on error. =head3 C Takes two arguments, a connection id and true/false value. If a value is specified, compression will be enabled or disabled accordingly for the specified connection. If a value is not specified the current status of compression is returned. Returns undef on error. =head3 C Requires on argument, the connection id you wish to disconnect. The component will terminate the connection the next time that the wheel input is flushed, so you may send some sort of error message to the client on that connection. Returns true on success, undef on error. =head3 C Requires one argument, a connection id. Returns true value if the connection exists, false otherwise. =head3 C Takes one argument, a connection_id. Returns a list consisting of: the IP address of the peer; the port on the peer; our socket address; our socket port. Returns undef on error. my ($peeraddr, $peerport, $sockaddr, $sockport) = $ircd->connection_info($conn_id); =head3 C Takes one mandatory argument and one optional. The first mandatory argument is a L object that will be used to check connecting IP addresses against. The second optional argument is a reason string for the denial. =head3 C Takes one mandatory argument, a L object to remove from the current denial list. =head3 C Takes one argument, an IP address. Returns true or false depending on whether that IP is denied or not. =head3 C Takes one mandatory argument, a L object that will be checked against connecting IP addresses for exemption from denials. =head3 C Takes one mandatory argument, a L object to remove from the current exemption list. =head3 C Takes one argument, an IP address. Returns true or false depending on whether that IP is exempt from denial or not. =head2 Plugins =head3 C I> Returns the L object. =head3 C I> Accepts two arguments: The alias for the plugin The actual plugin object Any number of extra arguments The alias is there for the user to refer to it, as it is possible to have multiple plugins of the same kind active in one Object::Pluggable object. This method goes through the pipeline's C method, which will call C<< $plugin->plugin_register($pluggable, @args) >>. Returns the number of plugins now in the pipeline if plugin was initialized, C/an empty list if not. =head3 C I> Accepts the following arguments: The alias for the plugin or the plugin object itself Any number of extra arguments This method goes through the pipeline's C method, which will call C<< $plugin->plugin_unregister($pluggable, @args) >>. Returns the plugin object if the plugin was removed, C/an empty list if not. =head3 C I> Accepts the following arguments: The alias for the plugin This method goes through the pipeline's C method. Returns the plugin object if it was found, C/an empty list if not. =head3 C I> Takes no arguments. Returns a hashref of plugin objects, keyed on alias, or an empty list if there are no plugins loaded. =head3 C I> Takes no arguments. Returns an arrayref of plugin objects, in the order which they are encountered in the pipeline. =head3 C I> Accepts the following arguments: The plugin object The type of the hook (the hook types are specified with _pluggable_init()'s 'types') The event name[s] to watch The event names can be as many as possible, or an arrayref. They correspond to the prefixed events and naturally, arbitrary events too. You do not need to supply events with the prefix in front of them, just the names. It is possible to register for all events by specifying 'all' as an event. Returns 1 if everything checked out fine, C/an empty list if something is seriously wrong. =head3 C I> Accepts the following arguments: The plugin object The type of the hook (the hook types are specified with _pluggable_init()'s 'types') The event name[s] to unwatch The event names can be as many as possible, or an arrayref. They correspond to the prefixed events and naturally, arbitrary events too. You do not need to supply events with the prefix in front of them, just the names. It is possible to register for all events by specifying 'all' as an event. Returns 1 if all the event name[s] was unregistered, undef if some was not found. =head1 INPUT EVENTS These are POE events that the component will accept: =head2 C I> Takes N arguments: a list of event names that your session wants to listen for, minus the C prefix. $ircd->yield('register', qw(connected disconnected)); The special argument 'all' will register your session for all events. Registering will generate an L|/ircd_registered> event that your session can trap. =head2 C I> Takes N arguments: a list of event names which you I want to receive. If you've previously done a L|/register> for a particular event which you no longer care about, this event will tell the component to stop sending them to you. (If you haven't, it just ignores you. No big deal.) If you have registered with 'all', attempting to unregister individual events such as 'connected', etc. will not work. This is a 'feature'. =head2 C Takes a number of arguments. Adds a new listener. =over 4 =item * B<'port'>, the TCP port to listen on. Default is a random port; =item * B<'auth'>, enable or disable auth sub-system for this listener. Enabled by default; =item * B<'bindaddr'>, specify a local address to bind the listener to; =item * B<'listenqueue'>, change the SocketFactory's ListenQueue; =item * B<'usessl'>, whether the listener should use SSL. Default is false; =item * B<'antiflood'>, whether the listener should use flood protection. Defaults is true; =item * B<'idle'>, the time, in seconds, after which a connection will be considered idle. Defaults is 180. =back =head2 C Takes one of the following arguments: =over 4 =item * B<'listener'>, a previously returned listener ID; =item * B<'port'>, a listening port; =back The listener will be deleted. Note: any connected clients on that port will not be disconnected. =head2 C Takes two mandatory arguments, B<'remoteaddress'> and B<'remoteport'>. Opens a TCP connection to specified address and port. =over 4 =item * B<'remoteaddress'>, hostname or IP address to connect to; =item * B<'remoteport'>, the TCP port on the remote host; =item * B<'bindaddress'>, a local address to bind from (optional); =back =head2 C Takes a hashref and one or more connection IDs. $ircd->yield( 'send_output', { prefix => 'blah!~blah@blah.blah.blah', command => 'PRIVMSG', params => ['#moo', 'cows go moo, not fish :D'] }, @list_of_connection_ids, ); =head2 C I> Takes no arguments. Terminates the component. Removes all listeners and connectors. Disconnects all current client and server connections. =head1 OUTPUT EVENTS These following events are sent to interested sessions. =head2 C I> =over =item Emitted: when a session registers with the component; =item Target: the registering session; =item Args: =over 4 =item * C: the component's object; =back =back =head2 C =over =item Emitted: when a client connects to one of the component's listeners; =item Target: all plugins and registered sessions =item Args: =over 4 =item * C: the conn id; =item * C: their ip address; =item * C: their tcp port; =item * C: our ip address; =item * C: our socket port; =item * C: a boolean indicating whether the client needs to be authed =back =back =head2 C =over =item Emitted: after a client has connected and the component has validated hostname and ident; =item Target: Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, a HASHREF with the following keys: 'ident' and 'hostname'; =back =back =head2 C =over =item Emitted: on a successful L|/add_listener> call; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the listening port; =item * C, the listener id; =item * C, the listening address; =back =back =head2 C =over =item Emitted: on a successful L|/del_listener> call; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the listening port; =item * C, the listener id; =item * C, the listener address; =back =back =head2 C =over =item Emitted: when a listener wheel fails; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the listener id; =item * C, the name of the operation that failed; =item * C, numeric value for $!; =item * C, string value for $!; =item * C, the port it tried to listen on; =item * C, the address it tried to listen on; =back =back =head2 C =over =item Emitted: on the failure of an L|/add_connector> call =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, a HASHREF containing the params that add_connector() was called with; =item * C, the name of the operation that failed; =item * C, numeric value for $!; =item * C, string value for $!; =back =back =head2 C =over =item Emitted: when the component establishes a connection with a peer; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, their ip address; =item * C, their tcp port; =item * C, our ip address; =item * C, our socket port; =item * C, the peer's name; =back =back =head2 C =over =item Emitted: when a client connection is flooded; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =back =back =head2 C =over =item Emitted: when a client connection has not sent any data for a set period; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, the number of seconds period we consider as idle; =back =back =head2 C =over =item Emitted: when compression has been enabled for a connection =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =back =back =head2 C =over =item Emitted: when a client or peer sends a valid IRC line to us; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, a HASHREF containing the output record from POE::Filter::IRCD: { prefix => 'blah!~blah@blah.blah.blah', command => 'PRIVMSG', params => [ '#moo', 'cows go moo, not fish :D' ], raw_line => ':blah!~blah@blah.blah.blah.blah PRIVMSG #moo :cows go moo, not fish :D' } =back =back =head2 C =over =item Emitted: when a line of input is received from a connection =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, the raw line of input =back =back =head2 C =over =item Emitted: when a line of output is sent over a connection =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, the raw line of output =back =back =head2 C =over =item Emitted: when a client disconnects; =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C, the connection id; =item * C, the error or reason for disconnection; =back =back =head2 C I> =over =item Emitted: when the component has been asked to L|/shutdown> =item Target: all registered sessions; =item Args: =over 4 =item * C: the session ID of the requesting component =back =back =head2 C I> =over =item Emitted: on a successful addition of a delayed event using the L|/delay> method =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C: the alarm id which can be used later with L|/delay_remove> =item * C: subsequent arguments are those which were passed to L|/delay> =back =back =head2 C I> =over =item Emitted: when a delayed command is successfully removed =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C: the alarm id which was removed =item * C: subsequent arguments are those which were passed to L|/delay> =back =back =head2 C I> =over =item Emitted: when a new plugin is added to the pipeline =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C: the plugin alias =item * C: the plugin object =back =back =head2 C I> =over =item Emitted: when a plugin is removed from the pipeline =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C: the plugin alias =item * C: the plugin object =back =back =head2 C I> =over =item Emitted: when an error occurs while executing a plugin handler =item Target: all plugins and registered sessions; =item Args: =over 4 =item * C: the error message =item * C: the plugin alias =item * C: the plugin object =back =back =head1 AUTHOR Chris 'BinGOs' Williams =head1 LICENSE Copyright E Chris Williams This module may be used, modified, and distributed under the same terms as Perl itself. Please see the license that came with your Perl distribution for details. =head1 SEE ALSO L L L =cut POE-Component-IRC-6.90/t/inc/POE/Component/Server/IRC/Plugin.pm0000644000175000017500000001322213153565114023056 0ustar bingosbingospackage POE::Component::Server::IRC::Plugin; BEGIN { $POE::Component::Server::IRC::Plugin::AUTHORITY = 'cpan:HINRIK'; } BEGIN { $POE::Component::Server::IRC::Plugin::VERSION = '1.52'; } use strict; use warnings FATAL => 'all'; require Exporter; use base qw(Exporter); our @EXPORT_OK = qw(PCSI_EAT_NONE PCSI_EAT_CLIENT PCSI_EAT_PLUGIN PCSI_EAT_ALL); our %EXPORT_TAGS = ( ALL => [@EXPORT_OK] ); use constant { PCSI_EAT_NONE => 1, PCSI_EAT_CLIENT => 2, PCSI_EAT_PLUGIN => 3, PCSI_EAT_ALL => 4, }; 1; =encoding utf8 =head1 NAME POE::Component::Server::IRC::Plugin - Provides plugin documentation for POE::Component::Server::IRC. =head1 DESCRIPTION This is the document coders/users should refer to when using/developing plugins for POE::Component::Server::IRC. The plugin system works by letting coders hook into aspects of POE::Component::Server::IRC::Backend. More details are found in the docs for L. The general architecture of using the plugins should be: # Import the stuff... use POE; use POE::Component::Server::IRC::Backend; use POE::Component::Server::IRC::Plugin::ExamplePlugin; # Create our session here POE::Session->create( ... ); # Create the IRC session here my $irc = POE::Component::Server::IRC::Backend->spawn() or die 'Nooo!'; # Create the plugin # Of course it could be something like $plugin = MyPlugin->new(); my $plugin = POE::Component::Server::IRC::Plugin::ExamplePlugin->new( ... ); # Hook it up! $irc->plugin_add( 'ExamplePlugin', $plugin ); # OOPS, we lost the plugin object! my $pluginobj = $irc->plugin_get( 'ExamplePlugin' ); # We want a list of plugins and objects my $hashref = $irc->plugin_list(); # Oh! We want a list of plugin aliases. my @aliases = keys %{ $irc->plugin_list() }; # Ah, we want to remove the plugin $plugin = $irc->plugin_del( 'ExamplePlugin' ); The plugins themselves will conform to the standard API described here. What they can do is limited only by imagination and the IRC RFC's ;) package POE::Component::Server::IRC::ExamplePlugin; # Import the constants use POE::Component::Server::IRC::Plugin qw( :ALL ); # Our constructor sub new { # ... } # Required entry point for POE::Component::Server::IRC::Backend sub PCSI_register { my ($self, $irc) = @_; # Register events we are interested in $irc->plugin_register( $self, 'SERVER', qw(connection) ); # Return success return 1; } # Required exit point for PoCo-Server-IRC sub PCSI_unregister { my ($self, $irc) = @_; # PCSIB will automatically unregister events for the plugin # Do some cleanup... # Return success return 1; } # Registered events will be sent to methods starting with IRC_ # If the plugin registered for SERVER - irc_355 sub IRCD_connection { my ($self, $irc, $line) = @_; # Remember, we receive pointers to scalars, so we can modify them $$line = 'frobnicate!'; # Return an exit code return PCSI_EAT_NONE; } # Default handler for events that do not have a corresponding # plugin method defined. sub _default { my ($self, $irc, $event) = splice @_, 0, 3; print "Default called for $event\n"; # Return an exit code return PCSI_EAT_NONE; } =head2 Pipeline The plugins are given priority on a first come, first serve basis. Therefore, plugins that were added before others have the first shot at processing events. See L for details. my $pipeline = $ircd->pipeline(); =head1 EVENTS =head2 SERVER hooks Hooks that are targeted toward data received from the server will get the exact same arguments as if it was a normal event, look at the POE::Component::Server::IRC::Backend docs for more information. B Server methods are identified in the plugin namespace by the subroutine prefix of IRCD_*. I.e. an ircd_cmd_kick event handler would be: sub IRCD_cmd_kick {} The only difference is instead of getting scalars, the hook will get a reference to the scalar, to allow it to mangle the data. This allows the plugin to modify data *before* they are sent out to registered sessions. They are required to return one of the exit codes so POE::Component::Server::IRC::Backend will know what to do. Names of potential hooks: socketerr connected plugin_del ... Keep in mind that they are always lowercased, check out the POE::Component::Server::IRC documentation. =head2 C<_default> If a plugin doesn't have a specific hook method defined for an event, the component will attempt to call a plugin's C<_default> method. The first parameter after the plugin and irc objects will be the handler name. sub _default { my ($self, $irc, $event) = splice @_, 0, 3; return PCSI_EAT_NONE; } The C<_default> handler is expected to return one of the exit codes so POE::Component::Server::IRC::Backend will know what to do. =head1 EXPORTS The following constants are exported on demand. =head2 C This means the event will continue to be processed by remaining plugins and finally, sent to interested sessions that registered for it. =head2 C This means the event will continue to be processed by remaining plugins but it will not be sent to any sessions that registered for it. =head2 C This means the event will not be processed by remaining plugins, it will go straight to interested sessions. =head2 C This means the event will be completely discarded, no plugin or session will see it. =head1 SEE ALSO L =cut POE-Component-IRC-6.90/t/inc/POE/Component/Server/IRC/Plugin/0000755000175000017500000000000013153565114022520 5ustar bingosbingosPOE-Component-IRC-6.90/t/inc/POE/Component/Server/IRC/Plugin/Auth.pm0000644000175000017500000002017513153565114023764 0ustar bingosbingospackage POE::Component::Server::IRC::Plugin::Auth; BEGIN { $POE::Component::Server::IRC::Plugin::Auth::AUTHORITY = 'cpan:HINRIK'; } BEGIN { $POE::Component::Server::IRC::Plugin::Auth::VERSION = '1.52'; } use strict; use warnings; use Carp 'croak'; use POE; use POE::Component::Client::Ident::Agent; use POE::Component::Client::DNS; use POE::Component::Server::IRC::Plugin 'PCSI_EAT_NONE'; sub new { my ($package, %args) = @_; return bless \%args, $package; } sub PCSI_register { my ($self, $ircd) = splice @_, 0, 2; $self->{ircd} = $ircd; POE::Session->create( object_states => [ $self => [qw( _start resolve_hostname resolve_ident got_hostname )], $self => { ident_agent_reply => 'got_ident', ident_agent_error => 'got_ident_error', } ], ); $ircd->plugin_register($self, 'SERVER', qw(connection)); return 1; } sub PCSI_unregister { my ($self, $ircd) = splice @_, 0, 2; $self->{resolver}->shutdown() if $self->{resolver}; return 1; } sub _start { my ($self, $session) = @_[OBJECT, SESSION]; $self->{session_id} = $session->ID; $self->{resolver} = POE::Component::Client::DNS->spawn( Timeout => 10, ); return; } sub IRCD_connection { my ($self, $ircd) = splice @_, 0, 2; pop @_; my ($conn_id, $peeraddr, $peerport, $sockaddr, $sockport, $needs_auth) = map { $$_ } @_; return PCSI_EAT_NONE if !$needs_auth; return PCSI_EAT_NONE if !$ircd->connection_exists($conn_id); $self->{conns}{$conn_id} = { hostname => '', ident => '', }; $ircd->send_output( { command => 'NOTICE', params => ['AUTH', '*** Checking Ident'], }, $conn_id, ); $ircd->send_output( { command => 'NOTICE', params => ['AUTH', '*** Checking Hostname'], }, $conn_id, ); if ($peeraddr =~ /^127\./) { $ircd->send_output( { command => 'NOTICE', params => ['AUTH', '*** Found your hostname'] }, $conn_id, ); $self->{conns}{$conn_id}{hostname} = 'localhost'; $self->_auth_done($conn_id); } else { $poe_kernel->call( $self->{session_id}, 'resolve_hostname', $conn_id, $peeraddr, ); } $poe_kernel->call( $self->{session_id}, 'resolve_ident', $conn_id, $peeraddr, $peerport, $sockaddr, $sockport, ); return PCSI_EAT_NONE; } sub resolve_hostname { my ($self, $conn_id, $peeraddr) = @_[OBJECT, ARG0, ARG1]; my $response = $self->{resolver}->resolve( event => 'got_hostname', host => $peeraddr, type => 'PTR', context => { conn_id => $conn_id, peeraddr => $peeraddr, }, ); $poe_kernel->call('got_hostname', $response) if $response; return; } sub resolve_ident { my ($kernel, $self, $conn_id, $peeraddr, $peerport, $sockaddr, $sockport) = @_[KERNEL, OBJECT, ARG0..$#_]; POE::Component::Client::Ident::Agent->spawn( PeerAddr => $peeraddr, PeerPort => $peerport, SockAddr => $sockaddr, SockPort => $sockport, BuggyIdentd => 1, TimeOut => 10, Reference => $conn_id, ); return; } sub got_hostname { my ($kernel, $self, $response) = @_[KERNEL, OBJECT, ARG0]; my $conn_id = $response->{context}{conn_id}; my $ircd = $self->{ircd}; if (!$ircd->connection_exists($conn_id)) { delete $self->{conns}{$conn_id}; return; } my $fail = sub { $ircd->send_output( { command => 'NOTICE', params => [ 'AUTH', "*** Couldn\'t look up your hostname", ], }, $conn_id, ); if ($self->{conns}{$conn_id}{done} == 2) { $self->_auth_done($conn_id); } }; return $fail->() if !defined $response->{response}; my @answers = $response->{response}->answer(); return $fail->() if !@answers; for my $answer (@answers) { my $context = $response->{context}; $context->{hostname} = $answer->rdatastr(); chop $context->{hostname} if $context->{hostname} =~ /\.$/; my $query = $self->{resolver}->resolve( event => 'got_ip', host => $answer->rdatastr(), context => $context, type => 'A', ); if (defined $query) { $kernel->call($self->{session_id}, 'got_ip', $query); } } return; } sub got_ip { my ($kernel, $self, $response) = @_[KERNEL, OBJECT, ARG0]; my $conn_id = $response->{context}{conn_id}; my $ircd = $self->{ircd}; if (!$ircd->connection_exists($conn_id)) { delete $self->{conns}{$conn_id}; return; } my $fail = sub { $ircd->send_output( { command => 'NOTICE', params => [ 'AUTH', "*** Couldn't look up your hostname", ], }, $conn_id, ); $self->_auth_done($conn_id); }; return $fail->() if !defined $response->{response}; my @answers = $response->{response}->answer(); return $fail->() if !@answers; my $peeraddress = $response->{context}{peeraddress}; my $hostname = $response->{context}{hostname}; for my $answer (@answers) { if ($answer->rdatastr() eq $peeraddress) { $ircd->send_output( { command => 'NOTICE', params => ['AUTH', '*** Found your hostname'], }, $conn_id, ); $self->{conns}{$conn_id}{hostname} = $hostname; $self->_auth_done($conn_id); return; } } $ircd->send_output( { command => 'NOTICE', params => [ 'AUTH', '*** Your forward and reverse DNS do not match', ], }, $conn_id, ); $self->_auth_done($conn_id); return; } sub _auth_done { my ($self, $conn_id) = @_; $self->{conns}{$conn_id}{done}++; return if $self->{conns}{$conn_id}{done} != 2; my $auth = delete $self->{conns}{$conn_id}; $self->{ircd}->send_event( 'auth_done', $conn_id, { ident => $auth->{ident}, hostname => $auth->{hostname}, }, ); return; } sub got_ident_error { my ($kernel, $self, $ref, $error) = @_[KERNEL, OBJECT, ARG0, ARG1]; my $conn_id = $ref->{Reference}; my $ircd = $self->{ircd}; if (!$ircd->connection_exists($conn_id)) { delete $self->{conns}{$conn_id}; return; } $ircd->send_output( { command => 'NOTICE', params => ['AUTH', "*** No Ident response"], }, $conn_id, ); $self->_auth_done($conn_id); return; } sub got_ident { my ($kernel, $self, $ref, $opsys, $other) = @_[KERNEL, OBJECT, ARG0, ARG1, ARG2]; my $conn_id = $ref->{Reference}; my $ircd = $self->{ircd}; if (!$ircd->connection_exists($conn_id)) { delete $self->{conns}{$conn_id}; return; } my $ident = ''; $ident = $other if uc $opsys ne 'OTHER'; $ircd->send_output( { command => 'NOTICE', params => ['AUTH', "*** Got Ident response"], }, $conn_id, ); $self->{conns}{$conn_id}{ident} = $ident; $self->_auth_done($conn_id); return; } 1; =encoding utf8 =head1 NAME POE::Component::Server::IRC::Plugin::Auth - Authentication subsystem of POE::Component::Server::IRC::Backend =head1 DESCRIPTION This module is used internally by L. No need for you to use it. =head1 AUTHOR Hinrik Ern SigurEsson Chris 'BinGOs' Williams =cut POE-Component-IRC-6.90/t/inc/POE/Component/Server/IRC/Plugin/OperServ.pm0000644000175000017500000001066413153565114024632 0ustar bingosbingospackage POE::Component::Server::IRC::Plugin::OperServ; BEGIN { $POE::Component::Server::IRC::Plugin::OperServ::AUTHORITY = 'cpan:HINRIK'; } BEGIN { $POE::Component::Server::IRC::Plugin::OperServ::VERSION = '1.52'; } use strict; use warnings; use POE::Component::Server::IRC::Plugin qw(:ALL); sub new { my ($package, %args) = @_; return bless \%args, $package; } sub PCSI_register { my ($self, $ircd) = splice @_, 0, 2; $ircd->plugin_register($self, 'SERVER', qw(daemon_privmsg daemon_join)); $ircd->yield( 'add_spoofed_nick', { nick => 'OperServ', umode => 'Doi', ircname => 'The OperServ bot', }, ); return 1; } sub PCSI_unregister { return 1; } sub IRCD_daemon_privmsg { my ($self, $ircd) = splice @_, 0, 2; my $nick = (split /!/, ${ $_[0] })[0]; return PCSI_EAT_NONE if !$ircd->state_user_is_operator($nick); my $request = ${ $_[2] }; SWITCH: { if (my ($chan) = $request =~ /^clear\s+(#.+)\s*$/i) { last SWITCH if !$ircd->state_chan_exists($chan); $ircd->yield('daemon_cmd_sjoin', 'OperServ', $chan); last SWITCH; } if (my ($chan) = $request =~ /^join\s+(#.+)\s*$/i) { last SWITCH if !$ircd->state_chan_exists($chan); $ircd->yield('daemon_cmd_join', 'OperServ', $chan); last SWITCH; } if (my ($chan) = $request =~ /^part\s+(#.+)\s*$/i) { last SWITCH unless $ircd->state_chan_exists($chan); $ircd->yield('daemon_cmd_part', 'OperServ', $chan); last SWITCH; } if (my ($chan, $mode) = $request =~ /^mode\s+(#.+)\s+(.+)\s*$/i) { last SWITCH if !$ircd->state_chan_exists($chan); $ircd->yield('daemon_cmd_mode', 'OperServ', $chan, $mode); last SWITCH; } if (my ($chan, $target) = $request =~ /^op\s+(#.+)\s+(.+)\s*$/i) { last SWITCH unless $ircd->state_chan_exists($chan); $ircd->daemon_server_mode($chan, '+o', $target); } } return PCSI_EAT_NONE; } sub IRCD_daemon_join { my ($self, $ircd) = splice @_, 0, 2; my $nick = (split /!/, ${ $_[0] })[0]; if (!$ircd->state_user_is_operator($nick) || $nick eq 'OperServ') { return PCSI_EAT_NONE; } my $channel = ${ $_[1] }; return PCSI_EAT_NONE if $ircd->state_is_chan_op($nick, $channel); $ircd->daemon_server_mode($channel, '+o', $nick); return PCSI_EAT_NONE; } 1; =encoding utf8 =head1 NAME POE::Component::Server::IRC::Plugin::OperServ - An OperServ plugin for POE::Component::Server::IRC =head1 SYNOPSIS use POE::Component::Server::IRC::Plugin::OperServ; $ircd->plugin_add( 'OperServ', POE::Component::Server::IRC::Plugin::OperServ->new(), ); =head1 DESCRIPTION POE::Component::Server::IRC::Plugin::OperServ is a L plugin which provides simple operator services. This plugin provides a server user called OperServ. OperServ accepts PRIVMSG commands from operators. /msg OperServ =head1 METHODS =head2 C Returns a plugin object suitable for feeding to L's C method. =head1 COMMANDS The following commands are accepted: =head2 clear CHANNEL The OperServ will remove all channel modes on the indicated channel, including all users' +ov flags. The timestamp of the channel will be reset and the OperServ will join that channel with +o. =head2 join CHANNEL The OperServ will simply join the channel you specify with +o. =head2 part CHANNEL The OperServ will part (leave) the channel specified. =head2 mode CHANNEL MODE The OperServ will set the channel mode you tell it to. You can also remove the channel mode by prefixing the mode with a '-' (minus) sign. =head2 op CHANNEL USER The OperServ will give +o to any user on a channel you specify. OperServ does not need to be in that channel (as this is mostly a server hack). Whenever the OperServ joins a channel (which you specify with the join command) it will automatically gain +o. =head1 AUTHOR Chris 'BinGOs' Williams =head1 LICENSE Copyright C<(c)> Chris Williams This module may be used, modified, and distributed under the same terms as Perl itself. Please see the license that came with your Perl distribution for details. =head1 SEE ALSO L =cut POE-Component-IRC-6.90/t/inc/POE/Component/IRC/0000755000175000017500000000000013153565114020014 5ustar bingosbingosPOE-Component-IRC-6.90/t/inc/POE/Component/IRC/Test/0000755000175000017500000000000013153565114020733 5ustar bingosbingosPOE-Component-IRC-6.90/t/inc/POE/Component/IRC/Test/Plugin.pm0000644000175000017500000000524413153565114022534 0ustar bingosbingospackage POE::Component::IRC::Test::Plugin; use strict; use warnings FATAL => 'all'; use POE::Component::IRC::Plugin qw( :ALL ); sub new { return bless { @_[1..$#_] }, $_[0]; } sub PCI_register { $_[1]->plugin_register( $_[0], 'SERVER', qw(all) ); return 1; } sub PCI_unregister { return 1; } sub _default { return PCI_EAT_NONE; } 1; __END__ =head1 NAME POE::Component::IRC::Test::Plugin - Part of the L test-suite. =head1 SYNOPSIS use Test::More tests => 16; BEGIN { use_ok('POE::Component::IRC') }; BEGIN { use_ok('POE::Component::IRC::Test::Plugin') }; use POE; my $self = POE::Component::IRC->spawn( ); isa_ok ( $self, 'POE::Component::IRC' ); POE::Session->create( inline_states => { _start => \&test_start, }, package_states => [ main => [ qw(irc_plugin_add irc_plugin_del) ], ], ); $poe_kernel->run(); sub test_start { my ($kernel, $heap) = @_[KERNEL, HEAP]; $self->yield( 'register' => 'all' ); my $plugin = POE::Component::IRC::Test::Plugin->new(); isa_ok ( $plugin, 'POE::Component::IRC::Test::Plugin' ); $heap->{counter} = 6; if ( !$self->plugin_add( 'TestPlugin' => $plugin ) ) { fail( 'plugin_add' ); $self->yield( 'unregister' => 'all' ); $self->yield( 'shutdown' ); } return: } sub irc_plugin_add { my ($kernel, $heap, $desc, $plugin) = @_[KERNEL, HEAP, ARG0, ARG1]; isa_ok ( $plugin, 'POE::Component::IRC::Test::Plugin' ); if ( !$self->plugin_del( 'TestPlugin' ) ) { fail( 'plugin_del' ); $self->yield( 'unregister' => 'all' ); $self->yield( 'shutdown' ); } return; } sub irc_plugin_del { my ($kernel, $heap, $desc, $plugin) = @_[KERNEL, HEAP, ARG0, ARG1]; isa_ok ( $plugin, 'POE::Component::IRC::Test::Plugin' ); $heap->{counter}--; if ( $heap->{counter} <= 0 ) { $self->yield( 'unregister' => 'all' ); $self->yield( 'shutdown' ); } else { if ( !$self->plugin_add( 'TestPlugin' => $plugin ) ) { fail( 'plugin_add' ); $self->yield( 'unregister' => 'all' ); $self->yield( 'shutdown' ); } } return: } =head1 DESCRIPTION POE::Component::IRC::Test::Plugin is a very simple L plugin used to test that the plugin system is working correctly, as demonstrated in the L. =head1 CONSTRUCTOR =over =item C No arguments required, returns an POE::Component::IRC::Test::Plugin object. =back =head1 AUTHOR Chris "BinGOs" Williams =head1 SEE ALSO L =cut POE-Component-IRC-6.90/t/inc/Net/0000755000175000017500000000000013153565114015540 5ustar bingosbingosPOE-Component-IRC-6.90/t/inc/Net/Netmask.pm0000644000175000017500000003043613153565114017506 0ustar bingosbingos# Copyright (C) 1998-2006, David Muir Sharnoff package Net::Netmask; use vars qw($VERSION); $VERSION = 1.9015; require Exporter; @ISA = qw(Exporter); @EXPORT = qw(findNetblock findOuterNetblock findAllNetblock cidrs2contiglists range2cidrlist sort_by_ip_address dumpNetworkTable sort_network_blocks cidrs2cidrs cidrs2inverse); @EXPORT_OK = (@EXPORT, qw(int2quad quad2int %quadmask2bits %quadhostmask2bits imask sameblock cmpblocks contains)); my $remembered = {}; my %imask2bits; my %size2bits; my @imask; # our %quadmask2bits; # our %quadhostmask2bits; use vars qw($error $debug %quadmask2bits %quadhostmask2bits); $debug = 1; use strict; use warnings FATAL => 'all'; use Carp; use overload '""' => \&desc, '<=>' => \&cmp_net_netmask_block, 'cmp' => \&cmp_net_netmask_block, 'fallback' => 1; sub new { my ($package, $net, $mask) = @_; $mask = '' unless defined $mask; my $base; my $bits; my $ibase; undef $error; if ($net =~ m,^(\d+\.\d+\.\d+\.\d+)/(\d+)$,) { ($base, $bits) = ($1, $2); } elsif ($net =~ m,^(\d+\.\d+\.\d+\.\d+)[:/](\d+\.\d+\.\d+\.\d+)$,) { $base = $1; my $quadmask = $2; if (exists $quadmask2bits{$quadmask}) { $bits = $quadmask2bits{$quadmask}; } else { $error = "illegal netmask: $quadmask"; } } elsif ($net =~ m,^(\d+\.\d+\.\d+\.\d+)[#](\d+\.\d+\.\d+\.\d+)$,) { $base = $1; my $hostmask = $2; if (exists $quadhostmask2bits{$hostmask}) { $bits = $quadhostmask2bits{$hostmask}; } else { $error = "illegal hostmask: $hostmask"; } } elsif (($net =~ m,^\d+\.\d+\.\d+\.\d+$,) && ($mask =~ m,\d+\.\d+\.\d+\.\d+$,)) { $base = $net; if (exists $quadmask2bits{$mask}) { $bits = $quadmask2bits{$mask}; } else { $error = "illegal netmask: $mask"; } } elsif (($net =~ m,^\d+\.\d+\.\d+\.\d+$,) && ($mask =~ m,0x[a-z0-9]+,i)) { $base = $net; my $imask = hex($mask); if (exists $imask2bits{$imask}) { $bits = $imask2bits{$imask}; } else { $error = "illegal netmask: $mask ($imask)"; } } elsif ($net =~ /^\d+\.\d+\.\d+\.\d+$/ && ! $mask) { ($base, $bits) = ($net, 32); } elsif ($net =~ /^\d+\.\d+\.\d+$/ && ! $mask) { ($base, $bits) = ("$net.0", 24); } elsif ($net =~ /^\d+\.\d+$/ && ! $mask) { ($base, $bits) = ("$net.0.0", 16); } elsif ($net =~ /^\d+$/ && ! $mask) { ($base, $bits) = ("$net.0.0.0", 8); } elsif ($net =~ m,^(\d+\.\d+\.\d+)/(\d+)$,) { ($base, $bits) = ("$1.0", $2); } elsif ($net =~ m,^(\d+\.\d+)/(\d+)$,) { ($base, $bits) = ("$1.0.0", $2); } elsif ($net =~ m,^(\d+)/(\d+)$,) { ($base, $bits) = ("$1.0.0.0", $2); } elsif ($net eq 'default' || $net eq 'any') { ($base, $bits) = ("0.0.0.0", 0); } elsif ($net =~ m,^(\d+\.\d+\.\d+\.\d+)\s*-\s*(\d+\.\d+\.\d+\.\d+)$,) { # whois format $ibase = quad2int($1); my $end = quad2int($2); $error = "illegal dotted quad: $net" unless defined($ibase) && defined($end); my $diff = ($end || 0) - ($ibase || 0) + 1; $bits = $size2bits{$diff}; $error = "could not find exact fit for $net" if ! defined $error && ( ! defined $bits || ($ibase & ~$imask[$bits])); } else { $error = "could not parse $net"; $error .= " $mask" if $mask; } carp $error if $error && $debug; $ibase = quad2int($base || 0) unless defined $ibase; unless (defined($ibase) || defined($error)) { $error = "could not parse $net"; $error .= " $mask" if $mask; } $ibase &= $imask[$bits] if defined $ibase && defined $bits; $bits = 0 unless $bits; if ($bits > 32) { $error = "illegal number of bits: $bits" unless $error; $bits = 32; } return bless { 'IBASE' => $ibase, 'BITS' => $bits, ( $error ? ( 'ERROR' => $error ) : () ), }; } sub new2 { local($debug) = 0; my $net = new(@_); return undef if $error; return $net; } sub errstr { return $error; } sub debug { my $this = shift; return (@_ ? $debug = shift : $debug) } sub base { my ($this) = @_; return int2quad($this->{'IBASE'}); } sub bits { my ($this) = @_; return $this->{'BITS'}; } sub size { my ($this) = @_; return 2**(32- $this->{'BITS'}); } sub next { my ($this) = @_; int2quad($this->{'IBASE'} + $this->size()); } sub broadcast { my($this) = @_; int2quad($this->{'IBASE'} + $this->size() - 1); } *first = \&base; *last = \&broadcast; sub desc { return int2quad($_[0]->{'IBASE'}).'/'.$_[0]->{'BITS'}; } sub imask { return (2**32 -(2** (32- $_[0]))); } sub mask { my ($this) = @_; return int2quad ( $imask[$this->{'BITS'}]); } sub hostmask { my ($this) = @_; return int2quad ( ~ $imask[$this->{'BITS'}]); } sub nth { my ($this, $index, $bitstep) = @_; my $size = $this->size(); my $ibase = $this->{'IBASE'}; $bitstep = 32 unless $bitstep; my $increment = 2**(32-$bitstep); $index *= $increment; $index += $size if $index < 0; return undef if $index < 0; return undef if $index >= $size; return int2quad($ibase+$index); } sub enumerate { my ($this, $bitstep) = @_; $bitstep = 32 unless $bitstep; my $size = $this->size(); my $increment = 2**(32-$bitstep); my @ary; my $ibase = $this->{'IBASE'}; for (my $i = 0; $i < $size; $i += $increment) { push(@ary, int2quad($ibase+$i)); } return @ary; } sub inaddr { my ($this) = @_; my $ibase = $this->{'IBASE'}; my $blocks = int($this->size()/256); return (join('.',unpack('xC3', pack('V', $ibase))).".in-addr.arpa", $ibase%256, $ibase%256+$this->size()-1) if $blocks == 0; my @ary; for (my $i = 0; $i < $blocks; $i++) { push(@ary, join('.',unpack('xC3', pack('V', $ibase+$i*256))) .".in-addr.arpa", 0, 255); } return @ary; } sub tag { my $this = shift; my $tag = shift; my $val = $this->{'T'.$tag}; $this->{'T'.$tag} = $_[0] if @_; return $val; } sub quad2int { my @bytes = split(/\./,$_[0]); return undef unless @bytes == 4 && ! grep {!(/\d+$/ && $_<256)} @bytes; return unpack("N",pack("C4",@bytes)); } sub int2quad { return join('.',unpack('C4', pack("N", $_[0]))); } sub storeNetblock { my ($this, $t) = @_; $t = $remembered unless $t; my $base = $this->{'IBASE'}; $t->{$base} = [] unless exists $t->{$base}; my $mb = maxblock($this); my $b = $this->{'BITS'}; my $i = $b - $mb; $t->{$base}->[$i] = $this; } sub deleteNetblock { my ($this, $t) = @_; $t = $remembered unless $t; my $base = $this->{'IBASE'}; my $mb = maxblock($this); my $b = $this->{'BITS'}; my $i = $b - $mb; return unless defined $t->{$base}; undef $t->{$base}->[$i]; for my $x (@{$t->{$base}}) { return if $x; } delete $t->{$base}; } sub findNetblock { my ($ipquad, $t) = @_; $t = $remembered unless $t; my $ip = quad2int($ipquad); my %done; for (my $b = 32; $b >= 0; $b--) { my $nb = $ip & $imask[$b]; next unless exists $t->{$nb}; my $mb = imaxblock($nb, 32); next if $done{$mb}++; my $i = $b - $mb; confess "$mb, $b, $ipquad, $nb" if ($i < 0 or $i > 32); while ($i >= 0) { return $t->{$nb}->[$i] if defined $t->{$nb}->[$i]; $i--; } } return undef; } sub findOuterNetblock { my ($ipquad, $t) = @_; $t = $remembered unless $t; my $ip; my $mask; if (ref($ipquad)) { $ip = $ipquad->{IBASE}; $mask = $ipquad->{BITS}; } else { $ip = quad2int($ipquad); $mask = 32; } for (my $b = 0; $b <= $mask; $b++) { my $nb = $ip & $imask[$b];; next unless exists $t->{$nb}; my $mb = imaxblock($nb, $mask); my $i = $b - $mb; confess "$mb, $b, $ipquad, $nb" if $i < 0; confess "$mb, $b, $ipquad, $nb" if $i > 32; while ($i >= 0) { return $t->{$nb}->[$i] if defined $t->{$nb}->[$i]; $i--; } } return undef; } sub findAllNetblock { my ($ipquad, $t) = @_; $t = $remembered unless $t; my @ary ; my $ip = quad2int($ipquad); my %done; for (my $b = 32; $b >= 0; $b--) { my $nb = $ip & $imask[$b]; next unless exists $t->{$nb}; my $mb = imaxblock($nb, 32); next if $done{$mb}++; my $i = $b - $mb; confess "$mb, $b, $ipquad, $nb" if $i < 0; confess "$mb, $b, $ipquad, $nb" if $i > 32; while ($i >= 0) { push(@ary, $t->{$nb}->[$i]) if defined $t->{$nb}->[$i]; $i--; } } return @ary; } sub dumpNetworkTable { my ($t) = @_; $t = $remembered unless $t; my @ary; foreach my $base (keys %$t) { push(@ary, grep (defined($_), @{$t->{base}})); for my $x (@{$t->{$base}}) { push(@ary, $x) if defined $x; } } return sort @ary; } sub checkNetblock { my ($this, $t) = @_; $t = $remembered unless $t; my $base = $this->{'IBASE'}; my $mb = maxblock($this); my $b = $this->{'BITS'}; my $i = $b - $mb; return defined $t->{$base}->[$i]; } sub match { my ($this, $ip) = @_; my $i = quad2int($ip); my $imask = $imask[$this->{BITS}]; if (($i & $imask) == $this->{IBASE}) { return (($i & ~ $imask) || "0 "); } else { return 0; } } sub maxblock { my ($this) = @_; return imaxblock($this->{'IBASE'}, $this->{'BITS'}); } sub nextblock { my ($this, $index) = @_; $index = 1 unless defined $index; my $newblock = bless { IBASE => $this->{IBASE} + $index * (2**(32- $this->{BITS})), BITS => $this->{BITS}, }; return undef if $newblock->{IBASE} >= 2**32; return undef if $newblock->{IBASE} < 0; return $newblock; } sub imaxblock { my ($ibase, $tbit) = @_; confess unless defined $ibase; while ($tbit > 0) { my $im = $imask[$tbit-1]; last if (($ibase & $im) != $ibase); $tbit--; } return $tbit; } sub range2cidrlist { my ($startip, $endip) = @_; my $start = quad2int($startip); my $end = quad2int($endip); ($start, $end) = ($end, $start) if $start > $end; return irange2cidrlist($start, $end); } sub irange2cidrlist { my ($start, $end) = @_; my @result; while ($end >= $start) { my $maxsize = imaxblock($start, 32); my $maxdiff = 32 - int(log($end - $start + 1)/log(2)); $maxsize = $maxdiff if $maxsize < $maxdiff; push (@result, bless { 'IBASE' => $start, 'BITS' => $maxsize }); $start += 2**(32-$maxsize); } return @result; } sub cidrs2contiglists { my (@cidrs) = sort_network_blocks(@_); my @result; while (@cidrs) { my (@r) = shift(@cidrs); my $max = $r[0]->{IBASE} + $r[0]->size; while ($cidrs[0] && $cidrs[0]->{IBASE} <= $max) { my $nm = $cidrs[0]->{IBASE} + $cidrs[0]->size; $max = $nm if $nm > $max; push(@r, shift(@cidrs)); } push(@result, [@r]); } return @result; } sub cidrs2cidrs { my (@cidrs) = sort_network_blocks(@_); my @result; while (@cidrs) { my (@r) = shift(@cidrs); my $max = $r[0]->{IBASE} + $r[0]->size; while ($cidrs[0] && $cidrs[0]->{IBASE} <= $max) { my $nm = $cidrs[0]->{IBASE} + $cidrs[0]->size; $max = $nm if $nm > $max; push(@r, shift(@cidrs)); } my $start = $r[0]->{IBASE}; my $end = $max - 1; push(@result, irange2cidrlist($start, $end)); } return @result; } sub cidrs2inverse { my $outer = shift; $outer = __PACKAGE__->new2($outer) || croak($error) unless ref($outer); my (@cidrs) = cidrs2cidrs(@_); my $first = $outer->{IBASE}; my $last = $first + $outer->size() -1; shift(@cidrs) while $cidrs[0] && $cidrs[0]->{IBASE} + $cidrs[0]->size < $first; my @r; while (@cidrs && $first <= $last) { if ($first < $cidrs[0]->{IBASE}) { if ($last <= $cidrs[0]->{IBASE}-1) { return (@r, irange2cidrlist($first, $last)); } push(@r, irange2cidrlist($first, $cidrs[0]->{IBASE}-1)); } last if $cidrs[0]->{IBASE} > $last; $first = $cidrs[0]->{IBASE} + $cidrs[0]->size; shift(@cidrs); } if ($first <= $last) { push(@r, irange2cidrlist($first, $last)); } return @r; } sub by_net_netmask_block { $a->{'IBASE'} <=> $b->{'IBASE'} || $a->{'BITS'} <=> $b->{'BITS'}; } sub sameblock { return ! cmpblocks(@_); } sub cmpblocks { my $this = shift; my $class = ref $this; my $other = (ref $_[0]) ? shift : $class->new(@_); return cmp_net_netmask_block($this, $other); } sub contains { my $this = shift; my $class = ref $this; my $other = (ref $_[0]) ? shift : $class->new(@_); return 0 if $this->{IBASE} > $other->{IBASE}; return 0 if $this->{BITS} > $other->{BITS}; return 0 if $other->{IBASE} > $this->{IBASE} + $this->size -1; return 1; } sub cmp_net_netmask_block { return ($_[0]->{IBASE} <=> $_[1]->{IBASE} || $_[0]->{BITS} <=> $_[1]->{BITS}); } sub sort_network_blocks { return map $_->[0], sort { $a->[1] <=> $b->[1] || $a->[2] <=> $b->[2] } map [ $_, $_->{IBASE}, $_->{BITS} ], @_; } sub sort_by_ip_address { return map $_->[0], sort { $a->[1] cmp $b->[1] } map [ $_, pack("C4",split(/\./,$_)) ], @_; } BEGIN { for (my $i = 0; $i <= 32; $i++) { $imask[$i] = imask($i); $imask2bits{$imask[$i]} = $i; $quadmask2bits{int2quad($imask[$i])} = $i; $quadhostmask2bits{int2quad(~$imask[$i])} = $i; $size2bits{ 2**(32-$i) } = $i; } } 1; POE-Component-IRC-6.90/t/03_subclasses/0000755000175000017500000000000013153565114016712 5ustar bingosbingosPOE-Component-IRC-6.90/t/03_subclasses/03_qnet_state.t0000644000175000017500000000057613153565114021560 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use POE; use POE::Component::IRC::Qnet::State; use Test::More tests => 1; my $bot = POE::Component::IRC::Qnet::State->spawn(); isa_ok($bot, 'POE::Component::IRC::Qnet::State'); $bot->yield('shutdown'); $poe_kernel->run(); POE::Session->create( package_states => [ main => ['_start'] ], ); sub _start { $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/03_subclasses/01_state.t0000644000175000017500000001463113153565114020524 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::Common qw(parse_user); use POE::Component::IRC::State; use POE::Component::Server::IRC; use Test::More 'no_plan'; my $bot = POE::Component::IRC::State->spawn(Flood => 1); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); isa_ok($bot, 'POE::Component::IRC::State'); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_registered irc_connected irc_001 irc_221 irc_305 irc_306 irc_whois irc_join irc_topic irc_chan_sync irc_user_mode irc_chan_mode irc_mode irc_error irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield(connect => { nick => 'TestBot', server => '127.0.0.1', port => $port, ircname => 'Test test bot', }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } sub irc_registered { my ($irc) = $_[ARG0]; isa_ok($irc, 'POE::Component::IRC::State'); } sub irc_connected { pass('Connected'); } sub irc_001 { my ($heap, $server) = @_[HEAP, ARG0]; my $irc = $_[SENDER]->get_heap(); $heap->{server} = $server; pass('Logged in'); is($irc->server_name(), 'poco.server.irc', 'Server Name Test'); is($irc->nick_name(), 'TestBot', 'Nick Name Test'); ok(!$irc->is_operator($irc->nick_name()), 'We are not an IRC op'); ok(!$irc->is_away($irc->nick_name()), 'We are not away'); $irc->yield(away => 'Gone for now'); $irc->yield(whois => 'TestBot'); } sub irc_305 { my $irc = $_[SENDER]->get_heap(); ok(!$irc->is_away($irc->nick_name()), 'We are back'); } sub irc_306 { my $irc = $_[SENDER]->get_heap(); ok($irc->is_away($irc->nick_name()), 'We are away now'); $irc->yield('away'); } sub irc_whois { my ($sender, $whois) = @_[SENDER, ARG0]; is($whois->{nick}, 'TestBot', 'Whois hash test'); $sender->get_heap()->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = parse_user($who); my $irc = $sender->get_heap(); is($nick, $irc->nick_name(), 'JOINER Test'); is($where, '#testchannel', 'Joined Channel Test'); is($who, $irc->nick_long_form($nick), 'nick_long_form()'); my $chans = $irc->channels(); is(keys %$chans, 1, 'Correct number of channels'); is((keys %$chans)[0], $where, 'Correct channel name'); my @nicks = $irc->nicks(); is(@nicks, 1, 'Only one nick known'); is($nicks[0], $nick, 'Nickname correct'); $irc->yield(topic => $where, 'Test topic'); } sub irc_topic { my ($sender, $heap, $chan, $topic) = @_[SENDER, HEAP, ARG1, ARG2]; my $irc = $sender->get_heap(); $heap->{got_topic}++; if ($heap->{got_topic} == 1) { my $topic_info = $irc->channel_topic($chan); is($topic, $topic_info->{Value}, 'Channel topic set'); $heap->{topic} = $topic_info; $irc->yield(topic => $chan, 'New test topic'); } elsif ($heap->{got_topic} == 2) { my $old_topic = $_[ARG3]; is_deeply($old_topic, $heap->{topic}, 'Got old topic'); } } sub irc_chan_sync { my ($sender, $heap, $chan) = @_[SENDER, HEAP, ARG0]; my $irc = $sender->get_heap(); my ($nick, $user, $host) = parse_user($irc->nick_long_form($irc->nick_name())); my ($occupant) = $irc->channel_list($chan); is($occupant, 'TestBot', 'Channel Occupancy Test'); ok($irc->channel_creation_time($chan), 'Got channel creation time'); ok(!$irc->channel_limit($chan), 'There is no channel limit'); ok(!$irc->is_channel_mode_set($chan, 'i'), 'Channel mode i not set yet'); ok($irc->is_channel_member($chan, $nick), 'Is Channel Member'); ok($irc->is_channel_operator($chan, $nick), 'Is Channel Operator'); ok(!$irc->is_channel_halfop($chan, $nick), 'Is not channel halfop'); ok(!$irc->has_channel_voice($chan, $nick), 'Does not have channel voice'); ok($irc->ban_mask($chan, $nick), 'Ban Mask Test'); my @channels = $irc->nick_channels($nick); is(@channels, 1, 'Only present in one channel'); is($channels[0], $chan, 'The channel name matches'); my $info = $irc->nick_info($nick); is($info->{Nick}, $nick, 'nick_info() - Nick'); is($info->{User}, $user, 'nick_info() - User'); is($info->{Host}, $host, 'nick_info() - Host'); is($info->{Userhost}, "$user\@$host", 'nick_info() - Userhost'); is($info->{Hops}, 0, 'nick_info() - Hops'); is($info->{Real}, 'Test test bot', 'nick_info() - Realname'); is($info->{Server}, $heap->{server}, 'nick_info() - Server'); ok(!$info->{IRCop}, 'nick_info() - IRCop'); $irc->yield(mode => $chan, '+l 100'); $heap->{mode_changed} = 1; } sub irc_chan_mode { my ($sender, $heap, $who, $chan, $mode) = @_[SENDER, HEAP, ARG0..ARG2]; my $irc = $sender->get_heap(); return if !$heap->{mode_changed}; $mode =~ s/\+//g; ok($irc->is_channel_mode_set($chan, $mode), "Channel Mode Set: $mode"); is($irc->channel_limit($chan), 100, 'Channel limit correct'); $irc->yield('quit'); } sub irc_user_mode { my ($sender, $who, $mode) = @_[SENDER, ARG0, ARG2]; my $irc = $sender->get_heap(); $mode =~ s/\+//g; ok($irc->is_user_mode_set($mode), "User Mode Set: $mode"); like($irc->umode(), qr/$mode/, 'Correct user mode in state'); } sub irc_mode { my $irc = $_[SENDER]->get_heap(); return if $_[ARG1] !~ /^\#/; } sub irc_221 { my $irc = $_[SENDER]->get_heap(); pass('State did a MODE query'); $irc->yield(mode => $irc->nick_name(), '+iw'); } sub irc_error { pass('irc_error'); } sub irc_disconnected { pass('irc_disconnected'); $poe_kernel->yield('_shutdown'); } POE-Component-IRC-6.90/t/03_subclasses/02_qnet.t0000644000175000017500000000055113153565114020350 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use POE; use POE::Component::IRC::Qnet; use Test::More tests => 1; my $bot = POE::Component::IRC::Qnet->spawn(); isa_ok($bot, 'POE::Component::IRC::Qnet'); $bot->yield('shutdown'); $poe_kernel->run(); POE::Session->create( package_states => [ main => ['_start'] ], ); sub _start { $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/03_subclasses/04_netsplit.t0000644000175000017500000001637013153565114021253 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::Common qw(parse_user); use POE::Component::IRC::State; use POE::Component::Server::IRC; use Test::More tests => 43; my $bot = POE::Component::IRC::State->spawn(Flood => 1); my $ircd1 = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, Config => { servername => 'ircd1.poco.server.irc', }, ); my $ircd2 = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, Config => { servername => 'ircd2.poco.server.irc', }, ); my $pass = 'letmein'; isa_ok($bot, 'POE::Component::IRC::State'); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_registered irc_connected irc_001 irc_join irc_chan_sync irc_nick_sync irc_error irc_quit irc_disconnected ircd_daemon_nick ircd_daemon_eob )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd1->yield('register', 'all'); $ircd1->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $ircd1->add_peer( name => 'ircd2.poco.server.irc', pass => $pass, rpass => $pass, type => 'c' ); $ircd2->add_peer( name => 'ircd1.poco.server.irc', pass => $pass, rpass => $pass, type => 'r', auto => 'r', raddress => '127.0.0.1', rport => $port ); $ircd2->yield( 'register', 'all' ); $ircd2->yield( 'add_spoofed_nick', nick => 'oper', umode => 'o', ); $bot->yield(register => 'all'); $_[HEAP]->{listening_port} = $port; return; #$bot->delay([connect => { # nick => 'TestBot', # server => '127.0.0.1', # port => $port, # ircname => 'Test test bot', #}], 5); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd1->yield('shutdown'); $ircd2->yield('shutdown'); $bot->yield('shutdown'); } sub irc_registered { my ($irc) = $_[ARG0]; isa_ok($irc, 'POE::Component::IRC::State'); } sub irc_connected { pass('Connected'); } sub irc_001 { my ($heap, $server) = @_[HEAP, ARG0]; my $irc = $_[SENDER]->get_heap(); $heap->{server} = $server; pass('Logged in'); is($irc->server_name(), 'ircd1.poco.server.irc', 'Server Name Test'); is($irc->nick_name(), 'TestBot', 'Nick Name Test'); ok(!$irc->is_operator($irc->nick_name()), 'We are not an IRC op'); ok(!$irc->is_away($irc->nick_name()), 'We are not away'); $irc->yield('join','#testchannel'); return; } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = parse_user($who); my $irc = $sender->get_heap(); is($nick, $irc->nick_name(), 'JOINER Test'); is($where, '#testchannel', 'Joined Channel Test'); is($who, $irc->nick_long_form($nick), 'nick_long_form()'); my $chans = $irc->channels(); is(keys %$chans, 1, 'Correct number of channels'); is((keys %$chans)[0], $where, 'Correct channel name'); my @nicks = $irc->nicks(); TODO: { local $TODO = 'Sometimes there is a race condition'; is(@nicks, 2, 'Two nicks known'); } is($nicks[0], $nick, 'Nickname correct'); } sub join_after_split { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = parse_user($who); my $irc = $sender->get_heap(); is($nick, 'oper', 'oper joined'); ok(!defined $bot->{NETSPLIT}->{Users}->{'OPER!oper@ircd2.poco.server.irc'}, 'OPER!oper@ircd2.poco.server.irc' ); ok($irc->is_channel_member($where, $nick), 'Is Channel Member'); TODO: { local $TODO = 'Sometimes there is a race condition'; ok(!$irc->is_channel_operator($where, $nick), 'Is Not Channel Operator'); } $poe_kernel->yield( '_shutdown' ); } sub irc_nick_sync { my ($nick,$chan) = @_[ARG0,ARG1]; pass($_[STATE]); is($nick,'oper','Oper user was synced'); is($chan,'#testchannel','The channel synced was #testchannel'); return; } sub irc_chan_sync { my ($sender, $heap, $chan) = @_[SENDER, HEAP, ARG0]; my $irc = $sender->get_heap(); my ($nick, $user, $host) = parse_user($irc->nick_long_form($irc->nick_name())); my ($occupant) = grep { $_ eq 'TestBot' } $irc->channel_list($chan); is($occupant, 'TestBot', 'Channel Occupancy Test'); ok($irc->channel_creation_time($chan), 'Got channel creation time'); ok(!$irc->channel_limit($chan), 'There is no channel limit'); ok(!$irc->is_channel_mode_set($chan, 'i'), 'Channel mode i not set yet'); ok($irc->is_channel_member($chan, $nick), 'Is Channel Member'); ok(!$irc->is_channel_operator($chan, $nick), 'Is Not Channel Operator'); ok(!$irc->is_channel_halfop($chan, $nick), 'Is not channel halfop'); ok(!$irc->has_channel_voice($chan, $nick), 'Does not have channel voice'); ok($irc->ban_mask($chan, $nick), 'Ban Mask Test'); my @channels = $irc->nick_channels($nick); is(@channels, 1, 'Only present in one channel'); is($channels[0], $chan, 'The channel name matches'); my $info = $irc->nick_info($nick); is($info->{Nick}, $nick, 'nick_info() - Nick'); is($info->{User}, $user, 'nick_info() - User'); is($info->{Host}, $host, 'nick_info() - Host'); is($info->{Userhost}, "$user\@$host", 'nick_info() - Userhost'); is($info->{Hops}, 0, 'nick_info() - Hops'); is($info->{Real}, 'Test test bot', 'nick_info() - Realname'); is($info->{Server}, $heap->{server}, 'nick_info() - Server'); ok(!$info->{IRCop}, 'nick_info() - IRCop'); $ircd2->_daemon_cmd_squit( 'oper', 'ircd1.poco.server.irc' ); } sub irc_error { pass('irc_error'); } sub irc_disconnected { pass('irc_disconnected'); } # We registered for all events, this will produce some debug info. sub _default { my ($event, $args) = @_[ARG0 .. $#_]; my @output = ( "$event: " ); for my $arg (@$args) { if ( ref $arg eq 'ARRAY' ) { push( @output, '[' . join(', ', @$arg ) . ']' ); } else { push ( @output, "'$arg'" ); } } print join ' ', @output, "\n"; return 0; } sub ircd_daemon_nick { my $nickname = $_[ARG0]; return unless $nickname eq 'oper'; $ircd2->yield( daemon_cmd_join => $nickname => '#testchannel' ); return; } sub ircd_daemon_server { diag(join ' ', @_[ARG0..$#_]); return; } sub ircd_daemon_eob { my ($heap,$server) = @_[HEAP,ARG0]; return if $heap->{second}; $heap->{second}++; $bot->delay([connect => { nick => 'TestBot', server => '127.0.0.1', port => $heap->{listening_port}, ircname => 'Test test bot', }], 5); return; } sub irc_quit { ok(defined $bot->{NETSPLIT}->{Users}->{'OPER!oper@ircd2.poco.server.irc'}, 'OPER!oper@ircd2.poco.server.irc' ); $poe_kernel->state( 'irc_join', 'main', 'join_after_split' ); $ircd2->_daemon_cmd_connect( 'oper', 'ircd1.poco.server.irc' ); $_[HEAP]->{netjoin}=1; return; } POE-Component-IRC-6.90/t/03_subclasses/06_state_nick_sync.t0000644000175000017500000000760513153565114022574 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 16; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, AwayPoll => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_366 irc_join irc_nick_sync irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name . ' logged in'); if ($irc == $bot1) { $irc->yield(join => '#testchannel'); $irc->yield(join => '#testchannel2'); } } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); if ($irc == $bot1 && $nick eq $bot2->nick_name() && !$heap->{seen_bot2}) { is($irc->nick_info($bot2->nick_name())->{Server}, undef, $bot1->nick_name(). " hasn't synced ".$bot2->nick_name(). " yet"); $heap->{seen_bot2} = 1; } return if $nick ne $irc->nick_name(); pass($irc->nick_name() . " joined channel $where"); if (keys %{ $bot1->channels } == 2 && !keys %{ $bot2->channels }) { $bot2->yield(join => "#testchannel"); } if ($irc == $bot2 && keys %{ $bot2->channels } == 1) { is($irc->nick_info($bot1->nick_name()), undef, $bot2->nick_name()." doesn't know about ".$bot1->nick_name." yet"); } } sub irc_366 { my ($sender, $heap, $args) = @_[SENDER, HEAP, ARG2]; my $irc = $sender->get_heap(); my $chan = $args->[0]; return if $irc != $bot2; return if $chan ne '#testchannel'; my @nicks = $irc->channel_list($chan); ok(defined $_, 'Nickname is defined') for @nicks; } sub irc_nick_sync { my ($sender, $heap, $nick, $chan) = @_[SENDER, HEAP, ARG0, ARG1]; my $irc = $sender->get_heap(); if ($irc == $bot1) { is($nick, $bot2->nick_name(), 'Nick from irc_nick_sync is correct'); $heap->{nick_sync}++; if ($heap->{nick_sync} == 1) { is($chan, '#testchannel', 'Channel from irc_nick_sync is correct'); $bot2->yield(join => "#testchannel2"); } if ($heap->{nick_sync} == 2) { is($chan, '#testchannel2', 'Channel from irc_nick_sync is correct'); $_->yield('quit') for ($bot1, $bot2); } } } sub irc_disconnected { my ($kernel, $heap, $info) = @_[KERNEL, HEAP, ARG1]; pass($info->{Nick} . ' disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/03_subclasses/05_state_awaypoll.t0000644000175000017500000000654413153565114022444 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::Server::IRC; use Test::More tests => 10; my $bot1 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC::State->spawn( Flood => 1, plugin_debug => 1, AwayPoll => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_chan_sync irc_user_away irc_user_back irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass($irc->nick_name . ' logged in'); if ($irc == $bot1) { $irc->yield(join => '#testchannel'); } } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', $irc->nick_name . ' joined channel'); } sub irc_chan_sync { my ($sender, $where) = @_[SENDER, ARG0]; my $irc = $sender->get_heap(); is($where, '#testchannel', $irc->nick_name . ' synced channel'); if ($irc == $bot1) { $bot2->yield(join => $where); } else { $bot1->yield(away => "I'm gone now"); $bot2->yield(away => "I'm gone now"); } } sub irc_user_away { my ($sender, $nick) = @_[SENDER, ARG0]; my $irc = $sender->get_heap(); if ($irc == $bot1) { fail("Shouldn't get irc_user_away when AwayPoll is off"); } is($nick, $bot1->nick_name(), $bot1->nick_name() .' went away'); $bot1->yield('away'); $bot2->yield('away'); } sub irc_user_back { my ($sender, $nick) = @_[SENDER, ARG0]; my $irc = $sender->get_heap(); if ($irc == $bot1) { fail("Shouldn't get irc_user_back when AwayPoll is off"); } is($nick, $bot1->nick_name(), $bot1->nick_name() .' came back'); $_->yield('quit') for ($bot1, $bot2); } sub irc_disconnected { my ($kernel, $heap, $info) = @_[KERNEL, HEAP, ARG1]; pass($info->{Nick} . ' disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/02_behavior/0000755000175000017500000000000013153565114016341 5ustar bingosbingosPOE-Component-IRC-6.90/t/02_behavior/08_parent_session.t0000644000175000017500000000146013153565114022072 0ustar bingosbingos# This tests the following from IRC.pm's pod: # # Starting with version 4.96, if you spawn the component from inside another # POE session, the component will automatically register that session as # wanting 'all' irc events. That session will receive an irc_registered # event indicating that the component is up and ready to go. use strict; use warnings FATAL => 'all'; use POE; use POE::Component::IRC; use Test::More tests => 2; POE::Session->create( package_states => [ main => [qw(_start irc_registered)], ], ); $poe_kernel->run(); sub _start { my ($heap) = $_[HEAP]; $heap->{irc} = POE::Component::IRC->spawn(); } sub irc_registered { my ($heap, $irc) = @_[HEAP, ARG0]; pass('Child registered us'); isa_ok($irc, 'POE::Component::IRC'); $irc->yield('shutdown'); } POE-Component-IRC-6.90/t/02_behavior/04_ipv6.t0000644000175000017500000001013613153565114017716 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use POE qw(Wheel::SocketFactory Wheel::ReadWrite Filter::Line); use POE::Component::IRC; use Test::More; my $tests = 4; BEGIN { my $GOT_SOCKET6; eval { Socket->import(qw(AF_INET6 unpack_sockaddr_in6 inet_pton)); $GOT_SOCKET6 = 1; }; if (!$GOT_SOCKET6) { eval { require Socket6; Socket6->import(qw(AF_INET6 unpack_sockaddr_in6 inet_pton)); $GOT_SOCKET6 = 1; }; plan skip_all => 'Socket6 is needed for IPv6 tests' if !$GOT_SOCKET6; } } # Argh, we need to be "smart" and see if we need GAI or not... # Perl-5.14.0 will core getaddrinfo() in it's Socket.pm eval { Socket->import('getaddrinfo') }; if ($@) { eval { require Socket::GetAddrInfo; Socket::GetAddrInfo->import(qw(:newapi getaddrinfo)) }; if ($@) { plan skip_all => 'Socket::GetAddrInfo is needed for IPv6 tests'; } } my $addr = eval { inet_pton(AF_INET6, "::1"); }; if (!defined $addr) { plan skip_all => "IPv6 tests require a configured localhost address ('::1')"; } plan tests => $tests; my $bot = POE::Component::IRC->spawn(); POE::Session->create( package_states => [ main => [qw( _start accept_client factory_failed client_input client_error irc_connected irc_socketerr irc_001 )] ] ); $poe_kernel->run(); sub _start { my ($heap) = $_[HEAP]; $heap->{sockfactory} = POE::Wheel::SocketFactory->new( SocketDomain => AF_INET6, BindAddress => '::1', BindPort => 0, SuccessEvent => 'accept_client', FailureEvent => 'factory_failed', ); my $packed_socket = $heap->{sockfactory}->getsockname; if (!$packed_socket) { diag("ERROR: Couldn't get the packed socket"); return; } eval { ($heap->{bindport}) = unpack_sockaddr_in6($packed_socket) }; if ($@) { diag("ERROR: $@"); return; } if ($heap->{bindport} == 0) { delete $heap->{sockfactory}; _skip_rest('$heap->{bindport} == 0'); return; } $bot->yield(register => 'all'); $bot->yield(connect => { Nick => 'testbot', Server => '::1', useipv6 => 1, Port => $heap->{bindport}, Username => 'testbot', Ircname => 'testbot 1.1', }); } sub accept_client { my ($heap, $socket) = @_[HEAP, ARG0]; my $wheel = POE::Wheel::ReadWrite->new( Handle => $socket, InputEvent => 'client_input', ErrorEvent => 'client_error', Filter => POE::Filter::Line->new( Literal => "\x0D\x0A" ), ); $heap->{client} = $wheel; } sub factory_failed { my ($heap, $syscall, $errno, $error) = @_[HEAP, ARG0..ARG2]; delete $_[HEAP]->{sockfactory}; _skip_rest("syscall error $errno: $error") if $tests; } sub client_input { my ($heap, $input) = @_[HEAP, ARG0]; SWITCH: { if ($input =~ /^NICK /) { pass('Server got NICK'); $tests--; $heap->{got_nick} = 1; last SWITCH; } if ($input =~ /^USER /) { pass('Server got USER'); $tests--; $heap->{got_user} = 1; last SWITCH; } if ($input =~ /^QUIT/ ) { delete $heap->{client}; delete $heap->{sockfactory}; return; } } if ($heap->{got_nick} && $heap->{got_user}) { # Send back irc_001 $heap->{client}->put(':test.script 001 testbot :Welcome to poconet Internet Relay Chat Network testbot!testbot@127.0.0.1'); } } sub client_error { my ($heap) = $_[HEAP]; delete $heap->{client}; delete $heap->{sockfactory}; } sub irc_connected { pass('Connected'); $tests--; } sub irc_socketerr { _skip_rest($_[ARG0]) if $tests; } sub irc_001 { pass('Logged in'); $bot->yield('shutdown'); } sub _skip_rest { my ($error) = @_; SKIP: { skip "AF_INET6 probably not supported ($error)", $tests; } $tests = 0; $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/02_behavior/13_activity.t0000644000175000017500000001116413153565114020670 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE::Component::IRC; use POE::Component::Server::IRC; use POE; use Test::More tests => 16; my $bot1 = POE::Component::IRC->spawn(Flood => 1); my $bot2 = POE::Component::IRC->spawn(Flood => 1); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start _shutdown ircd_listener_add ircd_listener_failure irc_001 irc_join irc_invite irc_mode irc_public irc_notice irc_ctcp_action irc_nick irc_topic irc_kick irc_msg irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $_[HEAP]->{logged_in}++; if ($_[HEAP]->{logged_in} == 2) { $bot1->yield(join => '#testchannel'); } } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); if ($nick eq $irc->nick_name()) { is($where, '#testchannel', 'Joined Channel Test'); if ($irc == $bot1) { $bot1->yield(invite => $bot2->nick_name(), $where); } else { $bot1->yield(mode => $where, '+m'); } } } sub irc_invite { pass('irc_invite'); $_[SENDER]->get_heap()->yield(join => $_[ARG1]); } sub irc_mode { my ($sender, $where, $mode) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); my $chantypes = join('', @{ $irc->isupport('CHANTYPES') || ['#', '&']}); return if $where !~ /^[$chantypes]/; return if $irc != $bot1; if ($mode =~ /\+[nt]/) { pass('Got initial channel modes'); } else { is($mode, '+m', 'irc_mode'); $bot1->yield(privmsg => $where, 'Test message 1'); } } sub irc_public { my ($sender, $where, $msg) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($msg, 'Test message 1', 'irc_public'); $bot1->yield(notice => $where->[0], 'Test message 2'); } sub irc_notice { my ($sender, $where, $msg) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($msg, 'Test message 2', 'irc_notice'); $bot1->yield(ctcp => $where->[0], 'ACTION Test message 3'); } sub irc_ctcp_action { my ($sender, $where, $msg) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($msg, 'Test message 3', 'irc_ctcp_action'); $bot1->yield(topic => $where->[0], 'Test topic'); } sub irc_topic { my ($sender, $chan, $msg) = @_[SENDER, ARG1, ARG2]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($msg, 'Test topic', 'irc_topic'); $bot1->yield(nick => 'NewNick'); } sub irc_nick { my $irc = $_[SENDER]->get_heap(); return if $irc != $bot2; pass('irc_nick'); $bot1->yield(kick => '#testchannel', $bot2->nick_name(), 'Good bye'); } sub irc_kick { my ($sender, $error) = @_[SENDER, ARG3]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($error, 'Good bye', 'irc_kick'); $bot1->yield(privmsg => $bot2->nick_name(), 'Test message 4'); } sub irc_msg { my ($sender, $msg) = @_[SENDER, ARG2]; my $irc = $sender->get_heap(); return if $irc != $bot2; is($msg, 'Test message 4', 'irc_msg'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/02_behavior/09_multiple.t0000644000175000017500000000561313153565114020676 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 20; my $bot1 = POE::Component::IRC->spawn(Flood => 1); my $bot2 = POE::Component::IRC->spawn(Flood => 1); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_registered irc_connected irc_001 irc_join irc_mode irc_public irc_error irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_registered { my ($irc) = $_[ARG0]; isa_ok($irc, 'POE::Component::IRC'); } sub irc_connected { pass('Connected'); } sub irc_001 { my ($kernel, $sender, $text) = @_[KERNEL, SENDER, ARG1]; my $irc = $sender->get_heap(); pass('Logged in'); is($irc->server_name(), 'poco.server.irc', 'Server Name Test'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); if ($nick eq $irc->nick_name()) { is($where, '#testchannel', 'Joined Channel Test'); } else { $irc->yield(mode => $where => '+o' => $nick); $irc->yield(privmsg => $where => 'HELLO'); $irc->yield('quit'); } } sub irc_mode { pass('Mode Test'); } sub irc_public { my ($sender, $who, $where, $what) = @_[SENDER, ARG0..ARG2]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); is($what, 'HELLO', 'irc_public test'); $irc->yield('quit'); } sub irc_error { pass('irc_error'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $bot1->yield('shutdown'); $bot2->yield('shutdown'); $ircd->yield('shutdown'); } POE-Component-IRC-6.90/t/02_behavior/01_public_methods.t0000644000175000017500000000071013153565114022025 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use POE::Component::IRC; use Test::More tests => 1; my @methods = qw( spawn new nick_name localaddr server port server_name session_id session_alias send_queue connected disconnect logged_in raw_events isupport isupport_dump_keys yield call delay delay_remove resolver send_event ); can_ok('POE::Component::IRC', @methods); POE-Component-IRC-6.90/t/02_behavior/16_nonclosing_ctcp.t0000644000175000017500000000462213153565114022222 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 5; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_ctcp_version irc_msg irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $heap = $_[HEAP]; my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $heap->{connected}++; return if $heap->{connected} != 2; $bot1->yield(privmsg => $bot2->nick_name(), "\001VERSION"); $bot1->yield(privmsg => $bot2->nick_name(), "goodbye"); $irc->yield(join => '#testchannel'); } sub irc_ctcp_version { fail('Got mangled CTCP VERSION'); } sub irc_msg { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; my $irc = $sender->get_heap(); is($msg, 'goodbye', 'Got private message'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/02_behavior/17_raw.t0000644000175000017500000000347613153565114017640 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 6; my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); my $bot = POE::Component::IRC->spawn( Flood => 1, Raw => 1, ); isa_ok($ircd, 'POE::Component::Server::IRC'); isa_ok($bot, 'POE::Component::IRC'); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_connected irc_raw_out irc_001 irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $bot->yield(register => 'all'); $bot->yield( connect => { nick => 'TestBot', server => '127.0.0.1', port => $port, }); } sub irc_connected { pass('Connected'); } sub irc_raw_out { my ($raw) = $_[ARG0]; pass('Got raw nick string') if $raw =~ /^NICK /; } sub irc_001 { my ($sender) = $_[SENDER]; my $irc = $sender->get_heap(); ok($irc->logged_in(), 'Logged in'); $irc->yield('quit'); } sub irc_disconnected { pass('Got irc_disconnected'); $poe_kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/02_behavior/05_resolver.t0000644000175000017500000000150513153565114020674 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use POE; use POE::Component::IRC; use Test::More; BEGIN { my $GOT_DNS; eval { require POE::Component::Client::DNS; $GOT_DNS = 1 if $POE::Component::Client::DNS::VERSION >= 0.99; }; if (!$GOT_DNS) { plan skip_all => 'POE::Component::Client::DNS 0.99 not installed'; } } plan tests => 4; my $dns = POE::Component::Client::DNS->spawn(); my $bot = POE::Component::IRC->spawn( Resolver => $dns ); isa_ok($bot, 'POE::Component::IRC'); isa_ok($dns, 'POE::Component::Client::DNS'); POE::Session->create( package_states => [ main => ['_start'] ], ); $poe_kernel->run(); sub _start { isa_ok($bot->resolver(), 'POE::Component::Client::DNS'); is($bot->resolver(), $dns, 'DNS objects match'); $bot->yield('shutdown'); $dns->shutdown(); } POE-Component-IRC-6.90/t/02_behavior/11_multi_signal.t0000644000175000017500000000431513153565114021521 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 14; my $bot1 = POE::Component::IRC->spawn(Flood => 1); my $bot2 = POE::Component::IRC->spawn(Flood => 1); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_registered irc_connected irc_001 irc_error irc_disconnected irc_shutdown )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $session, $port) = @_[KERNEL, HEAP, SESSION, ARG0]; $kernel->signal($kernel, 'POCOIRC_REGISTER', $session, 'all'); $heap->{nickcounter} = 0; $heap->{port} = $port; } sub irc_registered { my ($heap, $irc) = @_[HEAP, ARG0]; $heap->{nickcounter}++; pass('Registered ' . $heap->{nickcounter}); isa_ok($irc, 'POE::Component::IRC'); $irc->yield(connect => { nick => 'TestBot' . $heap->{nickcounter}, server => '127.0.0.1', port => $heap->{port}, }); } sub irc_connected { pass('Connected'); } sub irc_001 { my ($sender,$text) = @_[SENDER, ARG1]; my $irc = $sender->get_heap(); pass('Logged in'); $irc->yield('quit'); } sub irc_error { pass('irc_error'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $kernel->signal($kernel, 'POCOIRC_SHUTDOWN'); $ircd->yield('shutdown'); } sub irc_shutdown { pass('irc_shutdown'); } POE-Component-IRC-6.90/t/02_behavior/14_newline.t0000644000175000017500000000556513153565114020506 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 9; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_join irc_public irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $irc->yield(join => '#testchannel'); } sub irc_join { my ($sender, $heap, $who, $where) = @_[SENDER, HEAP, ARG0, ARG1]; my $nick = ( split /!/, $who )[0]; my $irc = $sender->get_heap(); return if $nick ne $irc->nick_name(); is($where, '#testchannel', 'Joined Channel Test'); $heap->{joined}++; return if $heap->{joined} != 2; $irc->yield(quote => "PRIVMSG $where :one\nPRIVMSG $where :two"); $irc->yield(privmsg => $where, "foo\nbar"); $irc->yield(privmsg => $where, "baz\rquux"); } sub irc_public { my ($sender, $heap, $where, $msg) = @_[SENDER, HEAP, ARG1, ARG2]; my $irc = $sender->get_heap(); my $chan = $where->[0]; $heap->{got_msg}++; if ($heap->{got_msg} == 1) { is($msg, 'one', 'First message'); } elsif ($heap->{got_msg} == 2) { is($msg, 'foo', 'Second message'); } elsif ($heap->{got_msg} == 3) { is($msg, 'baz', 'Third message'); $bot1->yield('quit'); $bot2->yield('quit'); } } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/02_behavior/02_connect.t0000644000175000017500000000640413153565114020464 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 38; my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); my $bot = POE::Component::IRC->spawn(Flood => 1); isa_ok($ircd, 'POE::Component::Server::IRC'); isa_ok($bot, 'POE::Component::IRC'); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown _default irc_connected irc_001 irc_391 irc_whois irc_join irc_isupport irc_error irc_disconnected irc_shutdown )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $port) = @_[KERNEL, HEAP, ARG0]; $bot->yield(register => 'all'); $bot->yield( connect => { nick => 'TestBot', server => '127.0.0.1', port => $port, }); } sub irc_connected { pass('Connected'); } sub irc_001 { my ($sender) = $_[SENDER]; my $irc = $sender->get_heap(); ok($irc->logged_in(), 'Logged in'); is($irc->server_name(), 'poco.server.irc', 'Server Name Test'); is($irc->nick_name(), 'TestBot', 'Nick Name Test'); is($irc->session_alias(), $irc, 'Alias Test'); $irc->yield('time'); $irc->yield(whois => 'TestBot'); } sub irc_isupport { my $isupport = $_[ARG0]; isa_ok($isupport, 'POE::Component::IRC::Plugin::ISupport'); is($isupport->isupport('NETWORK'), 'poconet', 'ISupport Network'); is($isupport->isupport('CASEMAPPING'), 'rfc1459', 'ISupport Casemapping'); for my $isupp ( qw(MAXCHANNELS MAXBANS MAXTARGETS NICKLEN TOPICLEN KICKLEN CHANTYPES PREFIX CHANMODES) ) { ok($isupport->isupport($isupp), "Testing $isupp"); } } # RPL_TIME sub irc_391 { my ($time) = $_[ARG1]; pass('Got the time, baby'); } sub irc_whois { my ($sender, $whois) = @_[SENDER, ARG0]; is($whois->{nick}, 'TestBot', 'Whois hash test'); $sender->get_heap()->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); is($nick, $irc->nick_name(), 'JOINER Test'); is($where, '#testchannel', 'Joined Channel Test'); $irc->yield('quit'); } sub irc_error { pass('Got irc_error'); } sub irc_shutdown { pass('Got irc_shutdown'); } sub irc_disconnected { pass('Got irc_disconnected'); $poe_kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot->yield('shutdown'); } sub _default { my ($event) = $_[ARG0]; return 0 if $event !~ /^irc_(002|003|004|422|251|255|311|312|317|318|353|366)$/; pass("Got $event"); return 0; } POE-Component-IRC-6.90/t/02_behavior/15_no_stacked_ctcp.t0000644000175000017500000000521413153565114022160 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 6; my $bot1 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $bot2 = POE::Component::IRC->spawn( Flood => 1, plugin_debug => 1, ); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_001 irc_ctcp_version irc_msg irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot1->yield(register => 'all'); $bot1->yield(connect => { nick => 'TestBot1', server => '127.0.0.1', port => $port, }); $bot2->yield(register => 'all'); $bot2->yield(connect => { nick => 'TestBot2', server => '127.0.0.1', port => $port, }); } sub irc_001 { my $heap = $_[HEAP]; my $irc = $_[SENDER]->get_heap(); pass('Logged in'); $heap->{connected}++; return if $heap->{connected} != 2; $bot1->yield(privmsg => $bot2->nick_name(), "\001VERSION\001\001VERSION\001"); $bot1->yield(privmsg => $bot2->nick_name(), "goodbye"); $irc->yield(join => '#testchannel'); } sub irc_ctcp_version { my ($sender, $heap) = @_[SENDER, HEAP]; my $irc = $sender->get_heap(); $heap->{got_ctcp}++; if ($heap->{got_ctcp} == 1) { pass('Got first CTCP VERSION'); } elsif ($heap->{got_ctcp} == 2) { fail('Got second CTCP VERSION'); } } sub irc_msg { my ($sender, $heap, $msg) = @_[SENDER, HEAP, ARG2]; my $irc = $sender->get_heap(); is($msg, 'goodbye', 'Got private message'); $bot1->yield('quit'); $bot2->yield('quit'); } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; pass('irc_disconnected'); $heap->{count}++; $kernel->yield('_shutdown') if $heap->{count} == 2; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $bot1->yield('shutdown'); $bot2->yield('shutdown'); } POE-Component-IRC-6.90/t/02_behavior/06_online.t0000644000175000017500000000725113153565114020324 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use POE qw(Wheel::SocketFactory); use POE::Component::IRC; use Socket qw(AF_INET inet_ntoa SOCK_STREAM unpack_sockaddr_in); use Test::More tests => 5; my $bot = POE::Component::IRC->spawn(); my $server = 'irc.freenode.net'; my $nick = "PoCoIRC" . $$; POE::Session->create( package_states => [ main => [qw( _start _shutdown _success _failure _irc_connect _time_out _default irc_registered irc_connected irc_001 irc_465 irc_error irc_socketerr irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; # Connect manually first to see if our internets are working. # If not, we can pass the error info to Test::More's skip() $heap->{sockfactory} = POE::Wheel::SocketFactory->new( SocketDomain => AF_INET, SocketType => SOCK_STREAM, SocketProtocol => 'tcp', RemoteAddress => $server, RemotePort => 6667, SuccessEvent => '_success', FailureEvent => '_failure', ); $kernel->delay(_time_out => 40); $heap->{numeric} = 0; $heap->{tests} = 5; } sub _success { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{address} = inet_ntoa($_[ARG1]); $kernel->delay('_time_out'); delete $heap->{sockfactory}; $kernel->yield('_irc_connect'); } sub _failure { my ($kernel, $heap, $operation, $errnum, $errstr) = @_[KERNEL, HEAP, ARG0..ARG2]; delete $heap->{sockfactory}; $kernel->yield(_shutdown => "$operation $errnum $errstr"); } sub _time_out { delete $_[HEAP]->{sockfactory}; $poe_kernel->yield(_shutdown => 'Connection timed out'); } sub _shutdown { my ($heap, $skip) = @_[HEAP, ARG0]; if ( !$skip && !$heap->{numeric} ) { $skip = 'Never received a numeric IRC event'; } SKIP: { skip $skip, $heap->{tests} if $skip; } $poe_kernel->alarm_remove_all(); $bot->yield('shutdown'); } sub _irc_connect { my ($heap) = $_[HEAP]; $bot->yield(register => 'all'); $bot->yield(connect => { server => $heap->{address}, nick => $nick, }); } sub irc_registered { my ($heap, $irc) = @_[HEAP, ARG0]; isa_ok($irc, 'POE::Component::IRC'); $heap->{tests}--; } sub irc_connected { TODO: { local $TODO = "K-lines or other unforeseen issues could derail this test"; pass('Connected'); }; $_[HEAP]->{tests}--; } sub irc_socketerr { my ($kernel) = $_[KERNEL]; $kernel->yield(_shutdown => $_[ARG0] ); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); TODO: { local $TODO = "K-lines or other unforeseen issues could derail this test"; pass('Logged in'); }; $_[HEAP]->{numeric}++; $_[HEAP]->{tests}--; $irc->yield('quit'); } sub irc_465 { my $irc = $_[SENDER]->get_heap(); TODO: { local $TODO = "Hey we is K-lined"; pass('ERR_YOUREBANNEDCREEP'); }; $_[HEAP]->{numeric}++; $_[HEAP]->{tests}--; } sub irc_error { TODO: { local $TODO = "K-lines or other unforeseen issues could derail this test"; pass('irc_error'); }; $_[HEAP]->{tests}--; } sub irc_disconnected { my ($kernel, $heap) = @_[KERNEL, HEAP]; TODO: { local $TODO = "K-lines or other unforeseen issues could derail this test"; pass('Disconnected'); }; $heap->{tests}--; $kernel->yield('_shutdown'); } sub _default { my ($event, $args) = @_[ARG0 .. $#_]; return unless $event =~ m!^irc_\d+!; $_[HEAP]->{numeric}++; return; } POE-Component-IRC-6.90/t/02_behavior/03_socketerr.t0000644000175000017500000000275713153565114021044 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use POE qw(Wheel::SocketFactory); use POE::Component::IRC; use Socket qw(unpack_sockaddr_in); use Test::More tests => 1; my $bot = POE::Component::IRC->spawn(); POE::Session->create( package_states => [ main => [qw( _start _try_connect _shutdown irc_socketerr )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; my $port = get_port() or $kernel->yield(_shutdown => 'No free port'); $kernel->yield(_try_connect => $port); $kernel->delay(_shutdown => 60, 'Timed out'); } sub get_port { my $wheel = POE::Wheel::SocketFactory->new( BindAddress => '127.0.0.1', BindPort => 0, SuccessEvent => '_fake_success', FailureEvent => '_fake_failure', ); return if !$wheel; return unpack_sockaddr_in($wheel->getsockname()) if wantarray; return (unpack_sockaddr_in($wheel->getsockname))[0]; } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $bot->yield(unregister => 'socketerr'); $bot->yield('shutdown'); } sub _try_connect { my ($port) = $_[ARG0]; $bot->yield(register => 'socketerr'); $bot->yield( connect => { nick => 'TestBot', server => '127.0.0.1', port => $port, }); } sub irc_socketerr { my ($kernel) = $_[KERNEL]; pass('Socket Error'); $kernel->yield('_shutdown'); } POE-Component-IRC-6.90/t/02_behavior/12_delays.t0000644000175000017500000000205013153565114020306 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use POE; use POE::Component::IRC; use Socket qw(unpack_sockaddr_in); use Test::More tests => 4; my $bot = POE::Component::IRC->spawn(); POE::Session->create( package_states => [ main => [qw( _start irc_registered irc_delay_set irc_delay_removed )], ], ); $poe_kernel->run(); sub _start { $bot->yield(register => 'all'); } sub irc_registered { my ($heap, $irc) = @_[HEAP, ARG0]; $heap->{alarm_id} = $irc->delay( [ connect => { nick => 'TestBot', server => '127.0.0.1', port => 6667, } ], 25 ); ok($heap->{alarm_id}, 'Set alarm'); } sub irc_delay_set { my ($heap, $event, $alarm_id) = @_[HEAP, STATE, ARG0]; is($alarm_id, $heap->{alarm_id}, $_[STATE]); my $opts = $bot->delay_remove($alarm_id); ok($opts, 'Delay Removed'); } sub irc_delay_removed { my ($heap, $alarm_id) = @_[HEAP, ARG0]; is($alarm_id, $heap->{alarm_id}, $_[STATE] ); $bot->yield('shutdown'); } POE-Component-IRC-6.90/t/02_behavior/10_signal.t0000644000175000017500000000375213153565114020312 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 7; my $bot = POE::Component::IRC->spawn(Flood => 1); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_registered irc_connected irc_001 irc_error irc_disconnected irc_shutdown )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $heap, $session, $port) = @_[KERNEL, HEAP, SESSION, ARG0]; $kernel->signal($kernel, 'POCOIRC_REGISTER', $session, 'all'); $heap->{port} = $port; } sub irc_registered { my ($heap, $irc) = @_[HEAP, ARG0]; pass('Registered'); isa_ok($irc, 'POE::Component::IRC'); $irc->yield(connect => { nick => 'TestBot', server => '127.0.0.1', port => $heap->{port}, }); } sub irc_connected { pass('Connected'); } sub irc_001 { my ($kernel, $sender, $text) = @_[KERNEL, SENDER, ARG1]; my $irc = $sender->get_heap(); pass('Logged in'); $irc->yield('quit'); } sub irc_error { pass('irc_error'); } sub irc_disconnected { pass('irc_disconnected'); $poe_kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $ircd->yield('shutdown'); $kernel->signal($kernel, 'POCOIRC_SHUTDOWN'); } sub irc_shutdown { pass('irc_shutdown'); } POE-Component-IRC-6.90/t/02_behavior/07_subclass.t0000644000175000017500000000561113153565114020656 0ustar bingosbingosuse strict; use warnings FATAL => 'all'; use lib 't/inc'; use POE; use POE::Component::IRC; use POE::Component::Server::IRC; use Test::More tests => 17; { package SubclassIRC; use base qw(POE::Component::IRC); use Test::More; my $VERSION = 1; sub S_001 { my $irc1 = shift; $irc1->SUPER::S_001(@_); my $irc2 = shift; pass('PoCo-IRC as subclass'); isa_ok($irc1, 'POE::Component::IRC'); isa_ok($irc2, 'POE::Component::IRC'); is($irc1->server_name(), 'poco.server.irc', 'Server Name Test'); is($irc2->nick_name(), 'TestBot', 'Nick Name Test'); } } my $bot = SubclassIRC->spawn(Flood => 1); my $ircd = POE::Component::Server::IRC->spawn( Auth => 0, AntiFlood => 0, ); isa_ok($bot, 'POE::Component::IRC'); isa_ok($ircd, 'POE::Component::Server::IRC'); POE::Session->create( package_states => [ main => [qw( _start ircd_listener_add ircd_listener_failure _shutdown irc_registered irc_connected irc_001 irc_whois irc_join irc_error irc_disconnected )], ], ); $poe_kernel->run(); sub _start { my ($kernel) = $_[KERNEL]; $ircd->yield('register', 'all'); $ircd->yield('add_listener'); $kernel->delay(_shutdown => 60, 'Timed out'); } sub ircd_listener_failure { my ($kernel, $op, $reason) = @_[KERNEL, ARG1, ARG3]; $kernel->yield('_shutdown', "$op: $reason"); } sub ircd_listener_add { my ($kernel, $port) = @_[KERNEL, ARG0]; $bot->yield(register => 'all'); $bot->yield( connect => { nick => 'TestBot', server => '127.0.0.1', port => $port, }); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $bot->yield('shutdown'); $ircd->yield('shutdown'); } sub irc_registered { my ($irc) = $_[ARG0]; isa_ok($irc, 'POE::Component::IRC'); } sub irc_connected { pass('Connected'); } sub irc_001 { my $irc = $_[SENDER]->get_heap(); pass('connect'); is($irc->server_name(), 'poco.server.irc', 'Server Name Test'); is($irc->nick_name(), 'TestBot', 'Nick Name Test'); $irc->yield(whois => 'TestBot'); } sub irc_whois { my ($sender, $whois) = @_[SENDER, ARG0]; is($whois->{nick}, 'TestBot', 'Whois hash test'); $sender->get_heap()->yield(join => '#testchannel'); } sub irc_join { my ($sender, $who, $where) = @_[SENDER, ARG0, ARG1]; my $nick = (split /!/, $who)[0]; my $irc = $sender->get_heap(); is($nick, $irc->nick_name(), 'JOINER Test'); is($where, '#testchannel', 'Joined Channel Test'); $irc->yield('quit'); } sub irc_error { pass('irc_error'); } sub irc_disconnected { my ($kernel) = $_[KERNEL]; pass('irc_disconnected'); $kernel->yield('_shutdown'); } POE-Component-IRC-6.90/t/02_behavior/18_shutdown.t0000644000175000017500000000253413153565114020715 0ustar bingosbingos#!/usr/bin/env perl use strict; use warnings FATAL => 'all'; use POE; use POE::Component::IRC; use Socket qw(unpack_sockaddr_in); use Test::More tests => 4; my $bot = POE::Component::IRC->spawn(Flood => 1); POE::Session->create( package_states => [ main => [qw( _start _shutdown irc_shutdown )], ], ); $poe_kernel->run(); sub _start { my ($kernel, $parent_heap) = @_[KERNEL, HEAP]; $bot->yield(register => 'all'); # we're testing if pocoirc correctly copes with a session immediately # dying after sending a 'shutdown' event POE::Session->create( inline_states => { _start => sub { $parent_heap->{sub_id} = $_[SESSION]->ID(); pass('Subsession started'); $bot->yield('shutdown'); }, _stop => sub { pass('Subsession stopped'); } }, ); $kernel->delay(_shutdown => 60, 'Timed out'); } sub irc_shutdown { my ($heap, $killer_id) = @_[HEAP, ARG0]; pass('IRC component shut down'); is($killer_id, $heap->{sub_id}, 'Killer session id matches'); $poe_kernel->yield('_shutdown'); } sub _shutdown { my ($kernel, $error) = @_[KERNEL, ARG0]; fail($error) if defined $error; $kernel->alarm_remove_all(); $bot->yield('shutdown'); } POE-Component-IRC-6.90/LICENSE0000644000175000017500000004406713153565114015016 0ustar bingosbingosThis software is copyright (c) 2017 by Dennis Taylor, Chris Williams, and Hinrik Örn Sigurðsson. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2017 by Dennis Taylor, Chris Williams, and Hinrik Örn Sigurðsson. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2017 by Dennis Taylor, Chris Williams, and Hinrik Örn Sigurðsson. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End POE-Component-IRC-6.90/Changes0000644000175000017500000021342213153565114015275 0ustar bingosbingosRevision history for Perl extension POE::Component::IRC. 6.90 Tue Sep 5 19:17:35 BST 2017 - Update simpleclient with IPv6 option - Remove requirement on List::MoreUtils - Fix missing code for Ignore_unauthorized - Add support for WEBIRC 6.89 Tue Sep 5 19:13:09 BST 2017 6.88 Sat Jun 28 13:14:00 BST 2014 - BotAddressed: Handle being addressed with a prefixed @ or % 6.87 Sat Jun 21 15:08:32 BST 2014 - Believe have resolved issues with online test 6.86 Fri Jun 20 11:12:06 BST 2014 - Added more diagnostics to the online test 6.85 Thu Jun 19 10:19:07 BST 2014 - Added some diagnostics output to the online test 6.84 Tue Jun 17 10:45:38 BST 2014 - Plugman: store @$ or else it gets overwritten - Commit: 65ba2a4f3 6.83 Mon May 27 10:40:09 BST 2013 - NickServID: React on IRC Message 433 - Commit: ec7cd33736 - BotCommand: Support for overriding the Command Handler - BotCommand: Added Support for a Help Modification Callback - BotCommand: Adapted the Help Callback Options so it gets the Command and Arguments - BotCommand: Added Support for Command Aliases - BotCommand: Allowed No Arguments/Only Variable Arguments - Implemented SSL Client Cert Support 6.82 Sat Mar 9 22:15:02 GMT 2013 - Add the Prefix to the "Syntax:" line of the command help 6.81 Fri Nov 23 15:53:11 GMT 2012 - Resolve hash randomisation issues with v5.17.6 6.80 Thu Sep 20 09:52:59 BST 2012 - Add missing prereq 6.79 Wed Sep 19 14:24:03 BST 2012 - Argument naming and argument count validation in Plugin::BotCommand - [rt.cpan.org #79745] nick_long_form dies due to a race condition 6.78 Wed Dec 7 20:29:45 GMT 2011 - Prevent an IPv6 test failure 6.77 Fri Dec 2 03:55:14 GMT 2011 - Prevent a test failure in 06_online.t if the host is K-lined 6.76 Tue Nov 29 03:24:55 GMT 2011 - DCC.pm: Fix DCC RESUME, it was broken - NickReclaim.pm: Make it more robust and prevent an error from being raised when we quit from IRC. 6.75 Sun Nov 13 14:24:50 UTC 2011 - Win32 fixes to the DCC plugin and netsplit test - You couldn't specify a localaddr without a localport. Fixed. 6.74 Sun Oct 9 20:16:13 GMT 2011 - Disable authentication in t/01_base/04_pocosi.t. Fixes test failure. 6.73 Sat Oct 8 04:40:18 GMT 2011 - Add missing dependencies to t/inc needed by poco-server-irc 6.72 Fri Oct 7 15:41:53 UTC 2011 - Skip IPv6 tests on systems which don't have inet_pton() - Fix regression in t/03_subclasses/01_state.t - Update the poco-server-irc in t/inc to version 1.53 6.71 Sun Sep 18 16:07:33 GMT 2011 - Make the component easier to use with dynamic IP interfaces - Fix race condition in 06_state_nick_sync.t - Silence warning due to incorrect use of length() instead of defined() - State.pm: Add a parameter to irc_topic containing the old topic 6.70 Tue Aug 2 03:38:52 GMT 2011 - State.pm: Support multiple modes in NAMES replies (NAMESX, multi-prefix) - State.pm: Support nick!user@host in NAMES replies (UHNAMES) - State.pm: Added channel_url() - Fixed a race condition in 06_state_nick_sync.t 6.69 Fri Jul 29 01:52:38 GMT 2011 - Whois.pm: Collect info from numerics 307 and 310 - Whois.pm: Removed the 'account' key and have the 'identified' key do its thing instead, so that there is one generic way to check if a user is identified, regardless of the network. 6.68 Sun May 22 17:01:21 GMT 2011 - REALLY fix it to work with the latest IRC::Utils 6.67 Sun May 22 16:43:27 GMT 2011 - Add missing documentation for irc_plugin_(add|del|error) events - IRC.pm: Improved the layout of the documentation - Common.pm: Fix to work with latest IRC::Utils 6.66 Thu May 19 22:32:07 GMT 2011 - BotCommand.pm: Allow commands to be \S+, not just \w+ 6.65 Thu May 19 01:54:21 GMT 2011 - BotCommand.pm: Quote the 'Prefix' before using it in a regex, and add 'Bare_private' to allow commands in private without a prefix 6.64 Sun May 15 09:59:12 GMT 2011 - Fix incorrect amount of tests skipped in 04_ipv6.t when IPv6 is not supported 6.63 Sun May 15 05:06:57 GMT 2011 - Remove vestigial 'unregister' event handler, poco-syndicator handles that now. The latest poco-syndicator release croaks if we try to override its handler, so this was causing failures. 6.62 Tue May 3 10:58:45 GMT 2011 - Make use of IPv6 functions from Socket (instead of Socket6) if they are available, and skip the IPv6 test if we don't have an implementation of getaddrinfo(). Thanks to Apocalypse for this. - Add a parameter to irc_snotice which contains the target of the message (usually '*' or 'AUTH' or something). - Qnet/State.pm: Forgot to import parse_user() from IRC::Utils. - IRC.pm: Document the Bitmode parameter and make it 8 (+i) by default. - IRC.pm: Remove a sizable chunk of the code and inherit from POE::Component::Syndicator instead. Got rid of an old backwards compatability workaround in the process: sessions will no longer receive irc_connected/irc_disconnected/irc_shutdown events if they didn't register for them. - Console.pm: Avoid custom stringifications when dumping objects - State.pm: nick_info() was failing when a nick was known but unsynced - Console.pm: Decode all arguments before printing them 6.61 Tue Apr 19 17:02:54 GMT 2011 - The changes to the filter test were causing failures on <5.12 due to C. Fixed it. - Make it so that irc_shutdown is always the last event to be sent - Depend on POE 1.310 to fix failing socket error test on Windows - Improve event queue ordering to make it more predictable. Add new methods, send_event_next() and send_event_now(), to bypass the event queue in different ways. - Replace the functions in Common.pm with wrappers around equivalents from IRC::Utils. - IRC.pm: Add server() and port() accessors. 6.60 Fri Apr 15 06:12:28 GMT 2011 - Fix failure (RT #67465) related to the recent irc_snotice change. Added a test for it as well. 6.59 Mon Apr 4 20:22:38 GMT 2011 - FollowTail, Logger & DCC: Use rel2abs instead of abs_path to preserve symlinks while still being unaffected by chdir() 6.58 Mon Apr 4 17:48:59 GMT 2011 - Fix FollowTail test to work in case /tmp is a symlink 6.57 Sat Apr 2 03:34:04 GMT 2011 - FollowTail, Logger & DCC plugins: Expand '~' in filename arguments, and resolve them to absolute paths, in case the process will chdir(). 6.56 Fri Apr 1 20:05:14 GMT 2011 - irc_snotice has been used for server NOTICEs which do not have a sender prefix. NOTICEs which have a server name as the sender prefix are now irc_snotice too, leaving irc_notice only for notices with a proper nick!user@host sender. 6.55 Fri Apr 1 18:37:49 GMT 2011 - State.pm: Store the real nicks of channel members after receiving a NAMES reply. Fixes the issue of undefined nicks being returned by channel_list() before the channel has been synced. - State.pm: Check all arguments for definedness in public methods for easier debugging 6.54 Thu Mar 10 18:20:47 GMT 2011 - Fixed all the trailing space 'errors' - Resolve an issue with irc_nick_sync in poco-irc-state, added test 6.52 Fri Nov 5 18:27:16 CET 2010 - Fixed typo in shutdown code and added a test to confirm 6.51 Fri Nov 5 12:28:14 CET 2010 - Make the t/02_behavior/06_online.t test a TODO, since we can't work around problems such as the user being K-lined from FreeNode - Save the sender id on shutdown, not the sender's reference, avoids a crash when a sender disappears before we complete the shutdown 6.50 Wed Nov 3 02:05:56 GMT 2010 - Fix race condition causing a duplicated test in t/04_plugins/12_autojoin/03_banned.t - Console.pm: Dump hashes and arrays recursively - Enable all debugging messages if $ENV{POCOIRC_DEBUG} is true - Make the 'shutdown' event do more work for us, such as forcibly disconnecting after a timeout if the server doesn't disconnect us following a QUIT command - Add an irc_raw_out event, corollary to irc_raw - AutoJoin.pm: Don't require the component to be ::State 6.49 Sat Oct 16 19:05:25 GMT 2010 - Add draft-mitchell-irc-capabilities-02.html to docs/ - Fix incorrect number of skipped tests in 06_online.t in some cases - Allow IRC server passwords which evaluate to false (e.g. '0') - Prevent possible race conditions in a few tests 6.48 Sun Oct 3 19:49:20 GMT 2010 - State.pm: Don't send an undefined value with irc_chan_mode when the mode has no argument - Console.pm: Improve the readability of the output, and show undef - Deliver irc_plugin_error immediately, bypassing the event queue 6.47 Sun Oct 3 15:28:50 GMT 2010 - Join arguments to the 'quote' command with spaces. This allows us to send commands with multiple arguments through the Console plugin. - Add support for CAP command/replies. We use it to enable the server's identify-msg feature when we connect. - State.pm: In disconnected/error/socketerr events when no info is available, make ARG1 an empty hash reference instead of undef. - Console.pm: Don't send events to client before they're authed - Console.pm: Pretty-print hash references 6.46 Wed Sep 29 04:57:42 UTC 2010 - Document the 'debug' parameter. - Use Object::Pluggable instead of POE::Component::Pluggable. This smooths out an inconsistency between plugins and normal sessions with regard to events where extra arguments have been added. 6.45 Sun Sep 26 03:41:48 GMT 2010 - Don't create a POE::Component::Client::DNS object if the user has supplied one. This fixes a regression introduced by yours truly a couple of years ago. 6.44 Sat Sep 25 23:34:11 GMT 2010 - Don't fail on IRC servers where a whole class of channel modes is unsupported (e.g. Bitlbee). 6.43 Sat Sep 25 21:30:36 GMT 2010 - State.pm: Don't forget to call IRC.pm's implementation of S_disconnected before our own. Due to this, the logged_in() method was reporting incorrect information after disconnecting. 6.42 Sat Sep 25 09:40:21 UTC 2010 - ISupport.pm: Don't send a premature irc_isupport event on networks which send us numerics higher than 005 before the actual 005 (e.g Rizon) - NickServID.pm: Send an 'irc_identified' event when we've identified with NickServ. In addition, be a little more permissive when determining if we have identified. Works with Rizon now. 6.41 Thu Sep 23 21:33:17 UTC 2010 - Don't use qw() as parentheses, it's deprecated in 5.13.4 - Drop CTCPs which don't have a closing delimiter 6.40 Thu Sep 9 06:55:27 UTC 2010 - AutoJoin.pm: Wait for a reply from NickServ before joining channels on connect 6.39 Sat Sep 4 02:16:28 UTC 2010 - AutoJoin.pm: Allow channel keys to be undefined - Make the 'nickserv' command do the right thing on ratbox ircds - Add a server_version() method 6.38 Fri Sep 3 18:33:50 UTC 2010 - Only process the first CTCP chunk we find in a message. This prevents someone from flooding our outgoing queue by having us e.g. reply to 20 VERSION requests at a time. - CTCP.pm: Reply to VERSION with "dev-git" when no version is available. 6.37 Tue Aug 17 22:53:22 GMT 2010 - Make all warnings fatal - Use real temp files in tests instead of littering the dist directory 6.36 Mon Jul 26 03:53:50 GMT 2010 - Added a logged_in() method to see if we're logged into IRC 6.35 Sun Jun 27 09:32:22 GMT 2010 - Disconnecting.pod: Mention when it is appropriate to use C<< $irc->yield('shutdown') >>. - Connector.pm: Clear the reconnect timer when the plugin is deleted so that we can actually shut down the IRC component. - Depend on POE::Component::Pluggable 1.26 for irc_plugin_error 6.34 Fri Jun 25 18:16:40 GMT 2010 - CTCP.pm: Do "use POE::Component::IRC;" to avoid weird failures when this plugin is compiled by code which hasn't done the same. 6.33 Mon Jun 21 20:27:42 GMT 2010 - BotCommand.pm: Allow user to choose how help messages are delivered - BotCommand.pm: Require the command prefix in private messages - BotCommand.pm: Make the help messages more context-sensitive - BotCommand.pm: Add support for custom auth checks - BotCommand.pm: If Eat == 1, we eat everything that looks like a command - Cookbook: Add Gtk2 example by Damian Kaczmarek - Logger.pm: Support a hook for custom log storage - IRC.pm: Remove redundant version() method - Convert distribution over to Dist::Zilla 6.32 Tue May 11 13:43:50 GMT 2010 - IRC.pm: Filter out \r in arguments to non-PRIVMSG commands too - IRC.pm: Uppercase REHASH/DIE/RESTART commands before sending them - IRC.pm: Simplify privmsg handler and remove undocumented behavior of concatenating multiple messages. 6.30 Mon May 10 14:34:54 GMT 2010 - Proxy.pm: Fix documentation error ('bindaddr' -> 'bindaddress') - IRC.pm: Split long messages on \r as well as \n. Plugs a security hole. 6.28 Sun Mar 14 10:50:43 GMT 2010 - Use utf8 encoding in all Pod - Cookbook: Replace the MegaHAL recipe with a Hailo one - Stop using Module::Install::AuthorTests since M::I 0.94 handles it automatically for us 6.26 Sun Mar 14 07:32:23 GMT 2010 - Depend on POE 1.287 for FollowTail bugfixes - Updated documentation to mention advice about avoiding the double encoding of non-ASCII channel names - Logger.pm: Avoid double-encoding non-ASCII channel names in logs 6.24 Fri Feb 12 02:45:21 GMT 2010 - NickServID.pm: Identification wasn't working after the change a couple of releases ago. Thanks to John O'Brien in RT #54530. (Hinrik) 6.22 Wed Jan 20 01:50:23 GMT 2010 - Logger.pm: The 'Restricted' switch had the opposite of the documented effect. Fixed that and also changed the default to true, so nobody who used the default will see a change. (Hinrik) 6.20 Fri Jan 15 18:38:44 GMT 2010 - NickServID.pm: Identify correctly when switching nicks on ratbox IRC servers (Hinrik) - Common.pm: Encode::Guess::guess_encoding() doesn't work well with 'UTF-8', revert back to 'utf8'. Added tests for it. (Hinrik) - CTCP.pm: It was sending "ARRAY(0x#######)" in reply to CTCP PING. Fixed it and added test for that and CTCP TIME. (Hinrik). - Depend on POE 1.284 so we won't get FAIL test reports from CPAN testers because of the FollowTail plugin. (Hinrik) 6.18 Fri Dec 11 19:23:24 GMT 2009 - NickReclaim.pm: Reclaim nick immediately when possible (Hinrik) - Depend on POE::Filter::IRCD 2.42. Fixes parsing of 005 numeric replies from some servers (Hinrik) 6.16 Sun Oct 11 08:57:18 GMT 2009 - BotTraffic.pm: Emit 'irc_bot_notice' events for bot notices (Hinrik) - Logger.pm: Log NOTICEs if requested (Hinrik) - Proxy.pm: Fix a regression introduced in 6.05_01. This was causing it to be completely broken. Added a test so it won't happen again unnoticed (Hinrik) 6.14 Thu Sep 24 15:07:05 GMT 2009 - More "return" -> "return PCI_EAT_NONE" fixes. This eliminates some harmless (but annoying) warnings. (Hinrik) - State.pm: Fix AwayPoll, which wasn't working at all. Also added a test for it and made the documentation clearer. Thanks to David E. Wheeler for spotting that one. (Hinrik) - IRC.pm: Document which spawn() options can not be passed to the 'connect' event. (Hinrik) - IRC.pm: Split PRIVMSGs with newlines into multiple messages. For other commands, don't pass user-supplied newlines through to the IRC server as it allows the user to submit raw IRC commands. (Hinrik) 6.12 Thu Sep 10 09:25:02 BST 2009 - Fix localaddr() issue reported in RT #48791 by Michael Andreen - Depend on latest (1.24) POE::Component::Pluggable (Hinrik) - BotCommand.pm: Strip colors/formatting before processing (Hinrik) - Plugin::AutoJoin S_join should return PCI_EAT_NONE if $joiner ne $irc->nick_name() (perigrin) 6.10 Fri Aug 14 21:19:07 BST 2009 - Implemented netsplit detection and handling of state on netjoin (bingos) - Refactored the netsplit code for robustness and sanity (bingos) - Added testcase for netsplit handling (bingos) - AutoJoin.pm: Fixed problem with rejoining password-protected channels that were not passed to the plugin constructor (Hinrik) - Removed extended debug output from some tests, they've been behaving for a while (Hinrik) - State and subclasses will use NAMES replies to synchronise channel state as well now. Should help RT #46825 (bingos). - Refactored the netsplit test slightly to try and eliminate race conditions (bingos) - Added netsplit detection code to Qnet::State subclass. (bingos) - Netsplit restoration now triggers irc_nick_sync event (bingos) - Added some diagnostics to the netsplit test. (bingos) - Markup test in netsplit as todo due to race condition (bingos) - Mark one of the netsplit tests TODO (bingos) - Time for a stable release 6.08 Fri May 29 11:46:45 GMT 2009 - CTCP.pm: Return an RFC822 date in response to CTCP TIME (Hinrik) - BotCommand.pm: Fix RT #46065, help message wasn't being printed (Hinrik) - Connector.pm: Make the traffic-noticing code more accurate (Hinrik) - PlugMan.pm: Allow custom auth checks for the IRC interface (Hinrik) - PlugMan.pm: Silence some warnings (bingos) 6.06 Thu Apr 30 12:05:04 GMT 2009 - NickServID.pm: Update a paragraph in the Pod (Hinrik) - State.pm: Don't delete all state in S_(error|socketerr|disconnected) handlers, removes some warnings (Hinrik) - AutoJoin.pm: Fixed some bugs, added more tests (Hinrik) - PlugMan.pm: Don't rely on State.pm for authentication. Eliminates race condition when receiving channel commands before the channel has been synced (Hinrik) - In jailed environments we can't assume that 127.0.0.1 will be that. reported by Jase Thew (Bazerka). - Logger.pm: Replace slashes with underscores before logging to disk, spotted by Sebastian Mair. 6.05_01 Sat Apr 11 09:18:28 GMT 2009 - Compat.pm: Don't emit an extra event or print a misleading debug message for CTCP ACTIONs on FreeNode (Hinrik) - AutoJoin.pm: Only join channels after we have asked the server if it supports FreeNode's CAPAB IDENTIFY-MSG (Hinrik) - BotCommand.pm: Accept commands in private too (Hinrik) - CTCP.pm: Handle CLIENTINFO as well (Hinrik) - Common.pm: Added irc_to_utf8 to decode IRC messages (Hinrik) - Proxy.pm: General cleanup. Also fix a bug introduced in 5.66 that caused it to keep too many welcome messages (Hinrik) - State.pm: General cleanup. Fixed a bug with the order of irc_nick_sync's arguments being reversed (Hinrik) 6.04 Sat Mar 7 23:31:11 GMT 2009 - Logger.pm: Only use portable strftime parameters. Fixes log timestamps on Solaris and Windows (Hinrik) - CTCP.pm: Use portable strftime parameters when responding to CTCP TIME requests (Hinrik) - State.pm: Document the extra parameters to irc_disconnected, irc_error, and irc_socketerr. (Hinrik) - Fixed race condition in some tests (Hinrik) 6.02 Fri Mar 6 10:54:22 GMT 2009 - Fix RT #43856, variable name typo in PlugMan.pm reported by barnaclebob - Add new test for PlugMan plugin (Hinrik) - Amend a few tests that were failing (Hinrik) - State.pm: Avoid a warning when setting a mode on a channel on which all previous modes have been unset (Hinrik) - Add optional Perl::Critic test for the test scripts (Hinrik) 6.00 Wed Mar 4 23:12:57 GMT 2009 - Logger.pm: Fix bug with logging some CTCP ACTIONs (Hinrik) - Logger.pm: Also log own messages in DCC chats. Add test for it (Hinrik) - Added more tests for general IRC activity, and for State.pm (Hinrik) - Added tests for BotCommand and Logger plugin (Hinrik) - Turned off flood control in all the tests, and removed or adjusted many of the delays used. This shaves about 70% off the time needed for a full test suite run (Hinrik) 5.98 Mon Mar 2 22:51:27 GMT 2009 - Parse some IRC protocol messages more strictly. Always split on ASCII space rather than \s, since tabs are not considered whitespace by the IRC protocol. (Hinrik) - DCC.pm: Most events now tell you what the peer's IP address is (Hinrik) - DCC.pm: Document the timeout parameter to the dcc command, and fixed some errors in the docs. (Hinrik) - Compat.pm/DCC.pm: Actually provide the whole nick!user@host (not just the nick) with every dcc_request, like the synopsis suggests (Hinrik) - DCC.pm: Fix crash when closing a DCC connection with pending outgoing data, reported by meneldor (Hinrik) - Added test case for the above (Hinrik) - DCC.pm: Don't crash if dcc_close is called with an invalid id, also reported by meneldor (Hinrik) - Logger.pm: Add DCC chat logging (Hinrik) - IRC.pm: Document the 'account' key returned by irc_whois (Hinrik) - IRC.pm: Allow plugins to respond to custom commands without them having to be defined explicitly in IRC.pm. This allows the removal of the last piece of DCC-specific code (Hinrik) - AutoJoin.pm: Add an option for retrying joins when banned (Hinrik) - NickServID.pm: Support ratbox-based ircds (Hinrik) - Synchronised all the version numbering (bingos) 5.96 Wed Jan 28 11:29:28 GMT 2009 - Added delays to the two failing tests reported by CPAN Testers, believe we are seeing race conditions. (bingos) 5.94 Tue Jan 27 21:38:51 GMT 2009 - Fixed dependency on Date::Format in inc. poco-server-irc (bingos) 5.92 Tue Jan 27 13:18:12 GMT 2009 - PlugMan.pm: Only require ::State when 'botowner' is set (Hinrik) - ISupport.pm: Fix parsing of MODES and SILENCE parameters (Hinrik) - AutoJoin.pm: Added 'Rejoin_delay' option (Hinrik) - Connector.pm: Allow adjusting the time to wait before reconnecting, to ease testing. (Hinrik) - Compat.pm: Fix parsing of CTCPs when no prefix is present (i.e. client CTCPs) (Hinrik) - Updated included POE::Component::Server::IRC to 1.36 (Hinrik) - Fixed up some tests to work with it (Hinrik) - Removed ziplink test since PoCo-Server-IRC only supports server ziplinks, not client ones (Hinrik) - Added tests for the following plugins: AutoJoin, BotAddressed, CycleEmpty, CTCP, Connector, ISupport, NickReclaim, Whois (Hinrik) 5.90 Thu Jan 22 10:52:53 GMT 2009 - Seen.pod: Recipe for a bot implementing the 'seen' command (Hinrik) - Reload.pod: How to reload your bot with out reconnecting (Hinrik) - Memory leak with stashing $self in $self->{alias}, change to stash a stringified version of $self instead. (bingos) 5.88 Thu Aug 28 15:49:48 BST 2008 - MegaHAL.pod: Bare-bones recipe for a MegaHAL bot (Hinrik) - BotCommand.pm: Send responses back via NOTICE, not PRIVMSG (Hinrik) - Filter/CTCP.pm: Removed, as it is deprecated and unmaintained (Hinrik) - IRC.pm: Really propagate the plugin_debug flag (Hinrik) - Filter/IRC/Compat.pm - change to _get_ctcp() as per RT #38773 5.86 Tue Jul 22 09:53:26 BST 2008 - Proxy.pm: Remove 'options => {trace => 1}' from constructor (Hinrik) - Compat.pm: Don't handle CAPAB IDENTIFY-MSG with non-ACTION CTCPs (Hinrik) 5.84 Thu Jun 26 19:55:41 BST 2008 - BotAddressed.pm: Made it a little smarter (Hinrik) - Common.pm: Make strip_color() strip bg color-only changes (Hinrik) - IRC.pm: Propagate plugin_debug flag to Pluggable (Hinrik) - IRC.pm: Added support for FreeNode's CAPAB IDENTIFY-MSG (Hinrik) - Makefile.PL: Depend on new Pluggable for better debug info (Hinrik) - t/02_behavior/12_delays.t: Shouldn't fail if there's an IRC server running on localhost (Hinrik) 5.82 Sat Jun 14 09:02:11 BST 2008 - Depend on new PoCo-Pluggable to fix a regression (Hinrik) 5.80 Thu Jun 13 15:30:08 GMT 2008 - CycleEmpty.pm: Renamed cycling() to is_cycling() (Hinrik) - IRC.pm: Documented the squit command (Hinrik) - Only test ziplinks given a proper version of *Zlib::Stream (Hinrik) - DCC.pm: Implemented DCC RESUME support (Hinrik) - Cleaned up and reorganized the test suite (Hinrik) - IRC.pm: Added SERVLIST and SQUERY commands. Should include everything from RFC2812 now. (Hinrik) - Fixed a bug in Proxy plugin (bingos) 5.78 Fri May 30 08:03:30 BST 2008 - Logger.pm: Fix the PART thing properly (Hinrik) - README: A few updates (Hinrik) - Proxy.pm: Fixed a small bug (Hinrik) - Common.pm: Fixed the docs for matches_mask_array() and allow it to be exported (Hinrik) - IRC.pm et al: Improved some warning messages (Hinrik) - IRC.pm: Moved DCC support to a plugin (Hinrik) - IRC.pm: Improved the docs some. Better index and more links. (Hinrik) - The plugin system now uses POE::Component::Pluggable (Hinrik) 5.76 Thu Apr 24 15:05:05 GMT 2008 - Logger.pm: Fixed serious typo in function name. Grr. (Hinrik) - Logger.pm: Handle PARTs correctly when there's no colon (Hinrik) - State.pm: Only WHO users once even if they join many chans (Hinrik) - State.pm: Added channel_creation_time() method (Hinrik) - State.pm: Made channel_modes() return mode arguments as well (Hinrik) - State.pm: Add is_channel_synced() (Hinrik) - PlugMan.pm - bug in new() spotted by plu (bingos) 5.74 Thu Apr 03 15:14:04 GMT 2008 - Logger.pm: Do charset conversion on everything, not just messages. This should handle non-ASCII channel names and nicknames on servers that support such things (Hinrik) - Logger.pm: Allow custom formats to provide their own timestamp in the topic_set_by handler (Hinrik) 5.72 Fri Mar 21 10:33:59 GMT 2008 - Compat.pm: Fixed a bug that caused a warning (Hinrik) - Patch applied from Somni [RT #33850] (bingos) - Fixes to two of the tests that were causing intermitent fails (bingos) - Logger.pm: Make logging work again :) (Hinrik) - Logger.pm: Fix topic_change log string (Hinrik) - State.pm: Document new AwayPoll behavior correctly (Hinrik) - Moved author tests to xt/ Module::Install::AuthorTests is now required by maintainers. (bingos) 5.70 Mon Mar 03 10:51:01 GMT 2008 - BotAddressed.pm: Fixed a small bug (Hinrik) - BotCommand.pm: A new plugin for handling bot commands (Hinrik) - IRC.pm: Shorten protocol lines that are too long, make the maximum length configurable. (Hinrik) - Amended IRC::Compat to do CTCP parsing. Amended dependent modules. (bingos) - Logger.pm: Use File::Spec for cross-platform file/dir creation. (Hinrik) - Make CTCP plugin respond to SOURCE requests (Hinrik) - Added a Cookbook (Hinrik) - State.pm: Save user hop count from WHO replies (Hinrik) - Connector.pm: Added support for multiple servers (Hinrik) - IRC.pm: Improved dcc_resume documentation, moved some others things around in the docs (Hinrik) - Added Hinrik to the maintainers list in IRC.pm (bingos) 5.68 Wed Feb 20 19:49:58 GMT 2008 - IRC.pm: Improved the docs a little, fixed an error in the SYNOPSIS and moved half of it to an example file. Should be less daunting now :) (Hinrik) - State.pm: Lengthen away status polling time to 5 minutes and make the feature optional. (Hinrik) - Common.pm: Improved mIRC color handling code/documentation (Hinrik) 5.66 Mon Feb 18 21:58:48 GMT 2008 - Removed Filter::IRC in favor of Filter::IRC::Compat (Hinrik) - Filter/CTCP.pm: Support filenames with spaces in DCCs (Hinrik) - IRC.pm: Always doube-quote sent DCC files for safety (Hinrik) - Compat.pm: Propagate debug flag to internal CTCP filter (Hinrik) - Updated t/perlcriticrc to exlude a few more policies (Hinrik) - Cleaned up all code and documentation. The changes include: everything needed to satisfy Perl::Critic, use carp/croak instead of warn/die where appropriate, use 4-column indents, use consistent coding style everywhere, some refactoring here and there... (Hinrik) - put Filter::IRC back. It is now a Stackable/IRCD/Compat mash-up (bingos) - full regression testing in 1_filter_compat.t yippee. (bingos) 5.64 Sat Feb 16 07:55:34 GMT 2008 - Logger.pm: Fix regression regarding utf8 detection (Hinrik) - Logger.pm: Don't log channel modes which have different meanings depending on the IRC network we're on. (Hinrik) - NickServID: Tweak it a little (Hinrik) - Add optional Test::Perl::Critic test to detect risky code. Currently 466 violations in about 16k lines of code, whee! (Hinrik) - ISupport.pm: Fix bug in CHANLIMIT handling (Hinrik) - Logger.pm: Missing S_001 return value (Hinrik) - Compat.pm: Fix missing raw_line (Hinrik) - Filter/CTCP.pm: Stop using POE::Filter::IRC (Hinrik) 5.62 Thu Feb 7 16:31:03 GMT 2008 - IRC.pm: Document the nickserv command (Hinrik) - Common.pm: Show some example usage of has_color() (Hinrik) - CycleEmpty.pm: New plugin to cycle empty channels in order to gain channel operator status (Hinrik) - Common.pm: Add more color/formatting codes (Hinrik) - Added plugin test for CycleEmpty (BinGOs) 5.60 Wed Feb 6 13:38:50 GMT 2008 - State.pm: Improved the away tracking code (Hinrik) - Logger.pm: Added missing argument preventing quit messages from being logged (Hinrik) - NickReclaim: Fixed regression introduced in 5.58 (Hinrik) - BotTraffic.pm: irc_bot_ctcp_action => irc_bot_action, to be consistent with BotAddressed.pm (Hinrik) - AutoJoin.pm: Delay autojoin if NickServID is loaded, so the user will be cloaked (if applicable) before joining channels (Hinrik) - Common.pm: Add constants and methods for dealing with colors and formatting (Hinrik) - IRC.pm: Add NICKSERV command, mention the new color stuff (Hinrik) - NickServID: Made it behave more sensibly considering upcoming FreeNode policy changes. Also, use a raw NICKSERV command (Hinrik) - Logger.pm: Rename SortByDate to Sort_by_date and add Strip_color, Strip_formatting (Hinrik) 5.58 Mon Feb 4 07:58:14 GMT 2008 - State.pm: Workaround for IRC servers (e.g. hybrid, hyperion) which send user WHO replies starting with the name of a random channel that the user is on (which the component might not be on) instead of '*' (Hinrik) - State.pm: Track the away status of channel users and send an event if the status changes (Hinrik) - Projects.pm: Some additions and cleanup (Hinrik) - Logger.pm: Add 'Restricted' argument for restricting read permissions of created files/dirs (Hinrik) - Logger.pm: Add 'Format' argument for specifying a custom log format (Hinrik) - Logger.pm: Close log files after writing to them (Hinrik) - Logger.pm: Omit date from timestamp if sorting log files by date (Hinrik) - Logger.pm: Always use present tense (Hinrik) - NickReclaim.pm: Small fix for an edge case (Hinrik) - BotAddressed.pm: Check for '$nick~ $text' as well (Hinrik) - NickServID.pm: Make it work if it's added before connecting (Hinrik) 5.56 Thu Jan 31 12:30:25 GMT 2008 - AutoJoin.pm: Silence some warnings (Hinrik) - Logger.pm: Add SortByDate argument to rotate logs (Hinrik) - Logger.pm: output something in English for every channel mode change (Hinrik) - Logger.pm: made the ACTION syntax distinct from the MODE syntax to allow for sane parsing of log files (Hinrik) - Fix bug causing NickReclaim plugin to only try to reclaim once (Hinrik) - Fix NICK/QUIT logging in Logger plugin (Hinrik) - Minor improvement and documentation update to BotAddressed plugin (Hinrik) 5.54 Sun Jan 27 09:21:27 GMT 2008 - Hinrik added numerous groovey plugins. Hinrik++ 5.52 Mon Jan 14 07:46:01 GMT 2008 - RT #32279: Filter/CTCP.pm doesn't provide raw_line by Hinrik 5.50 Sun Jan 13 10:19:05 GMT 2008 - RT #32271 reported by Hinrik - RT #32265 is_away() support by Hinrik 5.48 Thu Jan 10 20:13:10 GMT 2008 - Added plugin FollowTail, a tail following plugin 5.46 Thu Jan 3 15:12:21 GMT 2008 - 'irc_public' events should now be generated according to ISupport information 5.44 Tue Jan 1 13:58:15 GMT 2008 - Enhancement to part command to handle part messages. RT #32029 reported by Hinrik 5.42 Mon Dec 31 12:29:50 GMT 2007 - Amendments to NickReclaim plugin by Zoffix Znet 5.40 Wed Dec 26 10:55:18 GMT 2007 - Applied a patch from Hinrik to fix umode issues with State.pm 5.38 Thu Dec 6 17:24:23 GMT 2007 - CPAN Testers reports for dev releases look favourable, bumped for proper release. 5.37_02 Thu Dec 6 08:35:47 GMT 2007 - Added is_user_mode_set() method and 'irc_user_mode' event 5.37_01 Wed Dec 5 21:11:46 GMT 2007 - Added umode support to IRC::State 5.36 Thu Nov 1 13:51:02 GMT 2007 - Updated Module::Install to 0.68 5.34 Wed Jul 25 10:51:45 BST 2007 - Fixed abstract_from in Makefile.PL. 5.33_01 Tue Jul 10 17:53:01 BST 2007 - Moved documentation for connect() to spawn(); - Added CTCP PING to Plugin::CTCP; 5.32 Tue Jun 12 12:20:21 BST 2007 - Stable release after working around issues on Solaris. 5.31_05 Mon Jun 11 09:57:09 BST 2007 - Fixed an error in the SYNOPSIS example for Qnet::State; - More diagnostics to the ipv6 test to trigger on solaris; 5.31_04 Tue Jun 05 09:29:34 BST 2007 - More diagnostics to the ipv6 test to trigger on solaris; 5.31_03 Fri Jun 01 10:37:49 BST 2007 - More diagnostics to the ipv6 test to trigger on solaris; 5.31_02 Thu May 31 16:04:06 BST 2007 - More diagnostics to the ipv6 test to trigger on solaris; 5.31_01 Fri May 18 10:11:47 BST 2007 - Added a warning if UseSSL is specified but SSLify wasn't found, requested by H.Merijn Brand; - Added some diagnostics to the ipv6 test to trigger on solaris; 5.30 Tue May 08 19:25:06 BST 2007 - Applied a patch from dec for Plugin::Proxy.pm 5.29 Thu May 03 13:01:01 BST 2007 - 'irc_ctcp' events added by Aankhen`` 5.28 Tue May 01 14:50:08 BST 2007 - Applied a patch from dec to Plugin::Proxy. 5.27 Tue May 01 13:43:39 BST 2007 - Fixed a serious bug relating to PoCo-Client-DNS use, reported by dec 5.26 Sun Apr 29 15:19:56 BST 2007 - Fixed a bug relating to PoCo-Client-DNS use, reported by dec 5.25 Sun Apr 29 13:03:07 BST 2007 - Applied fix for problem with ipv6 support from bsmith - Fixed RT #26735 reported by dec 5.24 Mon Apr 16 13:43:36 BST 2007 - Changed the IPv6 support to only be enabled when 'useipv6' is explicitly used. 5.23 Thu Apr 12 16:07:56 BST 2007 - Added Test::Kwalitee test. - Added new IP functions to ::Common - IPv6 support for connecting to ipv6 ircds. - New IPv6 connect testcase. 5.22 Fri Feb 02 12:02:36 GMT 2007 - Found a bug in ::State that was causing problems during netsplits. 5.21 Thu Feb 01 12:21:45 GMT 2007 - More changes to Qnet::State to include AUTH in part/quit/kick events. Suggested by helios. 5.20 Wed Jan 31 17:25:31 GMT 2007 - Finally converted Makefile.PL to full Module::Install-ness. 5.19 Wed Jan 31 11:54:36 GMT 2007 - Change to ban_mask() method in Qnet::State, suggested by helios. 5.18 Fri Dec 29 10:55:05 GMT 2006 - Documentation fix to ::Plugin by Lyndon Miller. - Still a problem with TOPIC command. Fixed. 5.17 Tue Dec 12 22:52:48 GMT 2006 - Serious bug in TOPIC handling spotted. Fixed. 5.16 Wed Dec 06 11:54:08 GMT 2006 - Refactored the SOCKS code to use $wheel->event() to switch InputEvent. Thanks to dngor for pointing that out. 5.15 Tue Dec 05 19:26:34 GMT 2006 - Implemented SOCKS4 support. Requested by netmunky @ Efnet. Somni assisted with the design. Thanks! 5.14 Wed Nov 29 10:56:57 GMT 2006 - Found a serious problem with refcounts in the registration code. Fixed with merlyn's help. 5.13 Sun Nov 19 14:20:51 GMT 2006 - Fixed long standing bug in 'topic' command. 5.12 Thu Nov 16 14:04:51 GMT 2006 'Hairy COO!' - Documentation fix for ::Pipeline, spotted by Martijn van Beers. - Amended 6_common.t test-case to make sure it covered other edge case reported by 'Elvis Dead' via email. - Setting a delayed command with delay() generates a 'irc-delay_set' event. - Added ability to remove delayed commands. 5.11 Wed Oct 25 16:32:03 BST 2006 - Changed plugin processing so that any poco plugin handlers are now in an eval as well. Pesky edge-cases. - Refactored parse_mode_line() to handle dangerous edge cases. 5.10 Tue Oct 24 18:02:46 BST 2006 - ::State 'irc_kick' event has ARG4 which is the full nick!user@host of the kicked person. Suggested by helios. 5.09 Tue Oct 24 14:48:07 BST 2006 - Forgot a test with the Test::Plugin relocation. Damnit. - Reinstated ::Test::Plugin for the PlugMan tests. 5.08 Mon Oct 23 12:35:04 BST 2006 - Remove ::Test::Plugin and relocated code to the actual test. - Removed the optional debug in Pipeline. If there are errors you'll see them now. - New plugin tests, testing running POE sessions in plugins and dying in PCI_register(). - Deprecated 1_new.t test by removing it. 5.07 Tue Oct 17 11:37:28 BST 2006 - Enabled plugin_debug effect Pipeline. - Added send_event() method for injecting events in the event handling system. 5.06 Thu Oct 12 12:45:06 BST 2006 - Adjusted load() in PlugMan, suggested by Stefan Schwarzkopf. 5.05 Fri Oct 06 14:40:37 BST 2006 - ISupport documentation fix. - Amendments to plugin processing, plugin debugging should be less noisy now. 5.04 Mon Sep 25 13:30:46 BST 2006 - Removed Build.PL - Applied a patch from Ben Jackson which fixes the proxy support. Yay. 5.03 Sat Sep 16 14:17:01 BST 2006 - Switched Makefile.PL to using Make::Install. Added Build.PL - Fixed META.yml handling. - Fixed an unregister bug reported via CPAN::Forum. *sigh* 5.02 Fri Sep 08 16:32:12 BST 2006 - POE-0.37 has found a serious flaw in the shutdown() handler. Fixed. - ::Test::Harness was registering for HUP signal. Stopped that nonsense. 5.01 Thu Sep 07 17:53:00 BST 2006 - Fixed file permissions in the distribution. Again a CPANTS gripe. - Fiddled with State's insides. - Added find_auth_nicks method to Qnet::State, requested by helios. 5.00 Fri Sep 01 02:20:54 BST 2006 YAPC::EU Birmingham 2006 release - Test::Pod::Coverage test added, inspired by CPANTS hackathon, cheers, domm. - Added use strict to ::Constants. - PlugMan plugin will dump $@ when a plugin fails to 'load' now. - Documentation fixes to a lot of modules due to Pod::Coverage. 4.99 Tue Aug 29 17:47:04 BST 2006 - Added resync_chan and resync_nick to Qnet::State subclass, as suggested by helios. 4.98 Fri Aug 18 12:30:31 BST 2006 - Added support for connecting to ircds that support compressed links; only PCSI does this afaik, so limited use for most peeps. - Applied a patch from dec to fix a bug in ISupport plugin, RT #21058. 4.97 Mon Jul 24 12:46:26 BST 2006 - Fixed 'sconnect', it should send 'CONNECT' to the ircd now instead of 'SCONNECT'. - ::State assumed that ircd had returned ISupport info. Set reasonable defaults for ircd's that don't. - Changed 'sl' to 'quote' instead as far as the documented API. 4.96 Sun Jul 16 14:35:34 BST 2006 - Fixed a bug in Console plugin. - Minor code changes to Proxy plugin. - Component will automatically register a parent session if spawned from another session. Added testcase for this also. - Removed the deprecated IRC_EVTS registration bit from _start as the component uses plugin API stylee handlers now. - Tidied up PlugMan plugin code. - Updated documentation stipulating that the module is licensed the same as perl is. - Refactored Whois plugin. Added RPL_WHOISACTUALLY support. 4.95 Wed Jul 05 11:46:34 BST 2006 - Removed stray Dumper() in IRC.pm. - Fixed serious bug in ISupport plugin. 4.94 Sun Jul 02 10:01:45 BST 2006 - Amended the DNS code to implement round-robin type behaviour. - Added POCOIRC_REGISTER and POCOIRC_SHUTDOWN signals for multiple registration and shutdown, respectively. Added applicable tests to the testsuite. - Documentation fixes. Added DIE command. - Added multiple bot SYNOPSIS. 4.93 Tue Jun 13 19:25:45 BST 2006 - ::State, invex & excepts sync'ing when we +[qoah]. - ::State, documentation fixes. - Added 'irc_shutdown' event. - Bug in Qnet::State spotted by helios. Changed inheritance order and cpoied some code from Qnet to Qnet::State accordingly. 4.92 Sun Jun 11 18:09:13 BST 2006 - Added a check to _parseline for spurious blank events, reported by dec. - Added nick_channel_modes method to ::State to return the channel modes (ie. qaohv) of a given nick on a given channel - Lyndon Miller - Added note concerning the issues surrounding the SetAt and SetBy values to CAVEATS in the ::State pod - Lyndon Miller - Improvements to Plugin::PlugMan, it should actually work properly now >:) Thanks to mst and dngor. - ::State, nick_sync now has the channel name as ARG1. - Moved the INVEX and EXCEPTS sync'ing until we are +o'd, created irc_chan_sync_(invex|excepts). irc_chan_sync features the time in seconds taken to sync as ARG1 now. 4.91 Thu Jun 01 21:08:13 BST 2006 - Tweak to ::State to deal with ircds that don't report @+ status in WHO replies ( like unreal ). Thanks to Lyndon Miller for reporting that. - 'irc_dcc_failed' event was undocumented. Fixed. - Switched the poco-client-dns checks to 'use', so as to ensure that we only load >= 0.99. - Amendments to shutdown so that it sends a quit message to the ircd if we are connected. - Amended Connector plugin so the lag is collected independent of what the ircd sends us back. - Various changes to ::State in order to ensure full RFC compliant channel mode support, including support for channel access lists - Lyndon Miller - Added ::State methods to return channel access lists: channel_ban_list, channel_invex_list, channel_except_list - Lyndon Miller - Using 'use' for the dns checks was fubar. Switched back to 'require' and test the VERSION instead. - Changed the simpleclient.pl script to accept a filename as a second argument to /dump_state command. - Documentation tweaks to ::State by Lyndon Miller - Channel topic support added to ::State. Added the method channel_topic to return a hashref of topic data - Lyndon Miller - Changed 'Time' keys for channel lists and topic to 'SetAt' - Added irc_chan_mode event to ::State to allow everyone to enjoy the mode parsing State does internally - Lyndon Miller - Refactored ::Qnet::State subclass after all - Lyndon Miller changes to ::State. - Refactored ::State slightly to use ARG2 for numerics handlers instead of trying to parse ARG1 ourselves. FTW. 4.90 Mon May 22 13:23:09 BST 2006 - Missed the Filter::Stackable in plugins Console and Proxy. 4.89 Mon May 22 09:14:57 BST 2006 - A bug in POE-0.35's Filter::Stackable causing problems with ::Test::Harness. Enabled a runaround *sigh* 4.88 Sun May 21 17:57:38 BST 2006 - Code cleanup in ::Test::Harness. Workaround for systems without %z in strftime, like Solaris. - Added matches_mask() function to ::Common. Updated 6_common.t to add applicable tests. - Added parse_user() function to ::Common. Updated 6_common.t to add applicable tests. - new() deprecation warning specifies the module name. Saves confusion for people who are using Bot::* modules. - Added LUSERS command. - Major hackery to remove dependency on PoCo-Client-(DNS|Ident). 4.87 Sat May 06 17:03:34 BST 2006 - Testsuite 07 and 09 were still skipped on MSWin32. Fixed. - Altered BotAddressed at immute's suggestion. Check docs for details. - Altered Filter::Compat so it won't break with Stackable. - Added 'remove' command a Freenode extension. 4.86 Thu Apr 27 21:18:41 BST 2006 - POD fixes and perl dependency as pointed out by Alias. - Tweak so that the poco only shuts down PoCo-Client-DNS if we spawned it. - Spotted a problem with register() it was still stashing POE::Session refs. Bad BinGOs. - shutdown() will unregister all registered sessions now. - Code audits of State and Qnet::State. Lot's of cleanup. - Changed Common.pm u_irc/l_irc to support a casemapping argument, one may specify 'rfc1459', 'strict-rfc1459' or 'ascii'. Default is 'rfc1459'. - Changed State and Qnet::State to use casemapping for generating unique state keys. - Removed State::Lite. Deprecated. - Online test reports the server connected to. 4.85 Thu Apr 13 12:37:49 BST 2006 - Numerous bug fixes to State and Qnet/State which were causing terminations. Reported by dec. - Tweaks to a number of tests. - Various plugins have been debugged. - Added '/dump_state' command to simpleclient.pl. 4.84 Wed Apr 12 14:24:34 BST 2006 - Spotted a bug in Filter::CTCP, it wasn't setting raw_line. - Bug in dcc code meant DCC tests were failing on certain platforms. Fixed. - Changes to DCC tests. Rolled back MSWin32 skip checks. - Added one more DCC test for testing 'nataddr' option. 4.83 Tue Apr 11 20:45:04 BST 2006 - Changes to two of the DCC tests. DAMN YOU WINDOWS! 4.82 Tue Apr 11 19:32:45 BST 2006 - Sorted out Test::Harness, brought it up to PoCo-Server-IRC-0.3 standard. - Added a multiple client test to the testsuite. - Added socketerr test to the testsuite. - Added subclass test to the testsuite. - Added DCC test scripts to the testsuite. - Fixed a bug in DCC code for CHAT. - Added nick and nick_state tests. - Amended processing order in _send_event() so that the poco session can process events *before* the plugins do. - Plugin system will automagically check whether the poco object has any plugin handlers. These get processed first. - Removed the dependency on Date::Format, switched to POSIX::strftime. - Applied a patch from ketas for State.pm. - Fixes to Pipeline, spotted by dec @ MAGnet. - Added resolver() method for accessing the PoCo-Client-DNS object. - Refactored State.pm, Qnet.pm and Qnet/State.pm, handlers are all processed by plugin system now. Implemented better inheritance. - Expanded the SYNOPSIS sections of Qnet.pm, State.pm and Qnet/State.pm. - Added NickReclaim plugin and associated test. 4.81 Fri Mar 31 17:00:38 BST 2006 - Added PlugMan plugin manager and associated test. - Fixed the RFC docs in docs/. Spotted by integral. Thanks. - Added session_alias() method as suggested by Chris Thompson. - The component's HEAP is now the object. So is retrievable via $_[SENDER]->get_heap() in event handlers. Thanks to CT for the idea. Now why didn't I think of that sooner =[ - Various fixes to Test::Harness ircd. - Expanded the testsuite with 2 new tests. One uses Test::Harness, the other is an online test and tries to connect to freenode. - Fixed all the examples to use POE::Session->create(). - Added a warning to Makefile.PL about the online test. - Added delay() method for posting delayed commands. - Added a test to testsuite for ::State. - Added examples to Plugin docs. 4.80 Thu Mar 16 17:00:01 GMT 2006 - Code tidy up. - Fixed DCC bug. As reported by helios. - POD fix to ::State, missed two methods. - Changed default alias to "$self". Thanks dngor. - General POD rewrite. 4.79 Sun Jan 15 17:15:01 GMT 2006 - Serious bug in _send_event() spotted by ikaros @ freenode. The component wasn't dispatching events to itself since 4.78. 4.78 Tue Jan 10 22:01:09 GMT 2006 - Documentation bug. 'irc_topic' event wasn't documented. Reported by bluepunk @ efnet, through dngor :) - Finally got around to switch session registering from using POE::Session ( ew, nasty ) to session IDs instead. 4.77 Mon Dec 26 17:00:01 GMT 2005 - Forgot to add use ::Common to Qnet::State. Doh. 4.76 Fri Dec 23 15:20:20 GMT 2005 - Documentation bugs in the main IRC.pm SYNOPSIS. Bad BinGOs :( Spotted and reported by Mulander via email. - Added 'plugin_debug' option to dump after plugin evals if applicable. - Spotted a bug with the 'whois' handler. Looks like it has never worked ( properly ). Adjusted 'commasep' for the special case WHOIS mask,mask. - Minor fixes to Filter-IRC-Compat for argument handling. - Minor fixes to Pipeline and plugin_del(). 4.75 Sun Dec 04 17:45:20 GMT 2005 - Fixed a problem with DCC code. Thanks to ketas for the heads up. - Added disconnect() method with docs. - Code audit to make sure all event handlers return undef. - Updates to Connector plugin to fix timeout issues on connection. - Added tests for the included plugins: Connector,BotAddressed and BotTraffic. - Fixed dicebot.pl in examples/ problem with $SIG{INT}. - Updated docs to proxy support is SOCKS v4. - Added raw_events() method to enable/disable/display current irc_raw. - README updates. Notably to mention PoCo-SSLify for SSL links. - Stole japhy's ISupport plugin for .. erm .. new ISupport plugin >;] - Added CTCP.pm from gumbynet source. Added applicable test for it. - Added Console.pm from gumbynet source. Added applicable test for it. - Moved common functions to Common.pm. Amended relevant code to import functions from there. - Added Proxy.pm from gumbynet source. Hacked to make much more useful and robust. Added applicable test for it and added ircproxy.pl to examples/ folder. - Patch applied to BotTraffic plugin from immute. - Completely rehacked how the component handles parsing irc traffic to events. Now using Filter::IRCD with Filter::IRC::Compat to process all input. Input and output filters are stackable. - Patch applied to BotAddressed plugin from immute. 4.74 Wed Oct 26 09:15:21 BST 2005 - *sigh* another problem fixed with the new dns code. 4.73 Wed Oct 26 07:43:03 BST 2005 - Minor problem with PoCo-Client-DNS fixed. 4.72 Tue Oct 25 19:01:05 BST 2005 - Fix to Filter::IRC for INVITE. Apparently, asuka timestamps after the channel name. Doh. Thanks to Johannes Studt for spotting that. - Fixed the documentation in Projects.pm - Solved Ticket #15058, re: NoDNS and multiple PoCo-Client-DNS sessions. 4.71 Thu Oct 13 19:04:01 BST 2005 - Documentation bug in IRC.pm, spotted by cnelson. - Fixed ::State.pm for channel admin/owner support, spotted by Sebastien Wernerus. 4.70 Fri Sep 16 16:45:05 BST 2005 - Fixed a bug where 'irc_raw' events were being switched off after a connect() without parameters was called. 4.69 Mon Sep 05 12:30:01 BST 2005 - 3_connect.t was causing problems on Cygwin. Skipped this test on Cygwin for now. 4.68 Fri Sep 02 14:00:00 BST 2005 - Altered Connector plugin so it starts the auto_ping on 'irc_connected' rather than 'irc_001'. Thanks to British Telecom for enabling me to spot that one. >:] 4.67 - Documentation amendments to Plugin.pm. Well spotted, perigrin :D - Added POD test. - Filter-CTCP.pm fixed. All 'warn's only enabled when debug is set. Thanks to ketas for spotting that one. - Fixed a typo made doing the previous fix. >;) - Added Projects.pm, hopefully a list of PoCo-IRC using projects. - Added placeholder for State::Lite, a lightweight version of State. - Tidied up main PoCo-IRC POD. Added a much better SYNOPSIS. 4.66 Thu Jul 28 17:55:01 BST 2005 - Committed patches from Jeff 'japhy' Pinyan who has hacked prioritisation into the plugin system. Check Plugin.pm and Pipeline.pm for details. 4.65 Wed Jul 13 17:47:08 BST 2005 - Fixed the anamoly where plugins weren't deleted if shutdown() is called. This should fix plugins that based around POE::Session. 4.64 Tue Jul 05 16:25:01 BST 2005 - Fixed POD in Plugin::BotAddressed. - Added BotTraffic.pm plugin. 4.63 Thu Jun 16 21:55:49 BST 2005 - Fixed POD in BotAddressed and Connector plugins, thanks integral @ MagNET for spotting that one. - perigrin pointed out a problem with Test::Harness and dependent components. Updated distribution dependencies and amended Test::Harness accordingly. 4.62 Thu Jun 02 16:43:45 BST 2005 - Spotted another problem with ::Test::Harness, updated Makefile.PL with Date::Format dependency. 4.61 Thu Jun 02 10:38:05 BST 2005 - Found a bug in ::Test::Harness that made it fail tests where POE::Component::Client::DNS wasn't installed. Doh. 4.6 Wed Jun 01 15:28:03 BST 2005 - Applied another ketas patch. - Added BotAddressed plugin. - Added ::Test::Plugin. - Added ::Test::Harness, PoCo-Server-IRC in disguise :) - Added tests for the ::Test::* 4.5 Sun May 22 16:21:08 BST 2005 - Moved repository from cvs to svn \o/ - Applied patch from ketas. - Fixed docs for DCCPorts parameter to connect(). - Removed State.pm plugin as it was becoming difficult to keep in sync with State subclass. Eventually hope to replace State subclass with a proper plugin wrapper. - Relocated constants to Constants.pm, tidied up subclasses. - Added Connector.pm plugin. See docs for details. - PoCo-IRC will now send an 'irc_registered' event to registering sessions. ARG0 will the poco's object. 4.4 Thu Apr 28 15:16:03 BST 2005 - Added event handlers for PING and PONG IRC commands. - Added connected() method, so punters can query if the component is connected to an IRC server or not. - Applied a patch from Apocalypse re: DNS and SSL. - Fixed Filter::IRC so it now parses PONG properly. - ketas pointed out that in State.pm, the state for a channel wasn't getting deleted when the bot parted or got kicked. Fixed. 4.3 Wed Apr 20 09:25:21 BST 2005 - Added 'irc_raw' events and parameter to spawn/connect() to enable them. Thanks to webfox for the idea. 4.2 Thu Apr 14 12:00:00 BST 2005 - Minor changes to State.pm to delete the STATE info when we disconnect, error or socketerr. - Reorganised the distribution. 4.1 Mon Apr 11 11:24:44 BST 2005 - NATAddr bug spotted by apeiron @ MAGnet. Fixed. - webfox spotted a problem with whois plugin and POE Kernel assert_default. Hopefully fixed. 4.0 Tue Apr 05 10:39:42 BST 2005 - Fixed a minor bug in Filter-IRC.pm, where it wasn't decoloning the mode line before splitting it. Thanks to webfox for pointing it out. - Used eval's to make plugins system safe from rogue plugins. *tssk* *tssk* - Plugins system will now try to send events to a plugin method _default() if the call to S_* or U_* fails. - Applied a patch from webfox to enable SSL connections. \o/ - Ported SSL patch to all dependent sub-classes. - Teased and fixed a bug in IRC-State.pm. ban_mask() should work properly now. - paulv @ MAGnet pointed out that spawn() and connect() arguments are case-sensitive. Adapted his patch. Args can be in any case now. 3.9 Mon Mar 21 09:17:05 GMT 2005 - Applied patches from webfox @ MAGnet for UnrealIRCd support in IRC-State.pm and Plugin-State.pm. - Added plugin_list(). 3.8 Mon Mar 14 10:15:22 GMT 2005 - Applied ketas' DCC patch, eventually. - Applied a patch from Zsolt Szalai, which adds support for Freenode's 320 whois response. - Added Apocalypse's port of IRC-State.pm using the plugin API, Plugin-State.pm. - Added my plugin for 'irc_whois' and 'irc_whowas' functionality. - Fixed all the necessary modules to use Whois plugin. 3.7 Fri Mar 04 17:37:34 GMT 2005 - Applied massive patch from Apocalypse @ MAGnet that adds plugins. Read the docs in Plugins.pm for more info. - Corrected some grammar mistakes in Plugins.pm >:o) - Amended IRC-State.pm so that 'irc_nick' and 'irc_quit' have an additional parameter in ARG2 which is an arrayref of channels that are common with the component. 3.6 Tue Mar 01 17:47:05 GMT 2005 "Y Adeilad Daffydd-Sant" ( The Saint David Build(ing) ) - Applied ketas' patch to IRC-State. Adds channel_modes method and some code tidying. - Spotted that in some cases the component *needs* an alias. Made it use an internal alias unless one is specified. - Applied another ketas patch to IRC.pm, puts a friendly message when we can't allocate a DCC port. - Updated IRC-Qnet-State.pm to use a 'querytype' in the extended WHO command, to specify or WHO queries, due to spurious channels appearing in the state. Big thanks to MikeC @ Qnet for the pointers. 3.5 Wed Feb 23 13:28:05 GMT 2005 - IRC-State bug spotted and patched by ketas @ MAGnet - Same bug caught and squashed in IRC-Qnet-State by me. - Sorted out DCCPorts. It has to be an arrayref now. 3.4 Fri Feb 18 12:01:58 GMT 2005 - Deprecated new() in favour of new constructor spawn(). spawn() will except all the same parameters as connect(). Moved config stuff to _configure() to save duplication. - Changed all the object constructors about. Bit tedious but now it is alot easier to subclass. See _create(). - Added a hack for $self->session_id(). Made 'alias' optional if used with 'spawn'. - Added parameter NATPort so one can specify the NAT address that a bot appears to other IRC clients as for DCC transfers, etc. - Added DCCPorts parameter so that one can specify a range of ports to use for initiating DCC, instead of using 0. - Implemented and added subclass ::State which provides nickname and channel tracking. \o/ - Implemented and added subclass ::Qnet::State the ::State ported to the Qnet module. - Fixed the event dispatchers in _sock_up and _sock_down to use _send_event like everyone else. Danke to Apocalypse for spotting that. Amended _send_event so that 'irc_connected' and 'irc_disconnected' get sent to every session not just those that ask for it, as was the original behaviour. - Documentation updates for all the new stuff. - Added CVSLOG which contains all the glorious changes in developing this thingy. :) - Added send_queue() method, as I noticed that merlyn's logfile tailing code was accessing the heap and i moved all heap stuff to the object. *sigh* hacked it so that $heap holds a reference to $self->{send_queue} which should work. 3.3 Wed Feb 02 14:07:03 GMT 2005 - Updated IRC-Qnet to a). support new whois/whowas; b). support irc_330 which is the account on ircu. 3.2 Wed Feb 02 11:00:59 GMT 2005 - Implemented 'irc_whois' and 'irc_whowas' which gather all the salient data from the numeric replies and send one event containing a hashref. As suggested by numerous bods on #PoE @ MAGnet >;o) 3.1 Fri Jan 21 11:59:56 GMT 2005 - Converted _send_event sub to object method. - Added IRC-Qnet, with specific extensions for Quakenet. - Updated README 3.0 Fri Dec 31 09:00:01 GMT 2004 - Fixed Filter-IRC so that it groks WALLOPS properly. - Added docs/ and populated it with rfcs applicable to IRC. - Added a slightly more substantial test case, moved it to t/ - Converted use of HEAP to OBJECT. PoCo-IRC is *now* an object. - Added a fix for the infamous PART bug. Has to be explicitly enabled by specifying PartFix => 1 in the 'connect' handler. - Added a switch to 'connect' so that the use of PoCo::Client::DNS can be disabled if necessary. - Applied the outstanding patches: - PoCo::Client::DNS patch by Jim Westfall - DCC Resume patch by Bruno Boettcher - Flood doc patch by Rocco Caputo - Debug param patch by Paul Visscher - Proxy Support patch by Jeff Pinyan - Locops patch by Jon Nistor ========== Maintainership changed from Fimm to BinGOs ==================== 2.9 Sat Jul 19 13:32:45 PDT 2003 - Only one change this time: Adam Foxson's patch to add prioritized notices. 2.8 Sat Jun 7 16:13:25 PDT 2003 - Applied dngor's mega-patch, which fixes (among other things): a fix for a nasty lockup, improved error reporting, and better flood control. - Fixed some broken URLs and a couple mistakes in the documentation. 2.7 Sun Feb 2 15:05:28 PST 2003 - Fixed up the example scripts to play nicer with POE's new signal handling. Thanks to dngor for bringing this up. - Added a patch by lunartear to properly handle spaces in DCC filenames. - Fixed a bug reported by Robert Rendler regarding CTCP quoting accidentally duplicating backslashes. 2.6 Wed Dec 11 20:27:51 PST 2002 - Brian Kelly thoughtfully pointed out an URL in the documentation that was being mangled by pod2html. Should look better now. - Added a note about handling CTCP actions to the POD documentation, since that seems to be a source of confusion for a lot of people. - Added a 'list' event, which I seem to have overlooked entirely until now. Thanks to J.D. McCown for pointing it out. - Attempted to add Jim Westfall's asynchronous DNS patch, but I really need to learn a little more about IPv6 before I attempt to port somebody else's code to it. Hopefully in the next release. 2.5 Sun Oct 27 11:03:57 PST 2002 - Added an AIM <-> IRC proxy bot to the example scripts. Share and enjoy! - I just now noticed that POE::Component::IRC sessions never get garbage-collected. DOH. Now you can send them "shutdown" events to make them go away. Too bad it's probably too late to be breaking backwards compatibility on this... sigh. - Added a bug fix from Trym Skaar (those Norwegians get the coolest names!) which fixes a potential crash while closing DCC connections. - Added a mega-patch from the unstoppable Rocco Caputo which prioritizes messages sent to the IRC server by importance. This ensures that pings and login information will always keep flowing, even if your bot's inane chatter has been throttled. 2.4 Thu Oct 10 14:22:04 PDT 2002 - Added a patch from dngor to fix a crash caused by IRC servers sometimes inexplicably sending a blank line. - Added a patch from Jim Westfall which speeds up DCC file transfers by a couple orders of magnitude. Yay, Jim! 2.3 Fri Sep 6 07:59:50 PDT 2002 - Fixed a rare "uninitialized value" warning in oneoptarg(). - Added a patch from Trym Skaar which makes sure that DCC buffers are flushed before closing a connection. Thanks, Trym! 2.2 Fri May 24 13:00:44 PDT 2002 - dngor found an excellent page about IRC server numeric codes, which I added a link to in the documentation. - dngor also gave me two more patches: one to avoid some deprecation warnings introduced in the latest version of POE, and another which fixed a bug in one of his earlier patches. He's such a stud. 2.1 Mon Mar 4 17:06:03 PST 2002 - Added a long-buried patch from thefly to fix IRCnet channel name parsing. Sorry about the long turnaround on that one. - Applied Scott Beck's patch to Rocco's refcount patch. The whole "sessions not being GCed" brain-damage should be fixed now. 2.0 Fri Feb 22 15:23:23 PST 2002 - Rocco Caputo gave me two patches to apply; the first was a fix to his earlier output throttling patch, and the second was a snippet of code that will allow bot-writers to avoid having to set aliases on their control sessions to keep them alive. Cool! 1.9 Wed Dec 12 22:44:13 PST 2001 - David Dollar pointed out a bug with DCC using the wrong interface on multihomed hosts. Easy fix. 1.8 Mon Dec 10 16:04:06 PST 2001 - Applied dngor's studly patch to throttle line output. - Fixed a bug that would cause events to get thrown away if they came in while the connection to the IRC server was down. 1.7 Sat Jul 21 00:46:06 PDT 2001 - Fixed bugs in my initial implementations of the irc_invite event. Sigh. You ever have one of those days where you can't do anything right? Thanks again to the exceedingly patient Rasmus Hansen for pointing out that my updated version still didn't work right. - Fixed a bug in 'dcc_close' which prevented it from calling 'irc_dcc_done' handlers properly. 1.5 Thu Jul 5 15:24:31 PDT 2001 - Added an irc_invite event -- I knew I'd forgotten something! Thanks to Rasmus Hansen for the bug report. - Fixed a bug in topic() that would accidentally clear the topic when trying to query it. More thanks to Rasmus Hansen. 1.4 Mon Jul 2 17:10:59 PDT 2001 - One of the fixes in 1.3 broke newline handling horribly, such that it was sending two sets of line terminators on every line. I am a doofus. Patched by Rocco Caputo. 1.3 Sat Jun 30 17:29:30 PDT 2001 - The Indomitable Mark-Jason "Ominous" Dominus sent me so many patches and bug reports I'm almost at a loss to list them all. Among others, DCC SENDs no longer report the local pathname to the client on the other end, multiple concurrent DCC connections work, and some documentation errors have been fixed. - Many thanks to the infinitely studly Kees Cook, who, in addition to having a really cool name, sent me a big patch for lots of DCC bugs. DCC connections will now report errors and close their sockets properly! Woohoo! Also, 'irc_dcc_error' events give you more information about the connection that failed, and the 'dcc_accept' event now lets you rename incoming DCC files. - Fixed a silly bug; sl() was sending \n instead of \r\n as a line terminator. - Changed lots of Filter::CTCP die()s to warn()s, on the advice of Peter Barabas. Thanks, Peter! 1.2 Thu May 24 02:36:40 PDT 2001 - I have learned a valuable lesson about not including debugging prints in released code. Especially when the debugging code in question consists of somewhat vulgar inside jokes. :-) 1.1 Fri Mar 2 03:07:01 PST 2001 - A couple patches from Jonathan Steinert: 'ctcp', 'privmsg', and 'notice' will join() their arguments together with spaces, and 'kick' will no longer accidentally concatenate the nick onto the kick message. Thanks, Jon! 1.0 Wed Feb 21 15:09:56 PST 2001 - Split 'irc_ctcp' messages into 'irc_ctcp' and 'irc_ctcpreply'. My thanks to Jonathan Steinert. - Rocco "dngor" Caputo fixed up my DCC code for me, which was so broken as to exercise POE::Kernel bugs. :-) With his fixes in mind, I rewrote pretty much all the DCC stuff; it's much less hairy now. - Added 'dcc_chat' and 'dcc_accept' commands. - Moved all scripts into the "examples" directory and added a dummy test.pl, so it won't hang during CPAN installations anymore. - Worked around a bug in POE versions <0.1201, which caused DCC SEND/GET connections not to properly respond to pending data. - DCC connections should function properly now. Let me know if you experience problems. 1.0b Sat Jan 13 14:49:22 PST 2001 - This is a beta release. It may not entirely work, and DCC receive is still unimplemented. I'll list the bugs I remember fixing below. 1.0 final will have DCC receive capability, I promise! - CTCP event names are now in the form of "irc_ctcp_ping" or whatever. See the POD documentation. - CTCP events now actually include the sender and recipient names. - The infamous "Not an ARRAY reference" bug should now go away. Make sure you're using a recent version of POE! Turned out it was a bug in POE::Filter::Line. 0.15 Tue Aug 10 19:21:58 EDT 1999 - Well, it sucked for the first revision, at least. In my eager haste, I released the CTCP code with numerous debugging prints scattered throughout the source, some serious brokenness in mixed-mode messages, and a totally unimplemented put() method. All fixed! You can now actually send CTCP messages with the 'ctcp' and 'ctcpreply' events. Now to hack on DCC... 0.14 Sun Aug 8 18:29:46 EDT 1999 - Wrote documentation for POE::Filter::IRC. - Moved Filter.pm to Filter-IRC.pm, in preparation for adding a CTCP filter. - Addi fixed a nasty bug with public/msg handling in the Filter-IRC module. I am SUCH a neen. - Finally sat down and wrote the bloody CTCP filter, at long last. Don't be surprised if it sucks for the first few revisions... the last one I wrote did, too. On the other hand, this uses big chunks of the working code from that effort, so maybe I'll get lucky this time. 0.13 Fri Jun 4 03:56:13 EDT 1999 - Split the parser off into a separate POE::Filter::IRC module. The surgery was surprisingly easy, but I had to do an ugly Makefile.PL hack to get it to install correctly. 0.12 Fri Jun 4 01:16:55 EDT 1999 - Wrote a nice README, finally. - Fixed a bug in the test.pl script where I accidentally referred to the 'irc_disconnected' event as 'irc_disconnect'. No wonder it wasn't shutting down properly. 0.11 Thu Jun 3 18:41:51 EDT 1999 - Spruced up the parser's regexps with a lot of " +"'s. - Turned off all the massively verbose debugging code. - Realized that I need to write a README. 0.1 Thu Jun 3 16:55:24 EDT 1999 - Completely functional, minus CTCP and DCC. 0.1a Mon May 17 09:11:48 EDT 1999 - Released for a little private QA to oznoid and dngor. Moderately functional. Can send every command (I think), and has a half-written parser that handles the most common IRC events, and a few which it wasn't meant to handle. ============================================================================= Key: Qnet == Quakenet MAGnet == MAGnet EFNet == efnet POE-Component-IRC-6.90/MANIFEST.SKIP0000644000175000017500000000010313153565114015666 0ustar bingosbingos^POE-Component-IRC- ^cover_db/ ^utils/developer/ ^xt/ ^README.pod$ POE-Component-IRC-6.90/lib/0000755000175000017500000000000013153565114014544 5ustar bingosbingosPOE-Component-IRC-6.90/lib/POE/0000755000175000017500000000000013153565114015167 5ustar bingosbingosPOE-Component-IRC-6.90/lib/POE/Filter/0000755000175000017500000000000013153565114016414 5ustar bingosbingosPOE-Component-IRC-6.90/lib/POE/Filter/IRC.pm0000644000175000017500000000351713153565114017375 0ustar bingosbingospackage POE::Filter::IRC; our $AUTHORITY = 'cpan:HINRIK'; $POE::Filter::IRC::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use POE::Filter::Stackable; use POE::Filter::IRCD; use POE::Filter::IRC::Compat; sub new { my ($package, %opts) = @_; $opts{lc $_} = delete $opts{$_} for keys %opts; return POE::Filter::Stackable->new( Filters => [ POE::Filter::IRCD->new( DEBUG => $opts{debug} ), POE::Filter::IRC::Compat->new( DEBUG => $opts{debug} ), ], ); } 1; =encoding utf8 =head1 NAME POE::Filter::IRC -- A POE-based parser for the IRC protocol =head1 SYNOPSIS my $filter = POE::Filter::IRC->new(); my @events = @{ $filter->get( [ @lines ] ) }; =head1 DESCRIPTION POE::Filter::IRC takes lines of raw IRC input and turns them into weird little data structures, suitable for feeding to L. They look like this: { name => 'event name', args => [ some info about the event ] } This module was long deprecated in L. It now uses the same mechanism that that uses to parse IRC text. =head1 CONSTRUCTOR =head2 C Returns a new L object containing a L object and a L object. This does the same job that POE::Filter::IRC used to do. =head1 METHODS See the documentation for POE::Filter::IRCD and POE::Filter::IRC::Compat. =head1 AUTHOR Dennis C Taylor Refactoring by Chris C Williams =head1 SEE ALSO The documentation for L and L. L L L =cut POE-Component-IRC-6.90/lib/POE/Filter/IRC/0000755000175000017500000000000013153565114017031 5ustar bingosbingosPOE-Component-IRC-6.90/lib/POE/Filter/IRC/Compat.pm0000644000175000017500000003605613153565114020624 0ustar bingosbingospackage POE::Filter::IRC::Compat; our $AUTHORITY = 'cpan:HINRIK'; $POE::Filter::IRC::Compat::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use POE::Filter::IRCD; use File::Basename qw(fileparse); use base qw(POE::Filter); my %irc_cmds = ( qr/^\d{3}$/ => sub { my ($self, $event, $line) = @_; $event->{args}->[0] = _decolon( $line->{prefix} ); shift @{ $line->{params} }; if ( $line->{params}->[0] && $line->{params}->[0] =~ /\x20/ ) { $event->{args}->[1] = $line->{params}->[0]; } else { $event->{args}->[1] = join(' ', ( map { /\x20/ ? ":$_" : $_ } @{ $line->{params} } ) ); } $event->{args}->[2] = $line->{params}; }, qr/^cap$/ => sub { my ($self, $event, $line) = @_; for (my $i = 0; ; $i++) { last if !defined $line->{params}[$i+1]; $event->{args}[$i] = $line->{params}[$i+1]; } }, qr/^notice$/ => sub { my ($self, $event, $line) = @_; if (defined $line->{prefix} && $line->{prefix} =~ /!/) { $event->{args} = [ _decolon( $line->{prefix} ), [split /,/, $line->{params}->[0]], ($self->{identifymsg} ? _split_idmsg($line->{params}->[1]) : $line->{params}->[1] ), ]; } else { $event->{name} = 'snotice'; $event->{args} = [ $line->{params}->[1], $line->{params}->[0], (defined $line->{prefix} ? _decolon($line->{prefix}) : ()), ]; } }, qr/^privmsg$/ => sub { my ($self, $event, $line) = @_; if ( grep { index( $line->{params}->[0], $_ ) >= 0 } @{ $self->{chantypes} } ) { $event->{args} = [ _decolon( $line->{prefix} ), [split /,/, $line->{params}->[0]], ($self->{identifymsg} ? _split_idmsg($line->{params}->[1]) : $line->{params}->[1] ), ]; $event->{name} = 'public'; } else { $event->{args} = [ _decolon( $line->{prefix} ), [split /,/, $line->{params}->[0]], ($self->{identifymsg} ? _split_idmsg($line->{params}->[1]) : $line->{params}->[1] ), ]; $event->{name} = 'msg'; } }, qr/^invite$/ => sub { my ($self, $event, $line) = @_; shift( @{ $line->{params} } ); unshift( @{ $line->{params} }, _decolon( $line->{prefix} || '' ) ) if $line->{prefix}; $event->{args} = $line->{params}; }, ); # the magic cookie jar my %dcc_types = ( qr/^(?:CHAT|SEND)$/ => sub { my ($nick, $type, $args) = @_; my ($file, $addr, $port, $size); return if !(($file, $addr, $port, $size) = $args =~ /^(".+"|[^ ]+) +(\d+) +(\d+)(?: +(\d+))?/); if ($file =~ s/^"//) { $file =~ s/"$//; $file =~ s/\\"/"/g; } $file = fileparse($file); return ( $port, { nick => $nick, type => $type, file => $file, size => $size, addr => $addr, port => $port, }, $file, $size, $addr, ); }, qr/^(?:ACCEPT|RESUME)$/ => sub { my ($nick, $type, $args) = @_; my ($file, $port, $position); return if !(($file, $port, $position) = $args =~ /^(".+"|[^ ]+) +(\d+) +(\d+)/); $file =~ s/^"|"$//g; $file = fileparse($file); return ( $port, { nick => $nick, type => $type, file => $file, size => $position, port => $port, }, $file, $position, ); }, ); sub new { my ($package, %self) = @_; $self{lc $_} = delete $self{$_} for keys %self; $self{BUFFER} = [ ]; $self{_ircd} = POE::Filter::IRCD->new(); $self{chantypes} = [ '#', '&' ] if ref $self{chantypes} ne 'ARRAY'; return bless \%self, $package; } sub clone { my $self = shift; my $nself = { }; $nself->{$_} = $self->{$_} for keys %{ $self }; $nself->{BUFFER} = [ ]; return bless $nself, ref $self; } # Set/clear the 'debug' flag. sub debug { my ($self, $flag) = @_; if (defined $flag) { $self->{debug} = $flag; $self->{_ircd}->debug($flag); } return $self->{debug}; } sub chantypes { my ($self, $ref) = @_; return if ref $ref ne 'ARRAY' || !@{ $ref }; $self->{chantypes} = $ref; return 1; } sub identifymsg { my ($self, $switch) = @_; $self->{identifymsg} = $switch; return; } sub _split_idmsg { my ($line) = @_; my ($identified, $msg) = split //, $line, 2; $identified = $identified eq '+' ? 1 : 0; return $msg, $identified; } sub get_one { my ($self) = @_; my $line = shift @{ $self->{BUFFER} } or return [ ]; if (ref $line ne 'HASH' || !$line->{command} || !$line->{params}) { warn "Received line '$line' that is not IRC protocol\n" if $self->{debug}; return [ ]; } if ($line->{command} =~ /^PRIVMSG|NOTICE$/ && $line->{params}->[1] =~ tr/\001//) { return $self->_get_ctcp($line); } my $event = { name => lc $line->{command}, raw_line => $line->{raw_line}, }; for my $cmd (keys %irc_cmds) { if ($event->{name} =~ $cmd) { $irc_cmds{$cmd}->($self, $event, $line); return [ $event ]; } } # default unshift( @{ $line->{params} }, _decolon( $line->{prefix} || '' ) ) if $line->{prefix}; $event->{args} = $line->{params}; return [ $event ]; } sub get_one_start { my ($self, $lines) = @_; push @{ $self->{BUFFER} }, @$lines; return; } sub put { my ($self, $lineref) = @_; my $quoted = [ ]; push @$quoted, _ctcp_quote($_) for @$lineref; return $quoted; } # Properly CTCP-quotes a message. Whoop. sub _ctcp_quote { my ($line) = @_; $line = _low_quote( $line ); #$line =~ s/\\/\\\\/g; $line =~ s/\001/\\a/g; return "\001$line\001"; } # Splits a message into CTCP and text chunks. This is gross. Most of # this is also stolen from Net::IRC, but I (fimm) wrote that too, so it's # used with permission. ;-) sub _ctcp_dequote { my ($msg) = @_; my (@chunks, $ctcp, $text); # CHUNG! CHUNG! CHUNG! if (!defined $msg) { croak 'Not enough arguments to POE::Filter::IRC::Compat::_ctcp_dequote'; } # Strip out any low-level quoting in the text. $msg = _low_dequote( $msg ); # Filter misplaced \001s before processing... (Thanks, tchrist!) substr($msg, rindex($msg, "\001"), 1, '\\a') if ($msg =~ tr/\001//) % 2 != 0; return if $msg !~ tr/\001//; @chunks = split /\001/, $msg; shift @chunks if !length $chunks[0]; # FIXME: Is this safe? for (@chunks) { # Dequote unnecessarily quoted chars, and convert escaped \'s and ^A's. s/\\([^\\a])/$1/g; s/\\\\/\\/g; s/\\a/\001/g; } # If the line begins with a control-A, the first chunk is a CTCP # message. Otherwise, it starts with text and alternates with CTCP # messages. Really stupid protocol. if ($msg =~ /^\001/) { push @$ctcp, shift @chunks; } while (@chunks) { push @$text, shift @chunks; push @$ctcp, shift @chunks if @chunks; } return ($ctcp, $text); } sub _decolon { my ($line) = @_; $line =~ s/^://; return $line; } ## no critic (Subroutines::ProhibitExcessComplexity) sub _get_ctcp { my ($self, $line) = @_; # Is this a CTCP request or reply? my $ctcp_type = $line->{command} eq 'PRIVMSG' ? 'ctcp' : 'ctcpreply'; # CAPAP IDENTIFY-MSG is only applied to ACTIONs my ($msg, $identified) = ($line->{params}->[1], undef); ($msg, $identified) = _split_idmsg($msg) if $self->{identifymsg} && $msg =~ /^.ACTION/; my $events = [ ]; my ($ctcp, $text) = _ctcp_dequote($msg); if (!defined $ctcp) { warn "Received malformed CTCP message: $msg\n" if $self->{debug}; return $events; } my $nick = defined $line->{prefix} ? (split /!/, $line->{prefix})[0] : undef; # We only process the first CTCP. The only people who send multiple ones # are those who are trying to flood our outgoing queue anyway (e.g. by # having us reply to 20 VERSION requests at a time). my ($name, $args); CTCP: for my $string ($ctcp->[0]) { if (!(($name, $args) = $string =~ /^(\w+)(?: +(.*))?/)) { defined $nick ? do { warn "Received malformed CTCP message from $nick: $string\n" if $self->{debug} } : do { warn "Trying to send malformed CTCP message: $string\n" if $self->{debug} } ; last CTCP; } if (lc $name eq 'dcc') { my ($dcc_type, $rest); if (!(($dcc_type, $rest) = $args =~ /^(\w+) +(.+)/)) { defined $nick ? do { warn "Received malformed DCC request from $nick: $args\n" if $self->{debug} } : do { warn "Trying to send malformed DCC request: $args\n" if $self->{debug} } ; last CTCP; } $dcc_type = uc $dcc_type; my ($handler) = grep { $dcc_type =~ /$_/ } keys %dcc_types; if (!$handler) { warn "Unhandled DCC $dcc_type request: $rest\n" if $self->{debug}; last CTCP; } my @dcc_args = $dcc_types{$handler}->($nick, $dcc_type, $rest); if (!@dcc_args) { defined $nick ? do { warn "Received malformed DCC $dcc_type request from $nick: $rest\n" if $self->{debug} } : do { warn "Trying to send malformed DCC $dcc_type request: $rest\n" if $self->{debug} } ; last CTCP; } push @$events, { name => 'dcc_request', args => [ $line->{prefix}, $dcc_type, @dcc_args, ], raw_line => $line->{raw_line}, }; } else { push @$events, { name => $ctcp_type . '_' . lc $name, args => [ $line->{prefix}, [split /,/, $line->{params}->[0]], (defined $args ? $args : ''), (defined $identified ? $identified : () ), ], raw_line => $line->{raw_line}, }; } } # XXX: I'm not quite sure what this is for, but on FreeNode it adds an # extra bogus event and displays a debug message, so I have disabled it. # FreeNode precedes PRIVMSG and CTCP ACTION messages with '+' or '-'. #if ($text && @$text) { # my $what; # ($what) = $line->{raw_line} =~ /^(:[^ ]+ +\w+ +[^ ]+ +)/ # or warn "What the heck? '".$line->{raw_line}."'\n" if $self->{debug}; # $text = (defined $what ? $what : '') . ':' . join '', @$text; # $text =~ s/\cP/^P/g; # warn "CTCP: $text\n" if $self->{debug}; # push @$events, @{ $self->{_ircd}->get([$text]) }; #} return $events; } # Quotes a string in a low-level, protocol-safe, utterly brain-dead # fashion. Returns the quoted string. sub _low_quote { my ($line) = @_; my %enquote = ("\012" => 'n', "\015" => 'r', "\0" => '0', "\cP" => "\cP"); if (!defined $line) { croak 'Not enough arguments to POE::Filter::IRC::Compat->_low_quote'; } if ($line =~ tr/[\012\015\0\cP]//) { # quote \n, \r, ^P, and \0. $line =~ s/([\012\015\0\cP])/\cP$enquote{$1}/g; } return $line; } # Does low-level dequoting on CTCP messages. I hate this protocol. # Yes, I copied this whole section out of Net::IRC. sub _low_dequote { my ($line) = @_; my %dequote = (n => "\012", r => "\015", 0 => "\0", "\cP" => "\cP"); if (!defined $line) { croak 'Not enough arguments to POE::Filter::IRC::Compat->_low_dequote'; } # dequote \n, \r, ^P, and \0. # Thanks to Abigail (abigail@foad.org) for this clever bit. if ($line =~ tr/\cP//) { $line =~ s/\cP([nr0\cP])/$dequote{$1}/g; } return $line; } 1; =encoding utf8 =head1 NAME POE::Filter::IRC::Compat - A filter which converts L output into L events =head1 SYNOPSIS my $filter = POE::Filter::IRC::Compat->new(); my @events = @{ $filter->get( [ @lines ] ) }; my @msgs = @{ $filter->put( [ @messages ] ) }; =head1 DESCRIPTION POE::Filter::IRC::Compat is a L that converts L output into the L compatible event references. Basically a hack, so I could replace L with something that was more generic. Among other things, it converts normal text into thoroughly CTCP-quoted messages, and transmogrifies CTCP-quoted messages into their normal, sane components. Rather what you'd expect a filter to do. A note: the CTCP protocol sucks bollocks. If I ever meet the fellow who came up with it, I'll shave their head and tattoo obscenities on it. Just read the "specification" (F in this distribution) and you'll hopefully see what I mean. Quote this, quote that, quote this again, all in different and weird ways... and who the hell needs to send mixed CTCP and text messages? WTF? It looks like it's practically complexity for complexity's sake -- and don't even get me started on the design of the DCC protocol! Anyhow, enough ranting. Onto the rest of the docs... =head1 METHODS =head2 C Returns a POE::Filter::IRC::Compat object. Takes no arguments. =head2 C Makes a copy of the filter, and clears the copy's buffer. =head2 C Takes an arrayref of L hashrefs and produces an arrayref of L compatible event hashrefs. Yay. =head2 C, C These perform a similar function as C but enable the filter to work with L. =head2 C Takes an array reference of CTCP messages to be properly quoted. This doesn't support CTCPs embedded in normal messages, which is a brain-dead hack in the protocol, so do it yourself if you really need it. Returns an array reference of the quoted lines for sending. =head2 C Takes an optinal true/false value which enables/disables debugging accordingly. Returns the debug status. =head2 C Takes an arrayref of possible channel prefix indicators. =head2 C Takes a boolean to turn on/off the support for CAPAB IDENTIFY-MSG. =head1 AUTHOR Chris 'BinGOs' Williams =head1 SEE ALSO L L L =cut POE-Component-IRC-6.90/lib/POE/Component/0000755000175000017500000000000013153565114017131 5ustar bingosbingosPOE-Component-IRC-6.90/lib/POE/Component/IRC.pm0000644000175000017500000030264013153565114020111 0ustar bingosbingospackage POE::Component::IRC; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use POE qw(Wheel::SocketFactory Wheel::ReadWrite Driver::SysRW Filter::Line Filter::Stream Filter::Stackable); use POE::Filter::IRCD; use POE::Filter::IRC::Compat; use POE::Component::IRC::Constants qw(:ALL); use POE::Component::IRC::Plugin qw(:ALL); use POE::Component::IRC::Plugin::DCC; use POE::Component::IRC::Plugin::ISupport; use POE::Component::IRC::Plugin::Whois; use Socket qw(AF_INET SOCK_STREAM unpack_sockaddr_in inet_ntoa inet_aton); use base qw(POE::Component::Syndicator); our ($GOT_SSL, $GOT_CLIENT_DNS, $GOT_SOCKET6, $GOT_ZLIB); BEGIN { eval { require POE::Component::SSLify; import POE::Component::SSLify qw( Client_SSLify SSLify_ContextCreate ); $GOT_SSL = 1; }; eval { require POE::Component::Client::DNS; $GOT_CLIENT_DNS = 1 if $POE::Component::Client::DNS::VERSION >= 0.99; }; eval { require POE::Filter::Zlib::Stream; $GOT_ZLIB = 1 if $POE::Filter::Zlib::Stream::VERSION >= 1.96; }; # Socket6 provides AF_INET6 where earlier Perls' Socket don't. eval { Socket->import(qw(AF_INET6 unpack_sockaddr_in6 inet_ntop)); $GOT_SOCKET6 = 1; }; if (!$GOT_SOCKET6) { eval { require Socket6; Socket6->import(qw(AF_INET6 unpack_sockaddr_in6 inet_ntop)); $GOT_SOCKET6 = 1; }; if (!$GOT_SOCKET6) { # provide a dummy sub so code compiles *AF_INET6 = sub { ~0 }; } } } # BINGOS: I have bundled up all the stuff that needs changing # for inherited classes into _create. This gets called from 'spawn'. # $self->{OBJECT_STATES_ARRAYREF} contains event mappings to methods that have # the same name, gets passed to POE::Session->create as $self => [ ]; # $self->{OBJECT_STATES_HASHREF} contains event mappings to methods, where the # event and the method have diferent names. # $self->{IRC_CMDS} contains the traditional %irc_commands, mapping commands # to events and the priority that the command has. sub _create { my ($self) = @_; $self->{IRC_CMDS} = { rehash => [ PRI_HIGH, 'noargs', ], die => [ PRI_HIGH, 'noargs', ], restart => [ PRI_HIGH, 'noargs', ], quit => [ PRI_NORMAL, 'oneoptarg', ], version => [ PRI_HIGH, 'oneoptarg', ], time => [ PRI_HIGH, 'oneoptarg', ], trace => [ PRI_HIGH, 'oneoptarg', ], admin => [ PRI_HIGH, 'oneoptarg', ], info => [ PRI_HIGH, 'oneoptarg', ], away => [ PRI_HIGH, 'oneoptarg', ], users => [ PRI_HIGH, 'oneoptarg', ], lusers => [ PRI_HIGH, 'oneoptarg', ], locops => [ PRI_HIGH, 'oneoptarg', ], operwall => [ PRI_HIGH, 'oneoptarg', ], wallops => [ PRI_HIGH, 'oneoptarg', ], motd => [ PRI_HIGH, 'oneoptarg', ], who => [ PRI_HIGH, 'oneoptarg', ], nick => [ PRI_HIGH, 'onlyonearg', ], oper => [ PRI_HIGH, 'onlytwoargs', ], invite => [ PRI_HIGH, 'onlytwoargs', ], squit => [ PRI_HIGH, 'onlytwoargs', ], kill => [ PRI_HIGH, 'onlytwoargs', ], privmsg => [ PRI_NORMAL, 'privandnotice', ], privmsglo => [ PRI_NORMAL+1, 'privandnotice', ], privmsghi => [ PRI_NORMAL-1, 'privandnotice', ], notice => [ PRI_NORMAL, 'privandnotice', ], noticelo => [ PRI_NORMAL+1, 'privandnotice', ], noticehi => [ PRI_NORMAL-1, 'privandnotice', ], squery => [ PRI_NORMAL, 'privandnotice', ], join => [ PRI_HIGH, 'oneortwo', ], summon => [ PRI_HIGH, 'oneortwo', ], sconnect => [ PRI_HIGH, 'oneandtwoopt', ], whowas => [ PRI_HIGH, 'oneandtwoopt', ], stats => [ PRI_HIGH, 'spacesep', ], links => [ PRI_HIGH, 'spacesep', ], mode => [ PRI_HIGH, 'spacesep', ], servlist => [ PRI_HIGH, 'spacesep', ], cap => [ PRI_HIGH, 'spacesep', ], part => [ PRI_HIGH, 'commasep', ], names => [ PRI_HIGH, 'commasep', ], list => [ PRI_HIGH, 'commasep', ], whois => [ PRI_HIGH, 'commasep', ], ctcp => [ PRI_HIGH, 'ctcp', ], ctcpreply => [ PRI_HIGH, 'ctcp', ], ping => [ PRI_HIGH, 'oneortwo', ], pong => [ PRI_HIGH, 'oneortwo', ], }; my %event_map = map {($_ => $self->{IRC_CMDS}->{$_}->[CMD_SUB])} keys %{ $self->{IRC_CMDS} }; $self->{OBJECT_STATES_HASHREF} = { %event_map, quote => 'sl', }; $self->{OBJECT_STATES_ARRAYREF} = [qw( syndicator_started _parseline _sock_down _sock_failed _sock_up _socks_proxy_connect _socks_proxy_response debug connect _resolve_addresses _do_connect _quit_timeout _send_login _got_dns_response ison kick remove nickserv shutdown sl sl_login sl_high sl_delayed sl_prioritized topic userhost )]; return; } # BINGOS: the component can now configure itself via _configure() from # either spawn() or connect() ## no critic (Subroutines::ProhibitExcessComplexity) sub _configure { my ($self, $args) = @_; my $spawned = 0; if (ref $args eq 'HASH' && keys %{ $args }) { $spawned = delete $args->{spawned}; $self->{use_localaddr} = delete $args->{localaddr}; @{ $self }{ keys %{ $args } } = values %{ $args }; } if ($ENV{POCOIRC_DEBUG}) { $self->{debug} = 1; $self->{plugin_debug} = 1; } if ($self->{debug}) { $self->{ircd_filter}->debug(1); $self->{ircd_compat}->debug(1); } if ($self->{useipv6} && !$GOT_SOCKET6) { warn "'useipv6' option specified, but Socket6 was not found\n"; } if ($self->{usessl} && !$GOT_SSL) { warn "'usessl' option specified, but POE::Component::SSLify was not found\n"; } $self->{dcc}->nataddr($self->{nataddr}) if exists $self->{nataddr}; $self->{dcc}->dccports($self->{dccports}) if exists $self->{dccports}; $self->{port} = 6667 if !$self->{port}; $self->{msg_length} = 450 if !defined $self->{msg_length}; if ($self->{use_localaddr}) { $self->{localaddr} = $self->{use_localaddr} . ($self->{localport} ? (':'.$self->{localport}) : ''); } # Make sure that we have reasonable defaults for all the attributes. # The "IRC*" variables are ircII environment variables. if (!defined $self->{nick}) { $self->{nick} = $ENV{IRCNICK} || eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || 'WankerBot'; } if (!defined $self->{username}) { $self->{username} = eval { scalar getpwuid($>) } || $ENV{USER} || $ENV{LOGNAME} || 'foolio'; } if (!defined $self->{ircname}) { $self->{ircname} = $ENV{IRCNAME} || eval { (getpwuid $>)[6] } || 'Just Another Perl Hacker'; } if (!defined $self->{server} && !$spawned) { die "No IRC server specified\n" if !$ENV{IRCSERVER}; $self->{server} = $ENV{IRCSERVER}; } if (defined $self->{webirc}) { if (!ref $self->{webirc} ne 'HASH') { die "webirc param expects a hashref"; } for my $expect_key (qw(pass user host ip)) { if (!exists $self->{webirc}{$expect_key}) { die "webirc value is missing key '$expect_key'"; } } } return; } sub debug { my ($self, $switch) = @_[OBJECT, ARG0]; $self->{debug} = $switch; $self->{ircd_filter}->debug( $switch ); $self->{ircd_compat}->debug( $switch ); return; } # Parse a message from the IRC server and generate the appropriate # event(s) for listening sessions. sub _parseline { my ($session, $self, $ev) = @_[SESSION, OBJECT, ARG0]; return if !$ev->{name}; $self->send_event(irc_raw => $ev->{raw_line} ) if $self->{raw}; # record our nickname if ( $ev->{name} eq '001' ) { $self->{INFO}{RealNick} = ( split / /, $ev->{raw_line} )[2]; } $ev->{name} = 'irc_' . $ev->{name}; $self->send_event( $ev->{name}, @{$ev->{args}} ); if ($ev->{name} =~ /^irc_ctcp_(.+)$/) { $self->send_event(irc_ctcp => $1 => @{$ev->{args}}); } return; } # Internal function called when a socket is closed. sub _sock_down { my ($kernel, $self) = @_[KERNEL, OBJECT]; # Destroy the RW wheel for the socket. delete $self->{socket}; delete $self->{localaddr}; $self->{connected} = 0; # Stop any delayed sends. $self->{send_queue} = [ ]; $self->{send_time} = 0; $kernel->delay( sl_delayed => undef ); # Reset the filters if necessary $self->_compress_uplink( 0 ); $self->_compress_downlink( 0 ); $self->{ircd_compat}->chantypes( [ '#', '&' ] ); $self->{ircd_compat}->identifymsg(0); # post a 'irc_disconnected' to each session that cares $self->send_event(irc_disconnected => $self->{server} ); return; } sub disconnect { my ($self) = @_; $self->yield('_sock_down'); return; } # Internal function called when a socket fails to be properly opened. sub _sock_failed { my ($self, $op, $errno, $errstr) = @_[OBJECT, ARG0..ARG2]; delete $self->{socketfactory}; $self->send_event(irc_socketerr => "$op error $errno: $errstr" ); return; } # Internal function called when a connection is established. sub _sock_up { my ($kernel, $self, $session, $socket) = @_[KERNEL, OBJECT, SESSION, ARG0]; # We no longer need the SocketFactory wheel. Scrap it. delete $self->{socketfactory}; # Remember what IP address we're connected through, for multihomed boxes. my $localaddr; if ($GOT_SOCKET6) { eval { $localaddr = (unpack_sockaddr_in6( getsockname $socket ))[1]; $localaddr = inet_ntop( AF_INET6, $localaddr ); }; } if ( !$localaddr ) { $localaddr = (unpack_sockaddr_in( getsockname $socket ))[1]; $localaddr = inet_ntoa($localaddr); } $self->{localaddr} = $localaddr; if ( $self->{socks_proxy} ) { $self->{socket} = POE::Wheel::ReadWrite->new( Handle => $socket, Driver => POE::Driver::SysRW->new(), Filter => POE::Filter::Stream->new(), InputEvent => '_socks_proxy_response', ErrorEvent => '_sock_down', ); if ( !$self->{socket} ) { $self->send_event(irc_socketerr => "Couldn't create ReadWrite wheel for SOCKS socket" ); return; } my $packet; if ( _ip_is_ipv4( $self->{server} ) ) { # SOCKS 4 $packet = pack ('CCn', 4, 1, $self->{port}) . inet_aton($self->{server}) . ($self->{socks_id} || '') . (pack 'x'); } else { # SOCKS 4a $packet = pack ('CCn', 4, 1, $self->{port}) . inet_aton('0.0.0.1') . ($self->{socks_id} || '') . (pack 'x') . $self->{server} . (pack 'x'); } $self->{socket}->put( $packet ); return; } # ssl! if ($GOT_SSL and $self->{usessl}) { eval { my ($ctx); if( $self->{sslctx} ) { $ctx = $self->{sslctx}; } elsif( $self->{sslkey} && $self->{sslcert} ) { $ctx = SSLify_ContextCreate( $self->{sslkey}, $self->{sslcert} ); } else { $ctx = undef; } $socket = Client_SSLify($socket, undef, undef, $ctx); }; if ($@) { chomp $@; warn "Couldn't use an SSL socket: $@\n"; $self->{usessl} = 0; } } if ( $self->{compress} ) { $self->_compress_uplink(1); $self->_compress_downlink(1); } # Create a new ReadWrite wheel for the connected socket. $self->{socket} = POE::Wheel::ReadWrite->new( Handle => $socket, Driver => POE::Driver::SysRW->new(), InputFilter => $self->{srv_filter}, OutputFilter => $self->{out_filter}, InputEvent => '_parseline', ErrorEvent => '_sock_down', ); if ($self->{socket}) { $self->{connected} = 1; } else { $self->send_event(irc_socketerr => "Couldn't create ReadWrite wheel for IRC socket"); return; } # Post a 'irc_connected' event to each session that cares $self->send_event(irc_connected => $self->{server} ); # CONNECT if we're using a proxy if ($self->{proxy}) { # The original proxy code, AFAIK, did not actually work # with an HTTP proxy. $self->call( 'sl_login', 'CONNECT ' . $self->{server} . ':' . $self->{port} . " HTTP/1.0\n\n", ); # KLUDGE: Also, the original proxy code assumes the connection # is instantaneous Since this is not always the case, mess with # the queueing so that the sent text is delayed... $self->{send_time} = time() + 10; } $kernel->yield('_send_login'); return; } sub _socks_proxy_response { my ($kernel, $self, $session, $input) = @_[KERNEL, OBJECT, SESSION, ARG0]; if (length $input != 8) { $self->send_event( 'irc_socks_failed', 'Mangled response from SOCKS proxy', $input, ); $self->disconnect(); return; } my @resp = unpack 'CCnN', $input; if (@resp != 4 || $resp[0] ne '0' || $resp[1] !~ /^(?:90|91|92|93)$/) { $self->send_event( 'irc_socks_failed', 'Mangled response from SOCKS proxy', $input, ); $self->disconnect(); return; } if ( $resp[1] eq '90' ) { $kernel->call($session => '_socks_proxy_connect'); $self->{connected} = 1; $self->send_event( 'irc_connected', $self->{server} ); $kernel->yield('_send_login'); } else { $self->send_event( 'irc_socks_rejected', $resp[1], $self->{socks_proxy}, $self->{socks_port}, $self->{socks_id}, ); $self->disconnect(); } return; } sub _socks_proxy_connect { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->{socket}->event( InputEvent => '_parseline' ); $self->{socket}->set_input_filter( $self->{srv_filter} ); $self->{socket}->set_output_filter( $self->{out_filter} ); return; } sub _send_login { my ($kernel, $self, $session) = @_[KERNEL, OBJECT, SESSION]; # Now that we're connected, attempt to log into the server. # for servers which support CAP, it's customary to start with that $kernel->call($session, 'sl_login', 'CAP REQ :identify-msg'); $kernel->call($session, 'sl_login', 'CAP REQ :multi-prefix'); $kernel->call($session, 'sl_login', 'CAP LS'); $kernel->call($session, 'sl_login', 'CAP END'); # If we were told to use WEBIRC to spoof our host/IP, do so: if (defined $self->{webirc}) { $kernel->call($session => sl_login => 'WEBIRC ' . join " ", @{$self->{webirc}}{qw(pass user ip host)} ); } if (defined $self->{password}) { $kernel->call($session => sl_login => 'PASS ' . $self->{password}); } $kernel->call($session => sl_login => 'NICK ' . $self->{nick}); $kernel->call( $session, 'sl_login', 'USER ' . join(' ', $self->{username}, (defined $self->{bitmode} ? $self->{bitmode} : 8), '*', ':' . $self->{ircname} ), ); # If we have queued data waiting, its flush loop has stopped # while we were disconnected. Start that up again. $kernel->delay(sl_delayed => 0); return; } # Set up the component's IRC session. sub syndicator_started { my ($kernel, $session, $sender, $self, $alias) = @_[KERNEL, SESSION, SENDER, OBJECT, ARG0, ARG1 .. $#_]; # Send queue is used to hold pending lines so we don't flood off. # The count is used to track the number of lines sent at any time. $self->{send_queue} = [ ]; $self->{send_time} = 0; $self->{ircd_filter} = POE::Filter::IRCD->new(debug => $self->{debug}); $self->{ircd_compat} = POE::Filter::IRC::Compat->new(debug => $self->{debug}); my $srv_filters = [ POE::Filter::Line->new( InputRegexp => '\015?\012', OutputLiteral => '\015\012', ), $self->{ircd_filter}, $self->{ircd_compat}, ]; $self->{srv_filter} = POE::Filter::Stackable->new(Filters => $srv_filters); $self->{out_filter} = POE::Filter::Stackable->new(Filters => [ POE::Filter::Line->new( OutputLiteral => "\015\012" ), ]); # Plugin 'irc_whois' and 'irc_whowas' support $self->plugin_add('Whois_' . $self->session_id(), POE::Component::IRC::Plugin::Whois->new() ); $self->{isupport} = POE::Component::IRC::Plugin::ISupport->new(); $self->plugin_add('ISupport_' . $self->session_id(), $self->{isupport}); $self->{dcc} = POE::Component::IRC::Plugin::DCC->new(); $self->plugin_add('DCC_' . $self->session_id(), $self->{dcc}); return 1; } # The handler for commands which have N arguments, separated by commas. sub commasep { my ($kernel, $self, $state, @args) = @_[KERNEL, OBJECT, STATE, ARG0 .. $#_]; my $args; if ($state eq 'whois' and @args > 1 ) { $args = shift @args; $args .= ' ' . join ',', @args; } elsif ( $state eq 'part' and @args > 1 ) { my $chantypes = join('', @{ $self->isupport('CHANTYPES') || ['#', '&']}); my $message; if ($args[-1] =~ / +/ || $args[-1] !~ /^[$chantypes]/) { $message = pop @args; } $args = join(',', @args); $args .= " :$message" if defined $message; } else { $args = join ',', @args; } my $pri = $self->{IRC_CMDS}->{$state}->[CMD_PRI]; $state = uc $state; $state .= " $args" if defined $args; $kernel->yield(sl_prioritized => $pri, $state ); return; } # Get variables in order for openning a connection sub connect { my ($kernel, $self, $session, $sender, $args) = @_[KERNEL, OBJECT, SESSION, SENDER, ARG0]; if ($args) { my %arg; %arg = @{ $args } if ref $args eq 'ARRAY'; %arg = %{ $args } if ref $args eq 'HASH'; $arg{ lc $_ } = delete $arg{$_} for keys %arg; $self->_configure( \%arg ); } if ( $self->{resolver} && $self->{res_addresses} && @{ $self->{res_addresses} } ) { push @{ $self->{res_addresses} }, $self->{server}; $self->{resolved_server} = shift @{ $self->{res_addresses} }; } # try and use non-blocking resolver if needed if ( $self->{resolver} && !_ip_get_version( $self->{server} ) && !$self->{nodns} ) { $kernel->yield( '_resolve_addresses', $self->{server}, ( $self->{useipv6} && $GOT_SOCKET6 ? 'AAAA' : 'A' ), ); } else { $kernel->yield('_do_connect'); } $self->{INFO}{RealNick} = $self->{nick}; return; } sub _resolve_addresses { my ($kernel, $self, $hostname, $type) = @_[KERNEL, OBJECT, ARG0 .. ARG1]; my $response = $self->{resolver}->resolve( event => '_got_dns_response', host => $hostname, type => $type, context => { }, ); $kernel->yield(_got_dns_response => $response) if $response; return; } # open the connection sub _do_connect { my ($kernel, $self, $session) = @_[KERNEL, OBJECT, SESSION]; my $domain = AF_INET; # Disconnect if we're already logged into a server. $kernel->call($session => 'quit') if $self->{socket}; if ($self->{socks_proxy} && !$self->{socks_port}) { $self->{socks_port} = 1080; } for my $address (qw(socks_proxy proxy server resolved_server use_localaddr)) { next if !$self->{$address} || !_ip_is_ipv6( $self->{$address} ); if (!$GOT_SOCKET6) { warn "IPv6 address specified for '$address' but Socket6 not found\n"; return; } $domain = AF_INET6; } $self->{socketfactory} = POE::Wheel::SocketFactory->new( SocketDomain => $domain, SocketType => SOCK_STREAM, SocketProtocol => 'tcp', RemoteAddress => $self->{socks_proxy} || $self->{proxy} || $self->{resolved_server} || $self->{server}, RemotePort => $self->{socks_port} || $self->{proxyport} || $self->{port}, SuccessEvent => '_sock_up', FailureEvent => '_sock_failed', ($self->{use_localaddr} ? (BindAddress => $self->{use_localaddr}) : ()), ); return; } # got response from POE::Component::Client::DNS sub _got_dns_response { my ($kernel, $self, $response) = @_[KERNEL, OBJECT, ARG0]; my $type = uc $response->{type}; my $net_dns_packet = $response->{response}; my $net_dns_errorstring = $response->{error}; $self->{res_addresses} = [ ]; if (!defined $net_dns_packet) { $self->send_event(irc_socketerr => $net_dns_errorstring ); return; } my @net_dns_answers = $net_dns_packet->answer; for my $net_dns_answer (@net_dns_answers) { next if $net_dns_answer->type !~ /^A/; push @{ $self->{res_addresses} }, $net_dns_answer->rdatastr; } if ( !@{ $self->{res_addresses} } && $type eq 'AAAA') { $kernel->yield(_resolve_addresses => $self->{server}, 'A'); return; } if ( !@{ $self->{res_addresses} } ) { $self->send_event(irc_socketerr => 'Unable to resolve ' . $self->{server}); return; } if ( my $address = shift @{ $self->{res_addresses} } ) { $self->{resolved_server} = $address; $kernel->yield('_do_connect'); return; } $self->send_event(irc_socketerr => 'Unable to resolve ' . $self->{server}); return; } # Send a CTCP query or reply, with the same syntax as a PRIVMSG event. sub ctcp { my ($kernel, $state, $self, $to) = @_[KERNEL, STATE, OBJECT, ARG0]; my $message = join ' ', @_[ARG1 .. $#_]; if (!defined $to || !defined $message) { warn "The '$state' event requires two arguments\n"; return; } # CTCP-quote the message text. ($message) = @{$self->{ircd_compat}->put([ $message ])}; # Should we send this as a CTCP request or reply? $state = $state eq 'ctcpreply' ? 'notice' : 'privmsg'; $kernel->yield($state, $to, $message); return; } # The way /notify is implemented in IRC clients. sub ison { my ($kernel, @nicks) = @_[KERNEL, ARG0 .. $#_]; my $tmp = 'ISON'; if (!@nicks) { warn "The 'ison' event requires one or more nicknames\n"; return; } # We can pass as many nicks as we want, as long as it's shorter than # the maximum command length (510). If the list we get is too long, # w'll break it into multiple ISON commands. while (@nicks) { my $nick = shift @nicks; if (length($tmp) + length($nick) >= 509) { $kernel->yield(sl_high => $tmp); $tmp = 'ISON'; } $tmp .= " $nick"; } $kernel->yield(sl_high => $tmp); return; } # Tell the IRC server to forcibly remove a user from a channel. sub kick { my ($kernel, $chan, $nick) = @_[KERNEL, ARG0, ARG1]; my $message = join '', @_[ARG2 .. $#_]; if (!defined $chan || !defined $nick) { warn "The 'kick' event requires at least two arguments\n"; return; } $nick .= " :$message" if defined $message; $kernel->yield(sl_high => "KICK $chan $nick"); return; } # Tell the IRC server to forcibly remove a user from a channel. Freenode extension sub remove { my ($kernel, $chan, $nick) = @_[KERNEL, ARG0, ARG1]; my $message = join '', @_[ARG2 .. $#_]; if (!defined $chan || !defined $nick) { warn "The 'remove' event requires at least two arguments\n"; return; } $nick .= " :$message" if defined $message; $kernel->yield(sl_high => "REMOVE $chan $nick"); return; } # Interact with NickServ sub nickserv { my ($kernel, $self, $state) = @_[KERNEL, OBJECT, STATE]; my $args = join ' ', @_[ARG0 .. $#_]; my $command = 'NICKSERV'; my $version = $self->server_version(); $command = 'NS' if defined $version && $version =~ /ratbox/i; $command .= " $args" if defined $args; $kernel->yield(sl_high => $command); return; } # Set up a new IRC component. Deprecated. sub new { my ($package, $alias) = splice @_, 0, 2; croak "$package options should be an even-sized list" if @_ & 1; my %options = @_; if (!defined $alias) { croak 'Not enough arguments to POE::Component::IRC::new()'; } carp "Use of ${package}->new() is deprecated, please use spawn()"; my $self = $package->spawn ( alias => $alias, options => \%options ); return $self; } # Set up a new IRC component. New interface. sub spawn { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %params = @_; $params{ lc $_ } = delete $params{$_} for keys %params; delete $params{options} if ref $params{options} ne 'HASH'; my $self = bless { }, $package; $self->_create(); if ($ENV{POCOIRC_DEBUG}) { $params{debug} = 1; $params{plugin_debug} = 1; } my $options = delete $params{options}; my $alias = delete $params{alias}; my $plugin_debug = delete $params{plugin_debug}; $self->_syndicator_init( prefix => 'irc_', reg_prefix => 'PCI_', types => [SERVER => 'S', USER => 'U'], alias => $alias, register_signal => 'POCOIRC_REGISTER', shutdown_signal => 'POCOIRC_SHUTDOWN', object_states => [ $self => delete $self->{OBJECT_STATES_HASHREF}, $self => delete $self->{OBJECT_STATES_ARRAYREF}, ], ($plugin_debug ? (debug => 1) : () ), (ref $options eq 'HASH' ? ( options => $options ) : ()), ); $params{spawned} = 1; $self->_configure(\%params); if (!$params{nodns} && $GOT_CLIENT_DNS && !$self->{resolver}) { $self->{resolver} = POE::Component::Client::DNS->spawn( Alias => 'resolver' . $self->session_id() ); $self->{mydns} = 1; } return $self; } # The handler for all IRC commands that take no arguments. sub noargs { my ($kernel, $state, $arg) = @_[KERNEL, STATE, ARG0]; my $pri = $_[OBJECT]->{IRC_CMDS}->{$state}->[CMD_PRI]; if (defined $arg) { warn "The '$state' event takes no arguments\n"; return; } $state = uc $state; $kernel->yield(sl_prioritized => $pri, $state); return; } # The handler for commands that take one required and two optional arguments. sub oneandtwoopt { my ($kernel, $state) = @_[KERNEL, STATE]; my $arg = join '', @_[ARG0 .. $#_]; my $pri = $_[OBJECT]->{IRC_CMDS}->{$state}->[CMD_PRI]; $state = 'connect' if $state eq 'sconnect'; $state = uc $state; if (defined $arg) { $arg = ':' . $arg if $arg =~ /\x20/; $state .= " $arg"; } $kernel->yield(sl_prioritized => $pri, $state); return; } # The handler for commands that take at least one optional argument. sub oneoptarg { my ($kernel, $state) = @_[KERNEL, STATE]; my $pri = $_[OBJECT]->{IRC_CMDS}->{$state}->[CMD_PRI]; $state = uc $state; if (defined $_[ARG0]) { my $arg = join '', @_[ARG0 .. $#_]; $arg = ':' . $arg if $arg =~ /\x20/; $state .= " $arg"; } $kernel->yield(sl_prioritized => $pri, $state); return; } # The handler for commands which take one required and one optional argument. sub oneortwo { my ($kernel, $state, $one) = @_[KERNEL, STATE, ARG0]; my $two = join '', @_[ARG1 .. $#_]; my $pri = $_[OBJECT]->{IRC_CMDS}->{$state}->[CMD_PRI]; if (!defined $one) { warn "The '$state' event requires at least one argument\n"; return; } $state = uc( $state ) . " $one"; $state .= " $two" if defined $two; $kernel->yield(sl_prioritized => $pri, $state); return; } # Handler for commands that take exactly one argument. sub onlyonearg { my ($kernel, $state) = @_[KERNEL, STATE]; my $arg = join '', @_[ARG0 .. $#_]; my $pri = $_[OBJECT]->{IRC_CMDS}->{$state}->[CMD_PRI]; if (!defined $arg) { warn "The '$state' event requires one argument\n"; return; } $state = uc $state; $arg = ':' . $arg if $arg =~ /\x20/; $state .= " $arg"; $kernel->yield(sl_prioritized => $pri, $state); return; } # Handler for commands that take exactly two arguments. sub onlytwoargs { my ($kernel, $state, $one) = @_[KERNEL, STATE, ARG0]; my ($two) = join '', @_[ARG1 .. $#_]; my $pri = $_[OBJECT]->{IRC_CMDS}->{$state}->[CMD_PRI]; if (!defined $one || !defined $two) { warn "The '$state' event requires two arguments\n"; return; } $state = uc $state; $two = ':' . $two if $two =~ /\x20/; $state .= " $one $two"; $kernel->yield(sl_prioritized => $pri, $state); return; } # Handler for privmsg or notice events. sub privandnotice { my ($kernel, $state, $to, $msg) = @_[KERNEL, STATE, ARG0, ARG1]; my $pri = $_[OBJECT]->{IRC_CMDS}->{$state}->[CMD_PRI]; $state =~ s/privmsglo/privmsg/; $state =~ s/privmsghi/privmsg/; $state =~ s/noticelo/notice/; $state =~ s/noticehi/notice/; if (!defined $to || !defined $msg) { warn "The '$state' event requires two arguments\n"; return; } $to = join ',', @$to if ref $to eq 'ARRAY'; $state = uc $state; $kernel->yield(sl_prioritized => $pri, "$state $to :$msg"); return; } # Tell the IRC session to go away. sub shutdown { my ($kernel, $self, $sender, $session) = @_[KERNEL, OBJECT, SENDER, SESSION]; return if $self->{_shutdown}; $self->{_shutdown} = $sender->ID(); if ($self->logged_in()) { my ($msg, $timeout) = @_[ARG0, ARG1]; $msg = '' if !defined $msg; $timeout = 5 if !defined $timeout; $msg = ":$msg" if $msg =~ /\x20/; my $cmd = "QUIT $msg"; $kernel->call($session => sl_high => $cmd); $kernel->delay('_quit_timeout', $timeout); $self->{_waiting} = 1; } elsif ($self->connected()) { $self->disconnect(); } else { $self->_shutdown(); } return; } sub _quit_timeout { my ($self) = $_[OBJECT]; $self->disconnect(); return; } sub _shutdown { my ($self) = @_; $self->_syndicator_destroy($self->{_shutdown}); delete $self->{$_} for qw(socketfactory dcc wheelmap); $self->{resolver}->shutdown() if $self->{resolver} && $self->{mydns}; return; } # Send a line of login-priority IRC output. These are things which # must go first. sub sl_login { my ($kernel, $self) = @_[KERNEL, OBJECT]; my $arg = join ' ', @_[ARG0 .. $#_]; $kernel->yield(sl_prioritized => PRI_LOGIN, $arg ); return; } # Send a line of high-priority IRC output. Things like channel/user # modes, kick messages, and whatever. sub sl_high { my ($kernel, $self) = @_[KERNEL, OBJECT]; my $arg = join ' ', @_[ARG0 .. $#_]; $kernel->yield(sl_prioritized => PRI_HIGH, $arg ); return; } # Send a line of normal-priority IRC output to the server. PRIVMSG # and other random chatter. Uses sl() for compatibility with existing # code. sub sl { my ($kernel, $self) = @_[KERNEL, OBJECT]; my $arg = join ' ', @_[ARG0 .. $#_]; $kernel->yield(sl_prioritized => PRI_NORMAL, $arg ); return; } # Prioritized sl(). This keeps the queue ordered by priority, low to # high in the UNIX tradition. It also throttles transmission # following the hybrid ircd's algorithm, so you can't accidentally # flood yourself off. Thanks to Raistlin for explaining how ircd # throttles messages. sub sl_prioritized { my ($kernel, $self, $priority, @args) = @_[KERNEL, OBJECT, ARG0, ARG1]; if (my ($event) = $args[0] =~ /^(\w+)/ ) { # Let the plugin system process this return 1 if $self->send_user_event($event, \@args) == PCI_EAT_ALL; } else { warn "Unable to extract the event name from '$args[0]'\n"; } my $msg = $args[0]; my $now = time(); $self->{send_time} = $now if $self->{send_time} < $now; # if we find a newline in the message, take that to be the end of it $msg =~ s/[\015\012].*//s; if (bytes::length($msg) > $self->{msg_length} - bytes::length($self->nick_name())) { $msg = bytes::substr($msg, 0, $self->{msg_length} - bytes::length($self->nick_name())); } if (@{ $self->{send_queue} }) { my $i = @{ $self->{send_queue} }; $i-- while ($i && $priority < $self->{send_queue}->[$i-1]->[MSG_PRI]); splice( @{ $self->{send_queue} }, $i, 0, [ $priority, $msg ] ); } elsif ( !$self->{flood} && $self->{send_time} - $now >= 10 || !defined $self->{socket} ) { push( @{$self->{send_queue}}, [ $priority, $msg ] ); $kernel->delay( sl_delayed => $self->{send_time} - $now - 10 ); } else { warn ">>> $msg\n" if $self->{debug}; $self->send_event(irc_raw_out => $msg) if $self->{raw}; $self->{send_time} += 2 + length($msg) / 120; $self->{socket}->put($msg); } return; } # Send delayed lines to the ircd. We manage a virtual "send time" # that progresses into the future based on hybrid ircd's rules every # time a message is sent. Once we find it ten or more seconds into # the future, we wait for the realtime clock to catch up. sub sl_delayed { my ($kernel, $self) = @_[KERNEL, OBJECT]; return if !defined $self->{socket}; my $now = time(); $self->{send_time} = $now if $self->{send_time} < $now; while (@{ $self->{send_queue} } && ($self->{send_time} - $now < 10)) { my $arg = (shift @{$self->{send_queue}})->[MSG_TEXT]; warn ">>> $arg\n" if $self->{debug}; $self->send_event(irc_raw_out => $arg) if $self->{raw}; $self->{send_time} += 2 + length($arg) / 120; $self->{socket}->put($arg); } if (@{ $self->{send_queue} }) { $kernel->delay( sl_delayed => $self->{send_time} - $now - 10 ); } return; } # The handler for commands which have N arguments, separated by spaces. sub spacesep { my ($kernel, $state) = @_[KERNEL, STATE]; my $args = join ' ', @_[ARG0 .. $#_]; my $pri = $_[OBJECT]->{IRC_CMDS}->{$state}->[CMD_PRI]; $state = uc $state; $state .= " $args" if defined $args; $kernel->yield(sl_prioritized => $pri, $state ); return; } # Set or query the current topic on a channel. sub topic { my ($kernel, $chan, @args) = @_[KERNEL, ARG0..$#_]; my $topic; $topic = join '', @args if @args; if (defined $topic) { $chan .= " :"; $chan .= $topic if length $topic; } $kernel->yield(sl_prioritized => PRI_NORMAL, "TOPIC $chan"); return; } # Asks the IRC server for some random information about particular nicks. sub userhost { my ($kernel, @nicks) = @_[KERNEL, ARG0 .. $#_]; if (!@nicks) { warn "The 'userhost' event requires at least one nickname\n"; return; } # According to the RFC, you can only send 5 nicks at a time. while (@nicks) { $kernel->yield( 'sl_prioritized', PRI_HIGH, 'USERHOST ' . join(' ', splice(@nicks, 0, 5)), ); } return; } # Non-event methods sub server { my ($self) = @_; return $self->{server}; } sub port { my ($self) = @_; return $self->{port}; } sub server_name { my ($self) = @_; return $self->{INFO}{ServerName}; } sub server_version { my ($self) = @_; return $self->{INFO}{ServerVersion}; } sub localaddr { my ($self) = @_; return $self->{localaddr}; } sub nick_name { my ($self) = @_; return $self->{INFO}{RealNick}; } sub send_queue { my ($self) = @_; if (defined $self->{send_queue} && ref $self->{send_queue} eq 'ARRAY' ) { return scalar @{ $self->{send_queue} }; } return; } sub raw_events { my ($self, $value) = @_; return $self->{raw} if !defined $value; $self->{raw} = $value; return; } sub connected { my ($self) = @_; return $self->{connected}; } sub logged_in { my ($self) = @_; return 1 if $self->{INFO}{LoggedIn}; return; } sub _compress_uplink { my ($self, $value) = @_; return if !$GOT_ZLIB; return $self->{uplink} if !defined $value; if ($value) { $self->{out_filter}->unshift( POE::Filter::Zlib::Stream->new() ) if !$self->{uplink}; $self->{uplink} = 1; } else { $self->{out_filter}->shift() if $self->{uplink}; $self->{uplink} = 0; } return $self->{uplink}; } sub _compress_downlink { my ($self, $value) = @_; return if !$GOT_ZLIB; return $self->{downlink} if !defined $value; if ($value) { $self->{srv_filter}->unshift( POE::Filter::Zlib::Stream->new() ) if !$self->{downlink}; $self->{downlink} = 1; } else { $self->{srv_filter}->shift() if $self->{uplink}; $self->{downlink} = 0; } return $self->{downlink}; } sub S_001 { my ($self, $irc) = splice @_, 0, 2; $self->{INFO}{ServerName} = ${ $_[0] }; $self->{INFO}{LoggedIn} = 1; return PCI_EAT_NONE; } sub S_004 { my ($self, $irc) = splice @_, 0, 2; my $args = ${ $_[2] }; $self->{INFO}{ServerVersion} = $args->[1]; return PCI_EAT_NONE; } sub S_error { my ($self, $irc) = splice @_, 0, 2; $self->{INFO}{LoggedIn} = 0; return PCI_EAT_NONE; } sub S_disconnected { my ($self, $irc) = splice @_, 0, 2; $self->{INFO}{LoggedIn} = 0; if ($self->{_waiting}) { $poe_kernel->delay('_quit_timeout'); delete $self->{_waiting}; } $self->_shutdown() if $self->{_shutdown}; return PCI_EAT_NONE; } sub S_shutdown { my ($self, $irc) = splice @_, 0, 2; $self->{INFO}{LoggedIn} = 0; return PCI_EAT_NONE; } # Automatically replies to a PING from the server. Do not confuse this # with CTCP PINGs, which are a wholly different animal that evolved # much later on the technological timeline. sub S_ping { my ($self, $irc) = splice @_, 0, 2; my $arg = ${ $_[0] }; $irc->yield(sl_login => "PONG :$arg"); return PCI_EAT_NONE; } # NICK messages for the purposes of determining our current nickname sub S_nick { my ($self, $irc) = splice @_, 0, 2; my $nick = ( split /!/, ${ $_[0] } )[0]; my $new = ${ $_[1] }; $self->{INFO}{RealNick} = $new if ( $nick eq $self->{INFO}{RealNick} ); return PCI_EAT_NONE; } # tell POE::Filter::IRC::Compat to handle IDENTIFY-MSG sub S_290 { my ($self, $irc) = splice @_, 0, 2; my $text = ${ $_[1] }; $self->{ircd_compat}->identifymsg(1) if $text eq 'IDENTIFY-MSG'; return PCI_EAT_NONE; } sub S_cap { my ($self, $irc) = splice @_, 0, 2; my $cmd = ${ $_[0] }; if ($cmd eq 'ACK') { my $list = ${ $_[1] } eq '*' ? ${ $_[2] } : ${ $_[1] }; my @enabled = split / /, $list; if (grep { $_ =~ /^=?identify-msg$/ } @enabled) { $self->{ircd_compat}->identifymsg(1); } if (grep { $_ =~ /^-identify-msg$/ } @enabled) { $self->{ircd_compat}->identifymsg(0); } } return PCI_EAT_NONE; } sub S_isupport { my ($self, $irc) = splice @_, 0, 2; my $isupport = ${ $_[0] }; $self->{ircd_compat}->chantypes( $isupport->isupport('CHANTYPES') || [ '#', '&' ] ); $irc->yield(sl_login => 'CAPAB IDENTIFY-MSG') if $isupport->isupport('CAPAB'); $irc->yield(sl_login => 'PROTOCTL NAMESX') if $isupport->isupport('NAMESX'); $irc->yield(sl_login => 'PROTOCTL UHNAMES') if $isupport->isupport('UHNAMES'); return PCI_EAT_NONE; } # accesses the ISupport plugin sub isupport { my ($self, @args) = @_; return $self->{isupport}->isupport(@args); } sub isupport_dump_keys { return $_[0]->{isupport}->isupport_dump_keys(); } sub resolver { return $_[0]->{resolver}; } sub _ip_get_version { my ($ip) = @_; return if !defined $ip; # If the address does not contain any ':', maybe it's IPv4 return 4 if $ip !~ /:/ && _ip_is_ipv4($ip); # Is it IPv6 ? return 6 if _ip_is_ipv6($ip); return; } sub _ip_is_ipv4 { my ($ip) = @_; return if !defined $ip; # Check for invalid chars return if $ip !~ /^[\d\.]+$/; return if $ip =~ /^\./; return if $ip =~ /\.$/; # Single Numbers are considered to be IPv4 return 1 if $ip =~ /^(\d+)$/ && $1 < 256; # Count quads my $n = ($ip =~ tr/\./\./); # IPv4 must have from 1 to 4 quads return if $n <= 0 || $n > 4; # Check for empty quads return if $ip =~ /\.\./; for my $quad (split /\./, $ip) { # Check for invalid quads return if $quad < 0 || $quad >= 256; } return 1; } sub _ip_is_ipv6 { my ($ip) = @_; return if !defined $ip; # Count octets my $n = ($ip =~ tr/:/:/); return if ($n <= 0 || $n >= 8); # $k is a counter my $k; for my $octet (split /:/, $ip) { $k++; # Empty octet ? next if $octet eq ''; # Normal v6 octet ? next if $octet =~ /^[a-f\d]{1,4}$/i; # Last octet - is it IPv4 ? if ($k == $n + 1) { next if (ip_is_ipv4($octet)); } return; } # Does the IP address start with : ? return if $ip =~ m/^:[^:]/; # Does the IP address finish with : ? return if $ip =~ m/[^:]:$/; # Does the IP address have more than one '::' pattern ? return if $ip =~ s/:(?=:)//g > 1; return 1; } 1; =encoding utf8 =head1 NAME POE::Component::IRC - A fully event-driven IRC client module =head1 SYNOPSIS # A simple Rot13 'encryption' bot use strict; use warnings; use POE qw(Component::IRC); my $nickname = 'Flibble' . $$; my $ircname = 'Flibble the Sailor Bot'; my $server = 'irc.perl.org'; my @channels = ('#Blah', '#Foo', '#Bar'); # We create a new PoCo-IRC object my $irc = POE::Component::IRC->spawn( nick => $nickname, ircname => $ircname, server => $server, ) or die "Oh noooo! $!"; POE::Session->create( package_states => [ main => [ qw(_default _start irc_001 irc_public) ], ], heap => { irc => $irc }, ); $poe_kernel->run(); sub _start { my $heap = $_[HEAP]; # retrieve our component's object from the heap where we stashed it my $irc = $heap->{irc}; $irc->yield( register => 'all' ); $irc->yield( connect => { } ); return; } sub irc_001 { my $sender = $_[SENDER]; # Since this is an irc_* event, we can get the component's object by # accessing the heap of the sender. Then we register and connect to the # specified server. my $irc = $sender->get_heap(); print "Connected to ", $irc->server_name(), "\n"; # we join our channels $irc->yield( join => $_ ) for @channels; return; } sub irc_public { my ($sender, $who, $where, $what) = @_[SENDER, ARG0 .. ARG2]; my $nick = ( split /!/, $who )[0]; my $channel = $where->[0]; if ( my ($rot13) = $what =~ /^rot13 (.+)/ ) { $rot13 =~ tr[a-zA-Z][n-za-mN-ZA-M]; $irc->yield( privmsg => $channel => "$nick: $rot13" ); } return; } # We registered for all events, this will produce some debug info. sub _default { my ($event, $args) = @_[ARG0 .. $#_]; my @output = ( "$event: " ); for my $arg (@$args) { if ( ref $arg eq 'ARRAY' ) { push( @output, '[' . join(', ', @$arg ) . ']' ); } else { push ( @output, "'$arg'" ); } } print join ' ', @output, "\n"; return; } =head1 DESCRIPTION POE::Component::IRC is a POE component (who'd have guessed?) which acts as an easily controllable IRC client for your other POE components and sessions. You create an IRC component and tell it what events your session cares about and where to connect to, and it sends back interesting IRC events when they happen. You make the client do things by sending it events. That's all there is to it. Cool, no? [Note that using this module requires some familiarity with the details of the IRC protocol. I'd advise you to read up on the gory details of RFC 1459 (L) before you get started. Keep the list of server numeric codes handy while you program. Needless to say, you'll also need a good working knowledge of POE, or this document will be of very little use to you.] The POE::Component::IRC distribution has a F folder with a collection of salient documentation including the pertinent RFCs. POE::Component::IRC consists of a POE::Session that manages the IRC connection and dispatches C prefixed events to interested sessions and an object that can be used to access additional information using methods. Sessions register their interest in receiving C events by sending L|/register> to the component. One would usually do this in your C<_start> handler. Your session will continue to receive events until you L|/unregister>. The component will continue to stay around until you tell it not to with L|/shutdown>. The L demonstrates a fairly basic bot. See L for more examples. =head2 Useful subclasses Included with POE::Component::IRC are a number of useful subclasses. As they are subclasses they support all the methods, etc. documented here and have additional methods and quirks which are documented separately: =over 4 =item * L POE::Component::IRC::State provides all the functionality of POE::Component::IRC but also tracks IRC state entities such as nicks and channels. =item * L POE::Component::IRC::Qnet is POE::Component::IRC tweaked for use on Quakenet IRC network. =item * L POE::Component::IRC::Qnet::State is a tweaked version of POE::Component::IRC::State for use on the Quakenet IRC network. =back =head2 The Plugin system As of 3.7, PoCo-IRC sports a plugin system. The documentation for it can be read by looking at L. That is not a subclass, just a placeholder for documentation! A number of useful plugins have made their way into the core distribution: =over 4 =item * L Provides DCC support. Loaded by default. =item * L Keeps you on your favorite channels throughout reconnects and even kicks. =item * L Glues an irc bot to an IRC network, i.e. deals with maintaining ircd connections. =item * L Under normal circumstances irc bots do not normal the msgs and public msgs that they generate themselves. This plugin enables you to handle those events. =item * L Generates C / C / C events whenever your bot's name comes up in channel discussion. =item * L Provides an easy way to handle commands issued to your bot. =item * L See inside the component. See what events are being sent. Generate irc commands manually. A TCP based console. =item * L Follow the tail of an ever-growing file. =item * L Log public and private messages to disk. =item * L Identify with NickServ when needed. =item * L A lightweight IRC proxy/bouncer. =item * L Automagically generates replies to ctcp version, time and userinfo queries. =item * L An experimental Plugin Manager plugin. =item * L Automagically deals with your nickname being in use and reclaiming it. =item * L Cycles (parts and rejoins) channels if they become empty and opless, in order to gain ops. =back =head1 CONSTRUCTORS Both constructors return an object. The object is also available within 'irc_' event handlers by using C<< $_[SENDER]->get_heap() >>. See also L|/register> and L|/irc_registered>. =head2 C Takes a number of arguments, all of which are optional. All the options below may be supplied to the L|/connect> input event as well, except for B<'alias'>, B<'options'>, B<'NoDNS'>, B<'debug'>, and B<'plugin_debug'>. =over 4 =item * B<'alias'>, a name (kernel alias) that this instance will be known by; =item * B<'options'>, a hashref containing L options; =item * B<'Server'>, the server name; =item * B<'Port'>, the remote port number; =item * B<'Password'>, an optional password for restricted servers; =item * B<'Nick'>, your client's IRC nickname; =item * B<'Username'>, your client's username; =item * B<'Ircname'>, some cute comment or something. =item * B<'Bitmode'>, an integer representing your initial user modes set in the USER command. See RFC 2812. If you do not set this, C<8> (+i) will be used. =item * B<'UseSSL'>, set to some true value if you want to connect using SSL. =item * B<'SSLCert'>, set to a SSL Certificate(PAM encoded) to connect using a client cert =item * B<'SSLKey'>, set to a SSL Key(PAM encoded) to connect using a client cert =item * B<'SSLCtx'>, set to a SSL Context to configure the SSL Connection The B<'SSLCert'> and B<'SSLKey'> both need to be specified. The B<'SSLCtx'> takes precedence specified. =item * B<'Raw'>, set to some true value to enable the component to send L|/irc_raw> and L|/irc_raw_out> events. =item * B<'LocalAddr'>, which local IP address on a multihomed box to connect as; =item * B<'LocalPort'>, the local TCP port to open your socket on; =item * B<'NoDNS'>, set this to 1 to disable DNS lookups using PoCo-Client-DNS. (See note below). =item * B<'Flood'>, when true, it disables the component's flood protection algorithms, allowing it to send messages to an IRC server at full speed. Disconnects and k-lines are some common side effects of flooding IRC servers, so care should be used when enabling this option. Default is false. Two new attributes are B<'Proxy'> and B<'ProxyPort'> for sending your =item * B<'Proxy'>, IP address or server name of a proxy server to use. =item * B<'ProxyPort'>, which tcp port on the proxy to connect to. =item * B<'NATAddr'>, what other clients see as your IP address. =item * B<'DCCPorts'>, an arrayref containing tcp ports that can be used for DCC sends. =item * B<'Resolver'>, provide a L object for the component to use. =item * B<'msg_length'>, the maximum length of IRC messages, in bytes. Default is 450. The IRC component shortens all messages longer than this value minus the length of your current nickname. IRC only allows raw protocol lines messages that are 512 bytes or shorter, including the trailing "\r\n". This is most relevant to long PRIVMSGs. The IRC component can't be sure how long your user@host mask will be every time you send a message, considering that most networks mangle the 'user' part and some even replace the whole string (think FreeNode cloaks). If you have an unusually long user@host mask you might want to decrease this value if you're prone to sending long messages. Conversely, if you have an unusually short one, you can increase this value if you want to be able to send as long a message as possible. Be careful though, increase it too much and the IRC server might disconnect you with a "Request too long" message when you try to send a message that's too long. =item * B<'debug'>, if set to a true value causes the IRC component to print every message sent to and from the server, as well as print some warnings when it receives malformed messages. This option will be enabled if the C environment variable is set to a true value. =item * B<'plugin_debug'>, set to some true value to print plugin debug info, default 0. Plugins are processed inside an eval. When you enable this option, you will be notified when (and why) a plugin raises an exception. This option will be enabled if the C environment variable is set to a true value. =item * B<'socks_proxy'>, specify a SOCKS4/SOCKS4a proxy to use. =item * B<'socks_port'>, the SOCKS port to use, defaults to 1080 if not specified. =item * B<'socks_id'>, specify a SOCKS user_id. Default is none. =item * B<'useipv6'>, enable the use of IPv6 for connections. =item * B<'webirc'>, enable the use of WEBIRC to spoof host/IP. You must have a WEBIRC password set up on the IRC server/network (so will only work for servers which trust you to spoof the IP & host the connection is from) - value should be a hashref containing keys C, C, C and C. =back C will supply reasonable defaults for any of these attributes which are missing, so don't feel obliged to write them all out. If the component finds that L is installed it will use that to resolve the server name passed. Disable this behaviour if you like, by passing: C<< NoDNS => 1 >>. IRC traffic through a proxy server. B<'Proxy'>'s value should be the IP address or server name of the proxy. B<'ProxyPort'>'s value should be the port on the proxy to connect to. L|/connect> will default to using the I IRC server's port if you provide a proxy but omit the proxy's port. These are for HTTP Proxies. See B<'socks_proxy'> for SOCKS4 and SOCKS4a support. For those people who run bots behind firewalls and/or Network Address Translation there are two additional attributes for DCC. B<'DCCPorts'>, is an arrayref of ports to use when initiating DCC connections. B<'NATAddr'>, is the NAT'ed IP address that your bot is hidden behind, this is sent whenever you do DCC. SSL support requires L, as well as an IRC server that supports SSL connections. If you're missing POE::Component::SSLify, specifying B<'UseSSL'> will do nothing. The default is to not try to use SSL. B<'Resolver'>, requires a L object. Useful when spawning multiple poco-irc sessions, saves the overhead of multiple dns sessions. B<'NoDNS'> has different results depending on whether it is set with L|/spawn> or L|/connect>. Setting it with C, disables the creation of the POE::Component::Client::DNS completely. Setting it with L|/connect> on the other hand allows the PoCo-Client-DNS session to be spawned, but will disable any dns lookups using it. SOCKS4 proxy support is provided by B<'socks_proxy'>, B<'socks_port'> and B<'socks_id'> parameters. If something goes wrong with the SOCKS connection you should get a warning on STDERR. This is fairly experimental currently. IPv6 support is available for connecting to IPv6 enabled ircds (it won't work for DCC though). To enable it, specify B<'useipv6'>. Perl >=5.14 or L (for older Perls) is required. If you that and L installed and specify a hostname that resolves to an IPv6 address then IPv6 will be used. If you specify an ipv6 B<'localaddr'> then IPv6 will be used. =head2 C This method is deprecated. See the L|/spawn> method instead. The first argument should be a name (kernel alias) which this new connection will be known by. Optionally takes more arguments (see L|/spawn> as name/value pairs. Returns a POE::Component::IRC object. :) B Use of this method will generate a warning. There are currently no plans to make it die() >;] =head1 METHODS =head2 Information =head3 C Takes no arguments. Returns the server host we are currently connected to (or trying to connect to). =head3 C Takes no arguments. Returns the server port we are currently connected to (or trying to connect to). =head3 C Takes no arguments. Returns the name of the IRC server that the component is currently connected to. =head3 C Takes no arguments. Returns the IRC server version. =head3 C Takes no arguments. Returns a scalar containing the current nickname that the bot is using. =head3 C Takes no arguments. Returns the IP address being used. =head3 C The component provides anti-flood throttling. This method takes no arguments and returns a scalar representing the number of messages that are queued up waiting for dispatch to the irc server. =head3 C Takes no arguments. Returns true or false depending on whether the IRC component is logged into an IRC network. =head3 C Takes no arguments. Returns true or false depending on whether the component's socket is currently connected. =head3 C Takes no arguments. Terminates the socket connection disgracefully >;o] =head3 C Takes one argument, a server capability to query. Returns C on failure or a value representing the applicable capability. A full list of capabilities is available at L. =head3 C Takes no arguments, returns a list of the available server capabilities keys, which can be used with L|/isupport>. =head3 C Returns a reference to the L object that is internally created by the component. =head2 Events =head3 C I> Takes no arguments. Returns the ID of the component's session. Ideal for posting events to the component. $kernel->post($irc->session_id() => 'mode' => $channel => '+o' => $dude); =head3 C I> Takes no arguments. Returns the session alias that has been set through L|/spawn>'s B<'alias'> argument. =head3 C With no arguments, returns true or false depending on whether L|/irc_raw> and L|/irc_raw_out> events are being generated or not. Provide a true or false argument to enable or disable this feature accordingly. =head3 C I> This method provides an alternative object based means of posting events to the component. First argument is the event to post, following arguments are sent as arguments to the resultant post. $irc->yield(mode => $channel => '+o' => $dude); =head3 C I> This method provides an alternative object based means of calling events to the component. First argument is the event to call, following arguments are sent as arguments to the resultant call. $irc->call(mode => $channel => '+o' => $dude); =head3 C I> This method provides a way of posting delayed events to the component. The first argument is an arrayref consisting of the delayed command to post and any command arguments. The second argument is the time in seconds that one wishes to delay the command being posted. my $alarm_id = $irc->delay( [ mode => $channel => '+o' => $dude ], 60 ); Returns an alarm ID that can be used with L|/delay_remove> to cancel the delayed event. This will be undefined if something went wrong. =head3 C I> This method removes a previously scheduled delayed event from the component. Takes one argument, the C that was returned by a L|/delay> method call. my $arrayref = $irc->delay_remove( $alarm_id ); Returns an arrayref that was originally requested to be delayed. =head3 C I> Sends an event through the component's event handling system. These will get processed by plugins then by registered sessions. First argument is the event name, followed by any parameters for that event. =head3 C I> This sends an event right after the one that's currently being processed. Useful if you want to generate some event which is directly related to another event so you want them to appear together. This method can only be called when POE::Component::IRC is processing an event, e.g. from one of your event handlers. Takes the same arguments as L|/send_event>. =head3 C I> This will send an event to be processed immediately. This means that if an event is currently being processed and there are plugins or sessions which will receive it after you do, then an event sent with C will be received by those plugins/sessions I the current event. Takes the same arguments as L|/send_event>. =head2 Plugins =head3 C I> Returns the L object. =head3 C I> Accepts two arguments: The alias for the plugin The actual plugin object Any number of extra arguments The alias is there for the user to refer to it, as it is possible to have multiple plugins of the same kind active in one Object::Pluggable object. This method goes through the pipeline's C method, which will call C<< $plugin->plugin_register($pluggable, @args) >>. Returns the number of plugins now in the pipeline if plugin was initialized, C/an empty list if not. =head3 C I> Accepts the following arguments: The alias for the plugin or the plugin object itself Any number of extra arguments This method goes through the pipeline's C method, which will call C<< $plugin->plugin_unregister($pluggable, @args) >>. Returns the plugin object if the plugin was removed, C/an empty list if not. =head3 C I> Accepts the following arguments: The alias for the plugin This method goes through the pipeline's C method. Returns the plugin object if it was found, C/an empty list if not. =head3 C I> Takes no arguments. Returns a hashref of plugin objects, keyed on alias, or an empty list if there are no plugins loaded. =head3 C I> Takes no arguments. Returns an arrayref of plugin objects, in the order which they are encountered in the pipeline. =head3 C I> Accepts the following arguments: The plugin object The type of the hook (the hook types are specified with _pluggable_init()'s 'types') The event name[s] to watch The event names can be as many as possible, or an arrayref. They correspond to the prefixed events and naturally, arbitrary events too. You do not need to supply events with the prefix in front of them, just the names. It is possible to register for all events by specifying 'all' as an event. Returns 1 if everything checked out fine, C/an empty list if something is seriously wrong. =head3 C I> Accepts the following arguments: The plugin object The type of the hook (the hook types are specified with _pluggable_init()'s 'types') The event name[s] to unwatch The event names can be as many as possible, or an arrayref. They correspond to the prefixed events and naturally, arbitrary events too. You do not need to supply events with the prefix in front of them, just the names. It is possible to register for all events by specifying 'all' as an event. Returns 1 if all the event name[s] was unregistered, undef if some was not found. =head1 INPUT EVENTS How to talk to your new IRC component... here's the events we'll accept. These are events that are posted to the component, either via C<< $poe_kernel->post() >> or via the object method L|/yield>. So the following would be functionally equivalent: sub irc_001 { my ($kernel,$sender) = @_[KERNEL,SENDER]; my $irc = $sender->get_heap(); # obtain the poco's object $irc->yield( privmsg => 'foo' => 'Howdy!' ); $kernel->post( $sender => privmsg => 'foo' => 'Howdy!' ); $kernel->post( $irc->session_id() => privmsg => 'foo' => 'Howdy!' ); $kernel->post( $irc->session_alias() => privmsg => 'foo' => 'Howdy!' ); return; } =head2 Important Commands =head3 C I> Takes N arguments: a list of event names that your session wants to listen for, minus the C prefix. So, for instance, if you just want a bot that keeps track of which people are on a channel, you'll need to listen for JOINs, PARTs, QUITs, and KICKs to people on the channel you're in. You'd tell POE::Component::IRC that you want those events by saying this: $kernel->post('my client', 'register', qw(join part quit kick)); Then, whenever people enter or leave a channel your bot is on (forcibly or not), your session will receive events with names like L|/irc_join>, L|/irc_kick>, etc., which you can use to update a list of people on the channel. Registering for B<'all'> will cause it to send all IRC-related events to you; this is the easiest way to handle it. See the test script for an example. Registering will generate an L|/irc_registered> event that your session can trap. C is the components object. Useful if you want to bolt PoCo-IRC's new features such as Plugins into a bot coded to the older deprecated API. If you are using the new API, ignore this :) Registering with multiple component sessions can be tricky, especially if one wants to marry up sessions/objects, etc. Check the L section for an alternative method of registering with multiple poco-ircs. Starting with version 4.96, if you spawn the component from inside another POE session, the component will automatically register that session as wanting B<'all'> irc events. That session will receive an L|/irc_registered> event indicating that the component is up and ready to go. =head3 C I> Takes N arguments: a list of event names which you I want to receive. If you've previously done a L|/register> for a particular event which you no longer care about, this event will tell the IRC connection to stop sending them to you. (If you haven't, it just ignores you. No big deal.) If you have registered with 'all', attempting to unregister individual events such as 'mode', etc. will not work. This is a 'feature'. =head3 C Takes one argument: a hash reference of attributes for the new connection, see L|/spawn> for details. This event tells the IRC client to connect to a new/different server. If it has a connection already open, it'll close it gracefully before reconnecting. =head3 C and C Sends a CTCP query or response to the nick(s) or channel(s) which you specify. Takes 2 arguments: the nick or channel to send a message to (use an array reference here to specify multiple recipients), and the plain text of the message to send (the CTCP quoting will be handled for you). The "/me" command in popular IRC clients is actually a CTCP action. # Doing a /me $irc->yield(ctcp => $channel => 'ACTION dances.'); =head3 C Tells your IRC client to join a single channel of your choice. Takes at least one arg: the channel name (required) and the channel key (optional, for password-protected channels). =head3 C Tell the IRC server to forcibly evict a user from a particular channel. Takes at least 2 arguments: a channel name, the nick of the user to boot, and an optional witty message to show them as they sail out the door. =head3 C Tell the IRC server to forcibly evict a user from a particular channel. Takes at least 2 arguments: a channel name, the nick of the user to boot, and an optional witty message to show them as they sail out the door. Similar to KICK but does an enforced PART instead. Not supported by all servers. =head3 C Request a mode change on a particular channel or user. Takes at least one argument: the mode changes to effect, as a single string (e.g. "#mychan +sm-p+o"), and any number of optional operands to the mode changes (nicks, hostmasks, channel keys, whatever.) Or just pass them all as one big string and it'll still work, whatever. I regret that I haven't the patience now to write a detailed explanation, but serious IRC users know the details anyhow. =head3 C Allows you to change your nickname. Takes exactly one argument: the new username that you'd like to be known as. =head3 C Talks to NickServ, on networks which have it. Takes any number of arguments. =head3 C Sends a NOTICE message to the nick(s) or channel(s) which you specify. Takes 2 arguments: the nick or channel to send a notice to (use an array reference here to specify multiple recipients), and the text of the notice to send. =head3 C Tell your IRC client to leave the channels which you pass to it. Takes any number of arguments: channel names to depart from. If the last argument doesn't begin with a channel name identifier or contains a space character, it will be treated as a PART message and dealt with accordingly. =head3 C Sends a public or private message to the nick(s) or channel(s) which you specify. Takes 2 arguments: the nick or channel to send a message to (use an array reference here to specify multiple recipients), and the text of the message to send. Have a look at the constants in L if you would like to use formatting and color codes in your messages. $irc->yield('primvsg', '#mychannel', 'Hello there'); # same, but with a green Hello use IRC::Utils qw(GREEN NORMAL); $irc->yield('primvsg', '#mychannel', GREEN.'Hello'.NORMAL.' there'); =head3 C Tells the IRC server to disconnect you. Takes one optional argument: some clever, witty string that other users in your channels will see as you leave. You can expect to get an L|/irc_disconnected> event shortly after sending this. =head3 C By default, POE::Component::IRC sessions never go away. Even after they're disconnected, they're still sitting around in the background, waiting for you to call L|/connect> on them again to reconnect. (Whether this behavior is the Right Thing is doubtful, but I don't want to break backwards compatibility at this point.) You can send the IRC session a C event manually to make it delete itself. If you are logged into an IRC server, C first will send a quit message and wait to be disconnected. It will wait for up to 5 seconds before forcibly disconnecting from the IRC server. If you provide an argument, that will be used as the QUIT message. If you provide two arguments, the second one will be used as the timeout (in seconds). Terminating multiple components can be tricky. Check the L section for a method of shutting down multiple poco-ircs. =head3 C Retrieves or sets the topic for particular channel. If called with just the channel name as an argument, it will ask the server to return the current topic. If called with the channel name and a string, it will set the channel topic to that string. Supply an empty string to unset a channel topic. =head3 C Takes one argument: 0 to turn debugging off or 1 to turn debugging on. This flips the debugging flag in L, L, and POE::Component::IRC. This has the same effect as setting Debug in L|/spawn> or L|/connect>. =head2 Not-So-Important Commands =head3 C Asks your server who your friendly neighborhood server administrators are. If you prefer, you can pass it a server name to query, instead of asking the server you're currently on. =head3 C When sent with an argument (a message describig where you went), the server will note that you're now away from your machine or otherwise preoccupied, and pass your message along to anyone who tries to communicate with you. When sent without arguments, it tells the server that you're back and paying attention. =head3 C Used to query/enable/disable IRC protocol capabilities. Takes any number of arguments. =head3 C See the L (loaded by default) documentation for DCC-related commands. =head3 C Basically the same as the L|/version> command, except that the server is permitted to return any information about itself that it thinks is relevant. There's some nice, specific standards-writing for ya, eh? =head3 C Invites another user onto an invite-only channel. Takes 2 arguments: the nick of the user you wish to admit, and the name of the channel to invite them to. =head3 C Asks the IRC server which users out of a list of nicknames are currently online. Takes any number of arguments: a list of nicknames to query the IRC server about. =head3 C Asks the server for a list of servers connected to the IRC network. Takes two optional arguments, which I'm too lazy to document here, so all you would-be linklooker writers should probably go dig up the RFC. =head3 C Asks the server for a list of visible channels and their topics. Takes any number of optional arguments: names of channels to get topic information for. If called without any channel names, it'll list every visible channel on the IRC network. This is usually a really big list, so don't do this often. =head3 C Request the server's "Message of the Day", a document which typically contains stuff like the server's acceptable use policy and admin contact email addresses, et cetera. Normally you'll automatically receive this when you log into a server, but if you want it again, here's how to do it. If you'd like to get the MOTD for a server other than the one you're logged into, pass it the server's hostname as an argument; otherwise, no arguments. =head3 C Asks the server for a list of nicknames on particular channels. Takes any number of arguments: names of channels to get lists of users for. If called without any channel names, it'll tell you the nicks of everyone on the IRC network. This is a really big list, so don't do this much. =head3 C Sends a raw line of text to the server. Takes one argument: a string of a raw IRC command to send to the server. It is more optimal to use the events this module supplies instead of writing raw IRC commands yourself. =head3 C Returns some information about a server. Kinda complicated and not terribly commonly used, so look it up in the RFC if you're curious. Takes as many arguments as you please. =head3 C, an C event will be sent with B<'foo'> as C, and the rest as given below. It is not recommended that you register for both C and C events, since they will both be fired and presumably cause duplication. =head3 C C events are generated upon receipt of CTCP messages. For instance, receiving a CTCP PING request generates an C event, CTCP ACTION (produced by typing "/me" in most IRC clients) generates an C event, blah blah, so on and so forth. C is the nick!hostmask of the sender. C is the channel/recipient name(s). C is the text of the CTCP message. On servers supporting the IDENTIFY-MSG feature (e.g. FreeNode), CTCP ACTIONs will have C, which will be C<1> if the sender has identified with NickServ, C<0> otherwise. Note that DCCs are handled separately -- see the L. =head3 C C messages are just like C messages, described above, except that they're generated when a response to one of your CTCP queries comes back. They have the same arguments and such as C events. =head3 C The counterpart to L|/irc_connected>, sent whenever a socket connection to an IRC server closes down (whether intentionally or unintentionally). C is the server name. =head3 C You get this whenever the server sends you an ERROR message. Expect this to usually be accompanied by the sudden dropping of your connection. C is the server's explanation of the error. =head3 C Sent whenever someone joins a channel that you're on. C is the person's nick!hostmask. C is the channel name. =head3 C Sent whenever someone offers you an invitation to another channel. C is the person's nick!hostmask. C is the name of the channel they want you to join. =head3 C Sent whenever someone gets booted off a channel that you're on. C is the kicker's nick!hostmask. C is the channel name. C is the nick of the unfortunate kickee. C is the explanation string for the kick. =head3 C Sent whenever someone changes a channel mode in your presence, or when you change your own user mode. C is the nick!hostmask of that someone. C is the channel it affects (or your nick, if it's a user mode change). C is the mode string (i.e., "+o-b"). The rest of the args (C) are the operands to the mode string (nicks, hostmasks, channel keys, whatever). =head3 C Sent whenever you receive a PRIVMSG command that was addressed to you privately. C is the nick!hostmask of the sender. C is an array reference containing the nick(s) of the recipients. C is the text of the message. On servers supporting the IDENTIFY-MSG feature (e.g. FreeNode), there will be an additional argument, C, which will be C<1> if the sender has identified with NickServ, C<0> otherwise. =head3 C Sent whenever you, or someone around you, changes nicks. C is the nick!hostmask of the changer. C is the new nick that they changed to. =head3 C Sent whenever you receive a NOTICE command. C is the nick!hostmask of the sender. C is an array reference containing the nick(s) or channel name(s) of the recipients. C is the text of the NOTICE message. =head3 C Sent whenever someone leaves a channel that you're on. C is the person's nick!hostmask. C is the channel name. C is the part message. =head3 C Sent whenever you receive a PRIVMSG command that was sent to a channel. C is the nick!hostmask of the sender. C is an array reference containing the channel name(s) of the recipients. C is the text of the message. On servers supporting the IDENTIFY-MSG feature (e.g. FreeNode), there will be an additional argument, C, which will be C<1> if the sender has identified with NickServ, C<0> otherwise. =head3 C Sent whenever someone on a channel with you quits IRC (or gets KILLed). C is the nick!hostmask of the person in question. C is the clever, witty message they left behind on the way out. =head3 C Sent when a connection couldn't be established to the IRC server. C is probably some vague and/or misleading reason for what failed. =head3 C Sent when a channel topic is set or unset. C is the nick!hostmask of the sender. C is the channel affected. C will be either: a string if the topic is being set; or a zero-length string (i.e. '') if the topic is being unset. Note: replies to queries about what a channel topic *is* (i.e. TOPIC #channel), are returned as numerics, not with this event. =head3 C Sent in response to a WHOIS query. C is a hashref, with the following keys: =over 4 =item * B<'nick'>, the users nickname; =item * B<'user'>, the users username; =item * B<'host'>, their hostname; =item * B<'real'>, their real name; =item * B<'idle'>, their idle time in seconds; =item * B<'signon'>, the epoch time they signed on (will be undef if ircd does not support this); =item * B<'channels'>, an arrayref listing visible channels they are on, the channel is prefixed with '@','+','%' depending on whether they have +o +v or +h; =item * B<'server'>, their server (might not be useful on some networks); =item * B<'oper'>, whether they are an IRCop, contains the IRC operator string if they are, undef if they aren't. =item * B<'actually'>, some ircds report the user's actual ip address, that'll be here; =item * B<'identified'>. if the user has identified with NICKSERV (ircu, seven, Plexus) =item * B<'modes'>, a string describing the user's modes (Rizon) =back =head3 C Similar to the above, except some keys will be missing. =head3 C Enabled by passing C<< Raw => 1 >> to L|/spawn> or L|/connect>, or by calling L|/raw_events> with a true argument. C is the raw IRC string received by the component from the IRC server, before it has been mangled by filters and such like. =head3 C Enabled by passing C<< Raw => 1 >> to L|/spawn> or L|/connect>, or by calling L|/raw_events> with a true argument. C is the raw IRC string sent by the component to the the IRC server. =head3 C Emitted by the first event after an L|/All numeric events>, to indicate that isupport information has been gathered. C is the L object. =head3 C Emitted whenever we fail to connect successfully to a SOCKS server or the SOCKS server is not actually a SOCKS server. C will be some vague reason as to what went wrong. Hopefully. =head3 C Emitted whenever a SOCKS connection is rejected by a SOCKS server. C is the SOCKS code, C the SOCKS server address, C the SOCKS port and C the SOCKS user id (if defined). =head3 C I> Emitted whenever a new plugin is added to the pipeline. C is the plugin alias. C is the plugin object. =head3 C I> Emitted whenever a plugin is removed from the pipeline. C is the plugin alias. C is the plugin object. =head3 C I> Emitted when an error occurs while executing a plugin handler. C is the error message. C is the plugin alias. C is the plugin object. =head2 Somewhat Less Important Events =head3 C A reply from the server regarding protocol capabilities. C is the CAP subcommand (e.g. 'LS'). C is the result of the subcommand, unless this is a multi-part reply, in which case C is '*' and C contains the result. =head3 C See the L (loaded by default) documentation for DCC-related events. =head3 C An event sent whenever the server sends a PING query to the client. (Don't confuse this with a CTCP PING, which is another beast entirely. If unclear, read the RFC.) Note that POE::Component::IRC will automatically take care of sending the PONG response back to the server for you, although you can still register to catch the event for informational purposes. =head3 C A weird, non-RFC-compliant message from an IRC server. Usually sent during to you during an authentication phase right after you connect, while the server does a hostname lookup or similar tasks. C is the text of the server's message. C is the target, which could be B<'*'> or B<'AUTH'> or whatever. Servers vary as to whether these notices include a server name as the sender, or no sender at all. C is the sender, if any. =head3 C I> Emitted on a successful addition of a delayed event using the L|/delay> method. C will be the alarm_id which can be used later with L|/delay_remove>. Subsequent parameters are the arguments that were passed to L|/delay>. =head3 C I> Emitted when a delayed command is successfully removed. C will be the alarm_id that was removed. Subsequent parameters are the arguments that were passed to L|/delay>. =head2 All numeric events Most messages from IRC servers are identified only by three-digit numeric codes with undescriptive constant names like RPL_UMODEIS and ERR_NOTOPLEVEL. (Actually, the list of codes in the RFC is kind of out-of-date... the list in the back of Net::IRC::Event.pm is more complete, and different IRC networks have different and incompatible lists. Ack!) As an example, say you wanted to handle event 376 (RPL_ENDOFMOTD, which signals the end of the MOTD message). You'd register for '376', and listen for C events. Simple, no? C is the name of the server which sent the message. C is the text of the message. C is an array reference of the parsed message, so there is no need to parse C yourself. =head1 SIGNALS The component will handle a number of custom signals that you may send using L's C method. =head2 C I> Registering with multiple PoCo-IRC components has been a pita. Well, no more, using the power of L signals. If the component receives a C signal it'll register the requesting session and trigger an L|/irc_registered> event. From that event one can get all the information necessary such as the poco-irc object and the SENDER session to do whatever one needs to build a poco-irc dispatch table. The way the signal handler in PoCo-IRC is written also supports sending the C to multiple sessions simultaneously, by sending the signal to the POE Kernel itself. Pass the signal your session, session ID or alias, and the IRC events (as specified to L|/register>). To register with multiple PoCo-IRCs one can do the following in your session's _start handler: sub _start { my ($kernel, $session) = @_[KERNEL, SESSION]; # Registering with multiple pocoircs for 'all' IRC events $kernel->signal($kernel, 'POCOIRC_REGISTER', $session->ID(), 'all'); return: } Each poco-irc will send your session an L|/irc_registered> event: sub irc_registered { my ($kernel, $sender, $heap, $irc_object) = @_[KERNEL, SENDER, HEAP, ARG0]; # Get the poco-irc session ID my $sender_id = $sender->ID(); # Or it's alias my $poco_alias = $irc_object->session_alias(); # Store it in our heap maybe $heap->{irc_objects}->{ $sender_id } = $irc_object; # Make the poco connect $irc_object->yield(connect => { }); return; } =head2 C I> Telling multiple poco-ircs to shutdown was a pita as well. The same principle as with registering applies to shutdown too. Send a C to the POE Kernel to terminate all the active poco-ircs simultaneously. $poe_kernel->signal($poe_kernel, 'POCOIRC_SHUTDOWN'); Any additional parameters passed to the signal will become your quit messages on each IRC network. =head1 ENCODING This can be an issue. Take a look at L on it. =head1 BUGS A few have turned up in the past and they are sure to again. Please use L to report any. Alternatively, email the current maintainer. =head1 DEVELOPMENT You can find the latest source on github: L The project's developers usually hang out in the C<#poe> IRC channel on irc.perl.org. Do drop us a line. =head1 MAINTAINERS Chris C Williams Hinrik Ern SigurEsson =head1 AUTHOR Dennis Taylor. =head1 LICENCE Copyright (c) Dennis Taylor, Chris Williams and Hinrik Ern SigurEsson This module may be used, modified, and distributed under the same terms as Perl itself. Please see the license that came with your Perl distribution for details. =head1 MAD PROPS The maddest of mad props go out to Rocco "dngor" Caputo , for inventing something as mind-bogglingly cool as POE, and to Kevin "oznoid" Lenzo Elenzo@cs.cmu.eduE, for being the attentive parent of our precocious little infobot on #perl. Further props to a few of the studly bughunters who made this module not suck: Abys , Addi , ResDev , and Roderick . Woohoo! Kudos to Apocalypse, , for the plugin system and to Jeff 'japhy' Pinyan, , for Pipeline. Thanks to the merry band of POE pixies from #PoE @ irc.perl.org, including ( but not limited to ), ketas, ct, dec, integral, webfox, immute, perigrin, paulv, alias. IP functions are shamelessly 'borrowed' from L by Manuel Valente Check out the Changes file for further contributors. =head1 SEE ALSO RFC 1459 L L, L, L, Some good examples reside in the POE cookbook which has a whole section devoted to IRC programming L. The examples/ folder of this distribution. =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/0000755000175000017500000000000013153565114017546 5ustar bingosbingosPOE-Component-IRC-6.90/lib/POE/Component/IRC/Common.pm0000644000175000017500000000515613153565114021343 0ustar bingosbingospackage POE::Component::IRC::Common; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Common::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use IRC::Utils; require Exporter; use base qw(Exporter); our @EXPORT_OK = qw( u_irc l_irc parse_mode_line parse_ban_mask matches_mask matches_mask_array parse_user has_color has_formatting strip_color strip_formatting NORMAL BOLD UNDERLINE REVERSE WHITE BLACK DARK_BLUE DARK_GREEN RED BROWN PURPLE ORANGE YELLOW LIGHT_GREEN TEAL CYAN LIGHT_BLUE MAGENTA DARK_GREY LIGHT_GREY irc_to_utf8 ); our %EXPORT_TAGS = ( ALL => [@EXPORT_OK] ); no warnings 'once'; ## no critic (TestingAndDebugging::ProhibitNoWarnings) *NORMAL = *IRC::Utils::NORMAL; *BOLD = *IRC::Utils::BOLD; *UNDERLINE = *IRC::Utils::UNDERLINE; *REVERSE = *IRC::Utils::REVERSE; *ITALIC = *IRC::Utils::ITALIC; *FIXED = *IRC::Utils::FIXED; *WHITE = *IRC::Utils::WHITE; *BLACK = *IRC::Utils::BLACK; *DARK_BLUE = *IRC::Utils::BLUE; *DARK_GREEN = *IRC::Utils::GREEN; *RED = *IRC::Utils::RED; *BROWN = *IRC::Utils::BROWN; *PURPLE = *IRC::Utils::PURPLE; *ORANGE = *IRC::Utils::ORANGE; *YELLOW = *IRC::Utils::YELLOW; *LIGHT_GREEN = *IRC::Utils::LIGHT_GREEN; *TEAL = *IRC::Utils::TEAL; *CYAN = *IRC::Utils::LIGHT_CYAN; *LIGHT_BLUE = *IRC::Utils::LIGHT_BLUE; *MAGENTA = *IRC::Utils::PINK; *DARK_GREY = *IRC::Utils::GREY; *LIGHT_GREY = *IRC::Utils::LIGHT_GREY; *u_irc = *IRC::Utils::uc_irc; *l_irc = *IRC::Utils::lc_irc; *parse_mode_line = *IRC::Utils::parse_mode_line; *parse_ban_mask = *IRC::Utils::normalize_mask; *parse_user = *IRC::Utils::parse_user; *matches_mask = *IRC::Utils::matches_mask; *matches_mask_array = *IRC::Utils::matches_mask_array; *has_color = *IRC::Utils::has_color; *has_formatting = *IRC::Utils::has_formatting; *strip_color = *IRC::Utils::strip_color; *strip_formatting = *IRC::Utils::strip_formatting; *irc_to_utf8 = *IRC::Utils::decode_irc; 1; =encoding utf8 =head1 NAME POE::Component::IRC::Common - Provides a set of common functions for the L suite =head1 SYNOPSIS use IRC::Utils; =head1 DESCRIPTION B<'ATTENTION'>: Most of this module's functionality has been moved into L. Take a look at it. This module still exports the old functions (as wrappers around equivalents from L), but new ones won't be added. =head1 AUTHOR Chris 'BinGOs' Williams =head1 SEE ALSO L L =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/State.pm0000644000175000017500000015161613153565114021176 0ustar bingosbingospackage POE::Component::IRC::State; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::State::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use IRC::Utils qw(uc_irc parse_mode_line normalize_mask); use POE; use POE::Component::IRC::Plugin qw(PCI_EAT_NONE); use base qw(POE::Component::IRC); # Event handlers for tracking the STATE. $self->{STATE} is used as our # namespace. uc_irc() is used to create unique keys. # RPL_WELCOME # Make sure we have a clean STATE when we first join the network and if we # inadvertently get disconnected. sub S_001 { my $self = shift; $self->SUPER::S_001(@_); shift @_; delete $self->{STATE}; delete $self->{NETSPLIT}; $self->{STATE}{usermode} = ''; $self->yield(mode => $self->nick_name()); return PCI_EAT_NONE; } sub S_disconnected { my $self = shift; $self->SUPER::S_disconnected(@_); shift @_; my $nickinfo = $self->nick_info($self->nick_name()); $nickinfo = {} if !defined $nickinfo; my $channels = $self->channels(); push @{ $_[-1] }, $nickinfo, $channels; return PCI_EAT_NONE; } sub S_error { my $self = shift; $self->SUPER::S_error(@_); shift @_; my $nickinfo = $self->nick_info($self->nick_name()); $nickinfo = {} if !defined $nickinfo; my $channels = $self->channels(); push @{ $_[-1] }, $nickinfo, $channels; return PCI_EAT_NONE; } sub S_socketerr { my ($self, undef) = splice @_, 0, 2; my $nickinfo = $self->nick_info($self->nick_name()); $nickinfo = {} if !defined $nickinfo; my $channels = $self->channels(); push @{ $_[-1] }, $nickinfo, $channels; return PCI_EAT_NONE; } sub S_join { my ($self, undef) = splice @_, 0, 2; my ($nick, $user, $host) = split /[!@]/, ${ $_[0] }; my $map = $self->isupport('CASEMAPPING'); my $chan = ${ $_[1] }; my $uchan = uc_irc($chan, $map); my $unick = uc_irc($nick, $map); if ($unick eq uc_irc($self->nick_name(), $map)) { delete $self->{STATE}{Chans}{ $uchan }; $self->{CHANNEL_SYNCH}{ $uchan } = { MODE => 0, WHO => 0, BAN => 0, _time => time(), }; $self->{STATE}{Chans}{ $uchan } = { Name => $chan, Mode => '' }; # fake a WHO sync if we're only interested in people's user@host # and the server provides those in the NAMES reply if (exists $self->{whojoiners} && !$self->{whojoiners} && $self->isupport('UHNAMES')) { $self->_channel_sync($chan, 'WHO'); } else { $self->yield(who => $chan); } $self->yield(mode => $chan); $self->yield(mode => $chan => 'b'); } else { SWITCH: { my $netsplit = "$unick!$user\@$host"; if ( exists $self->{NETSPLIT}{Users}{ $netsplit } ) { # restore state from NETSPLIT if it hasn't expired. my $nuser = delete $self->{NETSPLIT}{Users}{ $netsplit }; if ( ( time - $nuser->{stamp} ) < ( 60 * 60 ) ) { $self->{STATE}{Nicks}{ $unick } = $nuser->{meta}; $self->send_event_next(irc_nick_sync => $nick, $chan); last SWITCH; } } if ( (!exists $self->{whojoiners} || $self->{whojoiners}) && !exists $self->{STATE}{Nicks}{ $unick }{Real}) { $self->yield(who => $nick); push @{ $self->{NICK_SYNCH}{ $unick } }, $chan; } else { # Fake 'irc_nick_sync' $self->send_event_next(irc_nick_sync => $nick, $chan); } } } $self->{STATE}{Nicks}{ $unick }{Nick} = $nick; $self->{STATE}{Nicks}{ $unick }{User} = $user; $self->{STATE}{Nicks}{ $unick }{Host} = $host; $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan } = ''; $self->{STATE}{Chans}{ $uchan }{Nicks}{ $unick } = ''; return PCI_EAT_NONE; } sub S_chan_sync { my ($self, undef) = splice @_, 0, 2; my $chan = ${ $_[0] }; if ($self->{awaypoll}) { $poe_kernel->state(_away_sync => $self); $poe_kernel->delay_add(_away_sync => $self->{awaypoll} => $chan); } return PCI_EAT_NONE; } sub S_part { my ($self, undef) = splice @_, 0, 2; my $map = $self->isupport('CASEMAPPING'); my $nick = uc_irc((split /!/, ${ $_[0] } )[0], $map); my $uchan = uc_irc(${ $_[1] }, $map); if ($nick eq uc_irc($self->nick_name(), $map)) { delete $self->{STATE}{Nicks}{ $nick }{CHANS}{ $uchan }; delete $self->{STATE}{Chans}{ $uchan }{Nicks}{ $nick }; for my $member ( keys %{ $self->{STATE}{Chans}{ $uchan }{Nicks} } ) { delete $self->{STATE}{Nicks}{ $member }{CHANS}{ $uchan }; if ( keys %{ $self->{STATE}{Nicks}{ $member }{CHANS} } <= 0 ) { delete $self->{STATE}{Nicks}{ $member }; } } delete $self->{STATE}{Chans}{ $uchan }; } else { delete $self->{STATE}{Nicks}{ $nick }{CHANS}{ $uchan }; delete $self->{STATE}{Chans}{ $uchan }{Nicks}{ $nick }; if ( !keys %{ $self->{STATE}{Nicks}{ $nick }{CHANS} } ) { delete $self->{STATE}{Nicks}{ $nick }; } } return PCI_EAT_NONE; } sub S_quit { my ($self, undef) = splice @_, 0, 2; my $map = $self->isupport('CASEMAPPING'); my $nick = (split /!/, ${ $_[0] })[0]; my $msg = ${ $_[1] }; my $unick = uc_irc($nick, $map); my $netsplit = 0; push @{ $_[-1] }, [ $self->nick_channels( $nick ) ]; # Check if it is a netsplit $netsplit = 1 if _is_netsplit( $msg ); if ($unick ne uc_irc($self->nick_name(), $map)) { for my $uchan ( keys %{ $self->{STATE}{Nicks}{ $unick }{CHANS} } ) { delete $self->{STATE}{Chans}{ $uchan }{Nicks}{ $unick }; # No don't stash the channel state. #$self->{NETSPLIT}{Chans}{ $uchan }{NICKS}{ $unick } = $chanstate # if $netsplit; } my $nickstate = delete $self->{STATE}{Nicks}{ $unick }; if ( $netsplit ) { delete $nickstate->{CHANS}; $self->{NETSPLIT}{Users}{ "$unick!" . join '@', @{$nickstate}{qw(User Host)} } = { meta => $nickstate, stamp => time }; } } return PCI_EAT_NONE; } sub _is_netsplit { my $msg = shift || return; return 1 if $msg =~ /^\s*\S+\.[a-z]{2,} \S+\.[a-z]{2,}$/i; return 0; } sub S_kick { my ($self, undef) = splice @_, 0, 2; my $chan = ${ $_[1] }; my $nick = ${ $_[2] }; my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); my $uchan = uc_irc($chan, $map); push @{ $_[-1] }, $self->nick_long_form( $nick ); if ( $unick eq uc_irc($self->nick_name(), $map)) { delete $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan }; delete $self->{STATE}{Chans}{ $uchan }{Nicks}{ $unick }; for my $member ( keys %{ $self->{STATE}{Chans}{ $uchan }{Nicks} } ) { delete $self->{STATE}{Nicks}{ $member }{CHANS}{ $uchan }; if ( keys %{ $self->{STATE}{Nicks}{ $member }{CHANS} } <= 0 ) { delete $self->{STATE}{Nicks}{ $member }; } } delete $self->{STATE}{Chans}{ $uchan }; } else { delete $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan }; delete $self->{STATE}{Chans}{ $uchan }{Nicks}{ $unick }; if ( keys %{ $self->{STATE}{Nicks}{ $unick }{CHANS} } <= 0 ) { delete $self->{STATE}{Nicks}{ $unick }; } } return PCI_EAT_NONE; } sub S_nick { my $self = shift; $self->SUPER::S_nick(@_); shift @_; my $nick = (split /!/, ${ $_[0] })[0]; my $new = ${ $_[1] }; my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); my $unew = uc_irc($new, $map); push @{ $_[-1] }, [ $self->nick_channels( $nick ) ]; if ($unick eq $unew) { # Case Change $self->{STATE}{Nicks}{ $unick }{Nick} = $new; } else { my $user = delete $self->{STATE}{Nicks}{ $unick }; $user->{Nick} = $new; for my $channel ( keys %{ $user->{CHANS} } ) { $self->{STATE}{Chans}{ $channel }{Nicks}{ $unew } = $user->{CHANS}{ $channel }; delete $self->{STATE}{Chans}{ $channel }{Nicks}{ $unick }; } $self->{STATE}{Nicks}{ $unew } = $user; } return PCI_EAT_NONE; } sub S_chan_mode { my ($self, undef) = splice @_, 0, 2; pop @_; my $who = ${ $_[0] }; my $chan = ${ $_[1] }; my $mode = ${ $_[2] }; my $arg = defined $_[3] ? ${ $_[3] } : ''; my $map = $self->isupport('CASEMAPPING'); my $me = uc_irc($self->nick_name(), $map); return PCI_EAT_NONE if $mode !~ /\+[qoah]/ || $me ne uc_irc($arg, $map); my $excepts = $self->isupport('EXCEPTS'); my $invex = $self->isupport('INVEX'); $self->yield(mode => $chan, $excepts ) if $excepts; $self->yield(mode => $chan, $invex ) if $invex; return PCI_EAT_NONE; } # RPL_UMODEIS sub S_221 { my ($self, undef) = splice @_, 0, 2; my $mode = ${ $_[1] }; $mode =~ s/^\+//; $self->{STATE}->{usermode} = $mode; return PCI_EAT_NONE; } # RPL_CHANNEL_URL sub S_328 { my ($self, undef) = splice @_, 0, 2; my ($chan, $url) = @{ ${ $_[2] } }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return PCI_EAT_NONE if !$self->_channel_exists($chan); $self->{STATE}{Chans}{ $uchan }{Url} = $url; return PCI_EAT_NONE; } # RPL_UNAWAY sub S_305 { my ($self, undef) = splice @_, 0, 2; $self->{STATE}->{away} = 0; return PCI_EAT_NONE; } # RPL_NOWAWAY sub S_306 { my ($self, undef) = splice @_, 0, 2; $self->{STATE}->{away} = 1; return PCI_EAT_NONE; } # this code needs refactoring ## no critic (Subroutines::ProhibitExcessComplexity ControlStructures::ProhibitCascadingIfElse) sub S_mode { my ($self, undef) = splice @_, 0, 2; my $map = $self->isupport('CASEMAPPING'); my $who = ${ $_[0] }; my $chan = ${ $_[1] }; my $uchan = uc_irc($chan, $map); pop @_; my @modes = map { ${ $_ } } @_[2 .. $#_]; # CHANMODES is [$list_mode, $always_arg, $arg_when_set, $no_arg] # A $list_mode always has an argument my $prefix = $self->isupport('PREFIX') || { o => '@', v => '+' }; my $statmodes = join '', keys %{ $prefix }; my $chanmodes = $self->isupport('CHANMODES') || [ qw(beI k l imnpstaqr) ]; my $alwaysarg = join '', $statmodes, @{ $chanmodes }[0 .. 1]; # Do nothing if it is UMODE if ($uchan ne uc_irc($self->nick_name(), $map)) { my $parsed_mode = parse_mode_line( $prefix, $chanmodes, @modes ); for my $mode (@{ $parsed_mode->{modes} }) { my $orig_arg; if (length $chanmodes->[2] && length $alwaysarg && $mode =~ /^(.[$alwaysarg]|\+[$chanmodes->[2]])/) { $orig_arg = shift @{ $parsed_mode->{args} }; } my $flag; my $arg = $orig_arg; if (length $statmodes && (($flag) = $mode =~ /\+([$statmodes])/)) { $arg = uc_irc($arg, $map); if (!$self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan } || $self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan } !~ /$flag/) { $self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan } .= $flag; $self->{STATE}{Chans}{ $uchan }{Nicks}{ $arg } = $self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan }; } } elsif (length $statmodes && (($flag) = $mode =~ /-([$statmodes])/)) { $arg = uc_irc($arg, $map); if ($self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan } =~ /$flag/) { $self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan } =~ s/$flag//; $self->{STATE}{Chans}{ $uchan }{Nicks}{ $arg } = $self->{STATE}{Nicks}{ $arg }{CHANS}{ $uchan }; } } elsif (length $chanmodes->[0] && (($flag) = $mode =~ /\+([$chanmodes->[0]])/)) { $self->{STATE}{Chans}{ $uchan }{Lists}{ $flag }{ $arg } = { SetBy => $who, SetAt => time(), }; } elsif (length $chanmodes->[0] && (($flag) = $mode =~ /-([$chanmodes->[0]])/)) { delete $self->{STATE}{Chans}{ $uchan }{Lists}{ $flag }{ $arg }; } # All unhandled modes with arguments elsif (length $chanmodes->[3] && (($flag) = $mode =~ /\+([^$chanmodes->[3]])/)) { $self->{STATE}{Chans}{ $uchan }{Mode} .= $flag if $self->{STATE}{Chans}{ $uchan }{Mode} !~ /$flag/; $self->{STATE}{Chans}{ $uchan }{ModeArgs}{ $flag } = $arg; } elsif (length $chanmodes->[3] && (($flag) = $mode =~ /-([^$chanmodes->[3]])/)) { $self->{STATE}{Chans}{ $uchan }{Mode} =~ s/$flag//; delete $self->{STATE}{Chans}{ $uchan }{ModeArgs}{ $flag }; } # Anything else doesn't have arguments so just adjust {Mode} as necessary. elsif (($flag) = $mode =~ /^\+(.)/ ) { $self->{STATE}{Chans}{ $uchan }{Mode} .= $flag if $self->{STATE}{Chans}{ $uchan }{Mode} !~ /$flag/; } elsif (($flag) = $mode =~ /^-(.)/ ) { $self->{STATE}{Chans}{ $uchan }{Mode} =~ s/$flag//; } $self->send_event_next(irc_chan_mode => $who, $chan, $mode, (defined $orig_arg ? $orig_arg : ())); } # Lets make the channel mode nice if ( $self->{STATE}{Chans}{ $uchan }{Mode} ) { $self->{STATE}{Chans}{ $uchan }{Mode} = join('', sort {uc $a cmp uc $b} ( split( //, $self->{STATE}{Chans}{ $uchan }{Mode} ) ) ); } } else { my $parsed_mode = parse_mode_line( @modes ); for my $mode (@{ $parsed_mode->{modes} }) { my $flag; if ( ($flag) = $mode =~ /^\+(.)/ ) { $self->{STATE}{usermode} .= $flag if $self->{STATE}{usermode} !~ /$flag/; } elsif ( ($flag) = $mode =~ /^-(.)/ ) { $self->{STATE}{usermode} =~ s/$flag//; } $self->send_event_next(irc_user_mode => $who, $chan, $mode ); } } return PCI_EAT_NONE; } sub S_topic { my ($self, undef) = splice @_, 0, 2; my $who = ${ $_[0] }; my $chan = ${ $_[1] }; my $topic = ${ $_[2] }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); push @{ $_[-1] }, $self->{STATE}{Chans}{$uchan}{Topic}; $self->{STATE}{Chans}{ $uchan }{Topic} = { Value => $topic, SetBy => $who, SetAt => time(), }; return PCI_EAT_NONE; } # RPL_NAMES sub S_353 { my ($self, undef) = splice @_, 0, 2; my @data = @{ ${ $_[2] } }; shift @data if $data[0] =~ /^[@=*]$/; my $chan = shift @data; my @nicks = split /\s+/, shift @data; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $prefix = $self->isupport('PREFIX') || { o => '@', v => '+' }; my $search = join '|', map { quotemeta } values %$prefix; $search = qr/(?:$search)/; for my $nick (@nicks) { my $status; if ( ($status) = $nick =~ /^($search+)/ ) { $nick =~ s/^($search+)//; } my ($user, $host); if ($self->isupport('UHNAMES')) { ($nick, $user, $host) = split /[!@]/, $nick; } my $unick = uc_irc($nick, $map); $status = '' if !defined $status; my $whatever = ''; my $existing = $self->{STATE}{Nicks}{$unick}{CHANS}{$uchan} || ''; for my $mode (keys %$prefix) { if ($status =~ /\Q$prefix->{$mode}/ && $existing !~ /\Q$prefix->{$mode}/) { $whatever .= $mode; } } $existing .= $whatever if !length $existing || $existing !~ /$whatever/; $self->{STATE}{Nicks}{$unick}{CHANS}{$uchan} = $existing; $self->{STATE}{Chans}{$uchan}{Nicks}{$unick} = $existing; $self->{STATE}{Nicks}{$unick}{Nick} = $nick; if ($self->isupport('UHNAMES')) { $self->{STATE}{Nicks}{$unick}{User} = $user; $self->{STATE}{Nicks}{$unick}{Host} = $host; } } return PCI_EAT_NONE; } # RPL_WHOREPLY sub S_352 { my ($self, undef) = splice @_, 0, 2; my ($chan, $user, $host, $server, $nick, $status, $rest) = @{ ${ $_[2] } }; my ($hops, $real) = split /\x20/, $rest, 2; my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); my $uchan = uc_irc($chan, $map); $self->{STATE}{Nicks}{ $unick }{Nick} = $nick; $self->{STATE}{Nicks}{ $unick }{User} = $user; $self->{STATE}{Nicks}{ $unick }{Host} = $host; if ( !exists $self->{whojoiners} || $self->{whojoiners} ) { $self->{STATE}{Nicks}{ $unick }{Hops} = $hops; $self->{STATE}{Nicks}{ $unick }{Real} = $real; $self->{STATE}{Nicks}{ $unick }{Server} = $server; $self->{STATE}{Nicks}{ $unick }{IRCop} = 1 if $status =~ /\*/; } if ( exists $self->{STATE}{Chans}{ $uchan } ) { my $whatever = ''; my $existing = $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan } || ''; my $prefix = $self->isupport('PREFIX') || { o => '@', v => '+' }; for my $mode ( keys %{ $prefix } ) { if ($status =~ /\Q$prefix->{$mode}/ && $existing !~ /\Q$prefix->{$mode}/ ) { $whatever .= $mode; } } $existing .= $whatever if !$existing || $existing !~ /$whatever/; $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan } = $existing; $self->{STATE}{Chans}{ $uchan }{Nicks}{ $unick } = $existing; $self->{STATE}{Chans}{ $uchan }{Name} = $chan; if ($self->{STATE}{Chans}{ $uchan }{AWAY_SYNCH} && $unick ne uc_irc($self->nick_name(), $map)) { if ( $status =~ /G/ && !$self->{STATE}{Nicks}{ $unick }{Away} ) { $self->send_event_next(irc_user_away => $nick, [ $self->nick_channels( $nick ) ] ); } elsif ($status =~ /H/ && $self->{STATE}{Nicks}{ $unick }{Away} ) { $self->send_event_next(irc_user_back => $nick, [ $self->nick_channels( $nick ) ] ); } } if ($self->{awaypoll}) { $self->{STATE}{Nicks}{ $unick }{Away} = $status =~ /G/ ? 1 : 0; } } return PCI_EAT_NONE; } # RPL_ENDOFWHO sub S_315 { my ($self, undef) = splice @_, 0, 2; my $what = ${ $_[2] }->[0]; my $map = $self->isupport('CASEMAPPING'); my $uwhat = uc_irc($what, $map); if ( exists $self->{STATE}{Chans}{ $uwhat } ) { my $chan = $what; my $uchan = $uwhat; if ( $self->_channel_sync($chan, 'WHO') ) { my $rec = delete $self->{CHANNEL_SYNCH}{ $uchan }; $self->send_event_next(irc_chan_sync => $chan, time() - $rec->{_time} ); } elsif ( $self->{STATE}{Chans}{ $uchan }{AWAY_SYNCH} ) { $self->{STATE}{Chans}{ $uchan }{AWAY_SYNCH} = 0; $poe_kernel->delay_add(_away_sync => $self->{awaypoll} => $chan ); $self->send_event_next(irc_away_sync_end => $chan ); } } else { my $nick = $what; my $unick = $uwhat; my $chan = shift @{ $self->{NICK_SYNCH}{ $unick } }; delete $self->{NICK_SYNCH}{ $unick } if !@{ $self->{NICK_SYNCH}{ $unick } }; $self->send_event_next(irc_nick_sync => $nick, $chan ); } return PCI_EAT_NONE; } # RPL_CREATIONTIME sub S_329 { my ($self, undef) = splice @_, 0, 2; my $map = $self->isupport('CASEMAPPING'); my $chan = ${ $_[2] }->[0]; my $time = ${ $_[2] }->[1]; my $uchan = uc_irc($chan, $map); $self->{STATE}->{Chans}{ $uchan }{CreationTime} = $time; return PCI_EAT_NONE; } # RPL_BANLIST sub S_367 { my ($self, undef) = splice @_, 0, 2; my @args = @{ ${ $_[2] } }; my $chan = shift @args; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my ($mask, $who, $when) = @args; $self->{STATE}{Chans}{ $uchan }{Lists}{b}{ $mask } = { SetBy => $who, SetAt => $when, }; return PCI_EAT_NONE; } # RPL_ENDOFBANLIST sub S_368 { my ($self, undef) = splice @_, 0, 2; my @args = @{ ${ $_[2] } }; my $chan = shift @args; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); if ($self->_channel_sync($chan, 'BAN')) { my $rec = delete $self->{CHANNEL_SYNCH}{ $uchan }; $self->send_event_next(irc_chan_sync => $chan, time() - $rec->{_time} ); } return PCI_EAT_NONE; } # RPL_INVITELIST sub S_346 { my ($self, undef) = splice @_, 0, 2; my ($chan, $mask, $who, $when) = @{ ${ $_[2] } }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $invex = $self->isupport('INVEX'); $self->{STATE}{Chans}{ $uchan }{Lists}{ $invex }{ $mask } = { SetBy => $who, SetAt => $when }; return PCI_EAT_NONE; } # RPL_ENDOFINVITELIST sub S_347 { my ($self, undef) = splice @_, 0, 2; my ($chan) = @{ ${ $_[2] } }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); $self->send_event_next(irc_chan_sync_invex => $chan); return PCI_EAT_NONE; } # RPL_EXCEPTLIST sub S_348 { my ($self, undef) = splice @_, 0, 2; my ($chan, $mask, $who, $when) = @{ ${ $_[2] } }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $excepts = $self->isupport('EXCEPTS'); $self->{STATE}{Chans}{ $uchan }{Lists}{ $excepts }{ $mask } = { SetBy => $who, SetAt => $when, }; return PCI_EAT_NONE; } # RPL_ENDOFEXCEPTLIST sub S_349 { my ($self, undef) = splice @_, 0, 2; my ($chan) = @{ ${ $_[2] } }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); $self->send_event_next(irc_chan_sync_excepts => $chan); return PCI_EAT_NONE; } # RPL_CHANNELMODEIS sub S_324 { my ($self, undef) = splice @_, 0, 2; my @args = @{ ${ $_[2] } }; my $chan = shift @args; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $modes = $self->isupport('CHANMODES') || [ qw(beI k l imnpstaqr) ]; my $prefix = $self->isupport('PREFIX') || { o => '@', v => '+' }; my $parsed_mode = parse_mode_line($prefix, $modes, @args); for my $mode (@{ $parsed_mode->{modes} }) { $mode =~ s/\+//; my $arg = ''; if ($mode =~ /[^$modes->[3]]/) { # doesn't match a mode with no args $arg = shift @{ $parsed_mode->{args} }; } if ( $self->{STATE}{Chans}{ $uchan }{Mode} ) { $self->{STATE}{Chans}{ $uchan }{Mode} .= $mode if $self->{STATE}{Chans}{ $uchan }{Mode} !~ /$mode/; } else { $self->{STATE}{Chans}{ $uchan }{Mode} = $mode; } $self->{STATE}{Chans}{ $uchan }{ModeArgs}{ $mode } = $arg if defined ( $arg ); } if ( $self->{STATE}{Chans}{ $uchan }{Mode} ) { $self->{STATE}{Chans}{ $uchan }{Mode} = join('', sort {uc $a cmp uc $b} split //, $self->{STATE}{Chans}{ $uchan }{Mode} ); } if ( $self->_channel_sync($chan, 'MODE') ) { my $rec = delete $self->{CHANNEL_SYNCH}{ $uchan }; $self->send_event_next(irc_chan_sync => $chan, time() - $rec->{_time} ); } return PCI_EAT_NONE; } # RPL_TOPIC sub S_332 { my ($self, undef) = splice @_, 0, 2; my $chan = ${ $_[2] }->[0]; my $topic = ${ $_[2] }->[1]; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); $self->{STATE}{Chans}{ $uchan }{Topic}{Value} = $topic; return PCI_EAT_NONE; } # RPL_TOPICWHOTIME sub S_333 { my ($self, undef) = splice @_, 0, 2; my ($chan, $who, $when) = @{ ${ $_[2] } }; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); $self->{STATE}{Chans}{ $uchan }{Topic}{SetBy} = $who; $self->{STATE}{Chans}{ $uchan }{Topic}{SetAt} = $when; return PCI_EAT_NONE; } # Methods for STATE query # Internal methods begin with '_' # sub umode { my ($self) = @_; return $self->{STATE}{usermode}; } sub is_user_mode_set { my ($self, $mode) = @_; if (!defined $mode) { warn 'User mode is undefined'; return; } $mode = (split //, $mode)[0] || return; $mode =~ s/[^A-Za-z]//g; return if !$mode; return 1 if $self->{STATE}{usermode} =~ /$mode/; return; } sub _away_sync { my ($self, $chan) = @_[OBJECT, ARG0]; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); $self->{STATE}{Chans}{ $uchan }{AWAY_SYNCH} = 1; $self->yield(who => $chan); $self->send_event(irc_away_sync_start => $chan); return; } sub _channel_sync { my ($self, $chan, $sync) = @_; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan) || !defined $self->{CHANNEL_SYNCH}{ $uchan }; $self->{CHANNEL_SYNCH}{ $uchan }{ $sync } = 1 if $sync; for my $item ( qw(BAN MODE WHO) ) { return if !$self->{CHANNEL_SYNCH}{ $uchan }{ $item }; } return 1; } sub _nick_exists { my ($self, $nick) = @_; my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); return 1 if exists $self->{STATE}{Nicks}{ $unick }; return; } sub _channel_exists { my ($self, $chan) = @_; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return 1 if exists $self->{STATE}{Chans}{ $uchan }; return; } sub _nick_has_channel_mode { my ($self, $chan, $nick, $flag) = @_; my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $unick = uc_irc($nick, $map); $flag = (split //, $flag)[0]; return if !$self->is_channel_member($uchan, $unick); return 1 if $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan } =~ /$flag/; return; } # Returns all the channels that the bot is on with an indication of # whether it has operator, halfop or voice. sub channels { my ($self) = @_; my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($self->nick_name(), $map); my %result; if (defined $unick && $self->_nick_exists($unick)) { for my $uchan ( keys %{ $self->{STATE}{Nicks}{ $unick }{CHANS} } ) { $result{ $self->{STATE}{Chans}{ $uchan }{Name} } = $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan }; } } return \%result; } sub nicks { my ($self) = @_; return map { $self->{STATE}{Nicks}{$_}{Nick} } keys %{ $self->{STATE}{Nicks} }; } sub nick_info { my ($self, $nick) = @_; if (!defined $nick) { warn 'Nickname is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); return if !$self->_nick_exists($nick); my $user = $self->{STATE}{Nicks}{ $unick }; my %result = %{ $user }; # maybe we haven't synced this user's info yet if (defined $result{User} && defined $result{Host}) { $result{Userhost} = "$result{User}\@$result{Host}"; } delete $result{'CHANS'}; return \%result; } sub nick_long_form { my ($self, $nick) = @_; if (!defined $nick) { warn 'Nickname is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); return if !$self->_nick_exists($nick); my $user = $self->{STATE}{Nicks}{ $unick }; return unless exists $user->{User} && exists $user->{Host}; return "$user->{Nick}!$user->{User}\@$user->{Host}"; } sub nick_channels { my ($self, $nick) = @_; if (!defined $nick) { warn 'Nickname is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); return if !$self->_nick_exists($nick); return map { $self->{STATE}{Chans}{$_}{Name} } keys %{ $self->{STATE}{Nicks}{ $unick }{CHANS} }; } sub channel_list { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan); return map { $self->{STATE}{Nicks}{$_}{Nick} } keys %{ $self->{STATE}{Chans}{ $uchan }{Nicks} }; } sub is_away { my ($self, $nick) = @_; if (!defined $nick) { warn 'Nickname is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); if ($unick eq uc_irc($self->nick_name())) { # more accurate return 1 if $self->{STATE}{away}; return; } return if !$self->_nick_exists($nick); return 1 if $self->{STATE}{Nicks}{ $unick }{Away}; return; } sub is_operator { my ($self, $nick) = @_; if (!defined $nick) { warn 'Nickname is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $unick = uc_irc($nick, $map); return if !$self->_nick_exists($nick); return 1 if $self->{STATE}{Nicks}{ $unick }{IRCop}; return; } sub is_channel_mode_set { my ($self, $chan, $mode) = @_; if (!defined $chan || !defined $mode) { warn 'Channel or mode is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); $mode = (split //, $mode)[0]; return if !$self->_channel_exists($chan) || !$mode; $mode =~ s/[^A-Za-z]//g; if (defined $self->{STATE}{Chans}{ $uchan }{Mode} && $self->{STATE}{Chans}{ $uchan }{Mode} =~ /$mode/) { return 1; } return; } sub is_channel_synced { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } return $self->_channel_sync($chan); } sub channel_creation_time { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan); return if !exists $self->{STATE}{Chans}{ $uchan }{CreationTime}; return $self->{STATE}{Chans}{ $uchan }{CreationTime}; } sub channel_limit { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan); if ( $self->is_channel_mode_set($chan, 'l') && defined $self->{STATE}{Chans}{ $uchan }{ModeArgs}{l} ) { return $self->{STATE}{Chans}{ $uchan }{ModeArgs}{l}; } return; } sub channel_key { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan); if ( $self->is_channel_mode_set($chan, 'k') && defined $self->{STATE}{Chans}{ $uchan }{ModeArgs}{k} ) { return $self->{STATE}{Chans}{ $uchan }{ModeArgs}{k}; } return; } sub channel_modes { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan); my %modes; if ( defined $self->{STATE}{Chans}{ $uchan }{Mode} ) { %modes = map { ($_ => '') } split(//, $self->{STATE}{Chans}{ $uchan }{Mode}); } if ( defined $self->{STATE}{Chans}{ $uchan }->{ModeArgs} ) { my %args = %{ $self->{STATE}{Chans}{ $uchan }{ModeArgs} }; @modes{keys %args} = values %args; } return \%modes; } sub is_channel_member { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nickname is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $unick = uc_irc($nick, $map); return if !$self->_channel_exists($chan) || !$self->_nick_exists($nick); return 1 if defined $self->{STATE}{Chans}{ $uchan }{Nicks}{ $unick }; return; } sub is_channel_operator { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nickname is undefined'; return; } return 1 if $self->_nick_has_channel_mode($chan, $nick, 'o'); return; } sub has_channel_voice { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nickname is undefined'; return; } return 1 if $self->_nick_has_channel_mode($chan, $nick, 'v'); return; } sub is_channel_halfop { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nickname is undefined'; return; } return 1 if $self->_nick_has_channel_mode($chan, $nick, 'h'); return; } sub is_channel_owner { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nickname is undefined'; return; } return 1 if $self->_nick_has_channel_mode($chan, $nick, 'q'); return; } sub is_channel_admin { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nickname is undefined'; return; } return 1 if $self->_nick_has_channel_mode($chan, $nick, 'a'); return; } sub ban_mask { my ($self, $chan, $mask) = @_; if (!defined $chan || !defined $mask) { warn 'Channel or mask is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); $mask = normalize_mask($mask); my @result; return if !$self->_channel_exists($chan); # Convert the mask from IRC to regex. $mask = uc_irc($mask, $map); $mask = quotemeta $mask; $mask =~ s/\\\*/[\x01-\xFF]{0,}/g; $mask =~ s/\\\?/[\x01-\xFF]{1,1}/g; for my $nick ( $self->channel_list($chan) ) { push @result, $nick if uc_irc($self->nick_long_form($nick)) =~ /^$mask$/; } return @result; } sub channel_ban_list { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my %result; return if !$self->_channel_exists($chan); if ( defined $self->{STATE}{Chans}{ $uchan }{Lists}{b} ) { %result = %{ $self->{STATE}{Chans}{ $uchan }{Lists}{b} }; } return \%result; } sub channel_except_list { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $excepts = $self->isupport('EXCEPTS'); my %result; return if !$self->_channel_exists($chan); if ( defined $self->{STATE}{Chans}{ $uchan }{Lists}{ $excepts } ) { %result = %{ $self->{STATE}{Chans}{ $uchan }{Lists}{ $excepts } }; } return \%result; } sub channel_invex_list { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $invex = $self->isupport('INVEX'); my %result; return if !$self->_channel_exists($chan); if ( defined $self->{STATE}{Chans}{ $uchan }{Lists}{ $invex } ) { %result = %{ $self->{STATE}{Chans}{ $uchan }{Lists}{ $invex } }; } return \%result; } sub channel_topic { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my %result; return if !$self->_channel_exists($chan); if ( defined $self->{STATE}{Chans}{ $uchan }{Topic} ) { %result = %{ $self->{STATE}{Chans}{ $uchan }{Topic} }; } return \%result; } sub channel_url { my ($self, $chan) = @_; if (!defined $chan) { warn 'Channel is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); return if !$self->_channel_exists($chan); return $self->{STATE}{Chans}{ $uchan }{Url}; } sub nick_channel_modes { my ($self, $chan, $nick) = @_; if (!defined $chan || !defined $nick) { warn 'Channel or nick is undefined'; return; } my $map = $self->isupport('CASEMAPPING'); my $uchan = uc_irc($chan, $map); my $unick = uc_irc($nick, $map); return if !$self->is_channel_member($chan, $nick); return $self->{STATE}{Nicks}{ $unick }{CHANS}{ $uchan }; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::State - A fully event-driven IRC client module with nickname and channel tracking =head1 SYNOPSIS # A simple Rot13 'encryption' bot use strict; use warnings; use POE qw(Component::IRC::State); my $nickname = 'Flibble' . $$; my $ircname = 'Flibble the Sailor Bot'; my $ircserver = 'irc.blahblahblah.irc'; my $port = 6667; my @channels = ( '#Blah', '#Foo', '#Bar' ); # We create a new PoCo-IRC object and component. my $irc = POE::Component::IRC::State->spawn( nick => $nickname, server => $ircserver, port => $port, ircname => $ircname, ) or die "Oh noooo! $!"; POE::Session->create( package_states => [ main => [ qw(_default _start irc_001 irc_public) ], ], heap => { irc => $irc }, ); $poe_kernel->run(); sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; # We get the session ID of the component from the object # and register and connect to the specified server. my $irc_session = $heap->{irc}->session_id(); $kernel->post( $irc_session => register => 'all' ); $kernel->post( $irc_session => connect => { } ); return; } sub irc_001 { my ($kernel, $sender) = @_[KERNEL, SENDER]; # Get the component's object at any time by accessing the heap of # the SENDER my $poco_object = $sender->get_heap(); print "Connected to ", $poco_object->server_name(), "\n"; # In any irc_* events SENDER will be the PoCo-IRC session $kernel->post( $sender => join => $_ ) for @channels; return; } sub irc_public { my ($kernel ,$sender, $who, $where, $what) = @_[KERNEL, SENDER, ARG0 .. ARG2]; my $nick = ( split /!/, $who )[0]; my $channel = $where->[0]; my $poco_object = $sender->get_heap(); if ( my ($rot13) = $what =~ /^rot13 (.+)/ ) { # Only operators can issue a rot13 command to us. return if !$poco_object->is_channel_operator( $channel, $nick ); $rot13 =~ tr[a-zA-Z][n-za-mN-ZA-M]; $kernel->post( $sender => privmsg => $channel => "$nick: $rot13" ); } return; } # We registered for all events, this will produce some debug info. sub _default { my ($event, $args) = @_[ARG0 .. $#_]; my @output = ( "$event: " ); for my $arg ( @$args ) { if (ref $arg eq 'ARRAY') { push( @output, '[' . join(', ', @$arg ) . ']' ); } else { push ( @output, "'$arg'" ); } } print join ' ', @output, "\n"; return 0; } =head1 DESCRIPTION POE::Component::IRC::State is a sub-class of L which tracks IRC state entities such as nicks and channels. See the documentation for L for general usage. This document covers the extra methods that POE::Component::IRC::State provides. The component tracks channels and nicks, so that it always has a current snapshot of what channels it is on and who else is on those channels. The returned object provides methods to query the collected state. =head1 CONSTRUCTORS POE::Component::IRC::State's constructors, and its C event, all take the same arguments as L does, as well as two additional ones: B<'AwayPoll'>, the interval (in seconds) in which to poll (i.e. C) the away status of channel members. Defaults to 0 (disabled). If enabled, you will receive C / L|/irc_user_away> / L|/irc_user_back> events, and will be able to use the L|/is_away> method for users other than yourself. This can cause a lot of increase in traffic, especially if you are on big channels, so if you do use this, you probably don't want to set it too low. For reference, X-Chat uses 300 seconds (5 minutes). B<'WhoJoiners'>, a boolean indicating whether the component should send a C for every person which joins a channel. Defaults to on (the C is sent). If you turn this off, L|/is_operator> will not work and L|/nick_info> will only return the keys B<'Nick'>, B<'User'>, B<'Host'> and B<'Userhost'>. =head1 METHODS All of the L methods are supported, plus the following: =head2 C Expects a channel and a ban mask, as passed to MODE +b-b. Returns a list of nicks on that channel that match the specified ban mask or an empty list if the channel doesn't exist in the state or there are no matches. =head2 C Expects a channel as a parameter. Returns a hashref containing the banlist if the channel is in the state, a false value if not. The hashref keys are the entries on the list, each with the keys B<'SetBy'> and B<'SetAt'>. These keys will hold the nick!hostmask of the user who set the entry (or just the nick if it's all the ircd gives us), and the time at which it was set respectively. =head2 C Expects a channel as parameter. Returns channel creation time or a false value. =head2 C Expects a channel as a parameter. Returns a hashref containing the ban exception list if the channel is in the state, a false value if not. The hashref keys are the entries on the list, each with the keys B<'SetBy'> and B<'SetAt'>. These keys will hold the nick!hostmask of the user who set the entry (or just the nick if it's all the ircd gives us), and the time at which it was set respectively. =head2 C Expects a channel as a parameter. Returns a hashref containing the invite exception list if the channel is in the state, a false value if not. The hashref keys are the entries on the list, each with the keys B<'SetBy'> and B<'SetAt'>. These keys will hold the nick!hostmask of the user who set the entry (or just the nick if it's all the ircd gives us), and the time at which it was set respectively. =head2 C Expects a channel as parameter. Returns the channel key or a false value. =head2 C Expects a channel as parameter. Returns the channel limit or a false value. =head2 C Expects a channel as parameter. Returns a list of all nicks on the specified channel. If the component happens to not be on that channel an empty list will be returned. =head2 C Expects a channel as parameter. Returns a hash ref keyed on channel mode, with the mode argument (if any) as the value. Returns a false value instead if the channel is not in the state. =head2 C Takes no parameters. Returns a hashref, keyed on channel name and whether the bot is operator, halfop or has voice on that channel. for my $channel ( keys %{ $irc->channels() } ) { $irc->yield( 'privmsg' => $channel => 'm00!' ); } =head2 C Expects a channel as a parameter. Returns a hashref containing topic information if the channel is in the state, a false value if not. The hashref contains the following keys: B<'Value'>, B<'SetBy'>, B<'SetAt'>. These keys will hold the topic itself, the nick!hostmask of the user who set it (or just the nick if it's all the ircd gives us), and the time at which it was set respectively. If the component happens to not be on the channel, nothing will be returned. =head2 C Expects a channel as a parameter. Returns the channel's URL. If the channel has no URL or the component is not on the channel, nothing will be returned. =head2 C Expects a channel and a nickname as parameters. Returns a true value if the nick has voice on the specified channel. Returns false if the nick does not have voice on the channel or if the nick/channel does not exist in the state. =head2 C Expects a nick as parameter. Returns a true value if the specified nick is away. Returns a false value if the nick is not away or not in the state. This will only work for your IRC user unless you specified a value for B<'AwayPoll'> in L|POE::Component::IRC/spawn>. =head2 C Expects a channel and a nickname as parameters. Returns a true value if the nick is an admin on the specified channel. Returns false if the nick is not an admin on the channel or if the nick/channel does not exist in the state. =head2 C Expects a channel and a nickname as parameters. Returns a true value if the nick is a half-operator on the specified channel. Returns false if the nick is not a half-operator on the channel or if the nick/channel does not exist in the state. =head2 C Expects a channel and a nickname as parameters. Returns a true value if the nick is on the specified channel. Returns false if the nick is not on the channel or if the nick/channel does not exist in the state. =head2 C Expects a channel and a single mode flag C<[A-Za-z]>. Returns a true value if that mode is set on the channel. =head2 C Expects a channel and a nickname as parameters. Returns a true value if the nick is an operator on the specified channel. Returns false if the nick is not an operator on the channel or if the nick/channel does not exist in the state. =head2 C Expects a channel and a nickname as parameters. Returns a true value if the nick is an owner on the specified channel. Returns false if the nick is not an owner on the channel or if the nick/channel does not exist in the state. =head2 C Expects a channel as a parameter. Returns true if the channel has been synced. Returns false if it has not been synced or if the channel is not in the state. =head2 C Expects a nick as parameter. Returns a true value if the specified nick is an IRC operator. Returns a false value if the nick is not an IRC operator or is not in the state. =head2 C Expects single user mode flag C<[A-Za-z]>. Returns a true value if that user mode is set. =head2 C Expects a channel and a nickname as parameters. Returns the modes of the specified nick on the specified channel (ie. qaohv). If the nick is not on the channel in the state, a false value will be returned. =head2 C Expects a nickname. Returns a list of the channels that that nickname and the component are on. An empty list will be returned if the nickname does not exist in the state. =head2 C Expects a nickname. Returns a hashref containing similar information to that returned by WHOIS. Returns a false value if the nickname doesn't exist in the state. The hashref contains the following keys: B<'Nick'>, B<'User'>, B<'Host'>, B<'Userhost'>, B<'Hops'>, B<'Real'>, B<'Server'> and, if applicable, B<'IRCop'>. =head2 C Expects a nickname. Returns the long form of that nickname, ie. C or a false value if the nick is not in the state. =head2 C Takes no parameters. Returns a list of all the nicks, including itself, that it knows about. If the component happens to be on no channels then an empty list is returned. =head2 C Takes no parameters. Returns the current user mode set for the bot. =head1 OUTPUT EVENTS =head2 Augmented events New parameters are added to the following L events. =head3 C See also L|POE::Component::IRC/irc_quit> in L. Additional parameter C contains an arrayref of channel names that are common to the quitting client and the component. =head3 C See also L|POE::Component::IRC/irc_nick> in L. Additional parameter C contains an arrayref of channel names that are common to the nick hanging client and the component. =head3 C See also L|POE::Component::IRC/irc_kick> in L. Additional parameter C contains the full nick!user@host of the kicked individual. =head3 C See also L|POE::Component::IRC/irc_kick> in L. Additional parameter C contains the old topic hashref, like the one returned by L|/channel_topic>. =head3 C =head3 C =head3 C These three all have two additional parameters. C is a hash of information about your IRC user (see L|/nick_info>), while C is a hash of the channels you were on (see L|/channels>). =head2 New events As well as all the usual L C events, there are the following events you can register for: =head3 C Sent whenever the component starts to synchronise the away statuses of channel members. C is the channel name. You will only receive this event if you specified a value for B<'AwayPoll'> in L|POE::Component::IRC/spawn>. =head3 C Sent whenever the component has completed synchronising the away statuses of channel members. C is the channel name. You will only receive this event if you specified a value for B<'AwayPoll'> in L|POE::Component::IRC/spawn>. =head3 C This is almost identical to L|POE::Component::IRC/irc_mode>, except that it's sent once for each individual mode with it's respective argument if it has one (ie. the banmask if it's +b or -b). However, this event is only sent for channel modes. =head3 C Sent whenever the component has completed synchronising a channel that it has joined. C is the channel name and C is the time in seconds that the channel took to synchronise. =head3 C Sent whenever the component has completed synchronising a channel's INVEX (invite list). Usually triggered by the component being opped on a channel. C is the channel name. =head3 C Sent whenever the component has completed synchronising a channel's EXCEPTS (ban exemption list). Usually triggered by the component being opped on a channel. C is the channel. =head3 C Sent whenever the component has completed synchronising a user who has joined a channel the component is on. C is the user's nickname and C the channel they have joined. =head3 C Sent when an IRC user sets his/her status to away. C is the nickname, C is an arrayref of channel names that are common to the nickname and the component. You will only receive this event if you specified a value for B<'AwayPoll'> in L|POE::Component::IRC/spawn>. B This above is only for users I. To know when you change your own away status, register for the C and C events. =head3 C Sent when an IRC user unsets his/her away status. C is the nickname, C is an arrayref of channel names that are common to the nickname and the component. You will only receive this event if you specified a value for B<'AwayPoll'> in L|POE::Component::IRC/spawn>. B This above is only for users I. To know when you change your own away status, register for the C and C events. =head3 C This is almost identical to L|POE::Component::IRC/irc_mode>, except it is sent for each individual umode that is being set. =head1 CAVEATS The component gathers information by registering for C, C, C, C, C, C and various numeric replies. When the component is asked to join a channel, when it joins it will issue 'WHO #channel', 'MODE #channel', and 'MODE #channel b'. These will solicit between them the numerics, C, C and C, respectively. When someone joins a channel the bot is on, it issues a 'WHO nick'. You may want to ignore these. Currently, whenever the component sees a topic or channel list change, it will use C A basic bot demonstrating the basics of PoCo-IRC. =head3 L Add translating capabilities to your bot. =head3 L Have your bot resolve DNS records for you. =head3 L Allow your bot to talk, using artificial "intelligence". =head3 L Implement the "seen" feature found in many bots, which tells you when your bot last saw a particular user, and what they were doing/saying. =head3 L Structure your code in such a way that your bot can be reprogrammed at runtime without reconnecting to the IRC server. =head3 Feeds Use your bot as an RSS/Atom feed aggregator. =head3 Reminder Have your bot remind you about something at a later time. =head3 Messenger Have your bot deliver messages to users as soon as they become active. =head3 Eval Have your bot evaluate mathematical expressions and code. =head2 Clients =head3 L A simple IRC client with a Gtk2 interface. =head3 ReadLine A simple IRC client with a ReadLine interface. =head1 AUTHOR Hinrik Ern SigurEsson, hinrik.sig@gmail.com POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin.pm0000644000175000017500000002622413153565114021350 0ustar bingosbingospackage POE::Component::IRC::Plugin; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; require Exporter; use base qw(Exporter); our @EXPORT_OK = qw(PCI_EAT_NONE PCI_EAT_CLIENT PCI_EAT_PLUGIN PCI_EAT_ALL); our %EXPORT_TAGS = ( ALL => [@EXPORT_OK] ); use constant { PCI_EAT_NONE => 1, PCI_EAT_CLIENT => 2, PCI_EAT_PLUGIN => 3, PCI_EAT_ALL => 4, }; 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin - Provides plugin constants and documentation for L =head1 SYNOPSIS # A simple ROT13 'encryption' plugin package Rot13; use strict; use warnings; use POE::Component::IRC::Plugin qw( :ALL ); # Plugin object constructor sub new { my $package = shift; return bless {}, $package; } sub PCI_register { my ($self, $irc) = splice @_, 0, 2; $irc->plugin_register( $self, 'SERVER', qw(public) ); return 1; } # This is method is mandatory but we don't actually have anything to do. sub PCI_unregister { return 1; } sub S_public { my ($self, $irc) = splice @_, 0, 2; # Parameters are passed as scalar-refs including arrayrefs. my $nick = ( split /!/, ${ $_[0] } )[0]; my $channel = ${ $_[1] }->[0]; my $msg = ${ $_[2] }; if (my ($rot13) = $msg =~ /^rot13 (.+)/) { $rot13 =~ tr[a-zA-Z][n-za-mN-ZA-M]; # Send a response back to the server. $irc->yield( privmsg => $channel => $rot13 ); # We don't want other plugins to process this return PCI_EAT_PLUGIN; } # Default action is to allow other plugins to process it. return PCI_EAT_NONE; } =head1 DESCRIPTION POE::Component::IRC's plugin system has been released separately as L. Gleaning at its documentation is advised. The rest of this document mostly describes aspects that are specific to POE::Component::IRC's use of Object::Pluggable. =head1 HISTORY Certain individuals in #PoE on MAGNet said we didn't need to bloat the PoCo-IRC code... BinGOs, the current maintainer of the module, and I heartily agreed that this is a wise choice. One example: Look at the magnificent new feature in 3.4 -> irc_whois replies! Yes, that is a feature I bet most of us have been coveting for a while, as it definitely makes our life easier. It was implemented in 30 minutes or so after a request, the maintainer said. I replied by saying that it's a wonderful idea, but what would happen if somebody else asked for a new feature? Maybe thatfeature is something we all would love to have, so should it be put in the core? Plugins allow the core to stay lean and mean, while delegating additional functionality to outside modules. BinGOs' work with making PoCo-IRC inheritable is wonderful, but what if there were 2 modules which have features that you would love to have in your bot? Inherit from both? Imagine the mess... Here comes plugins to the rescue :) You could say Bot::Pluggable does the job, and so on, but if this feature were put into the core, it would allow PoCo-IRC to be extended beyond our wildest dreams, and allow the code to be shared amongst us all, giving us superior bug smashing abilities. Yes, there are changes that most of us will moan when we go update our bots to use the new C<$irc> object system, but what if we also used this opportunity to improve PoCo-IRC even more and give it a lifespan until Perl8 or whatever comes along? :) =head1 DESCRIPTION The plugin system works by letting coders hook into the two aspects of PoCo-IRC: =over =item * Data received from the server =item * User commands about to be sent to the server =back The goal of this system is to make PoCo-IRC so easy to extend, enabling it to Take Over The World! *Just Kidding* The general architecture of using the plugins should be: # Import the stuff... use POE; use POE::Component::IRC; use POE::Component::IRC::Plugin::ExamplePlugin; # Create our session here POE::Session->create( ... ); # Create the IRC session here my $irc = POE::Component::IRC->spawn() or die "Oh noooo! $!"; # Create the plugin # Of course it could be something like $plugin = MyPlugin->new(); my $plugin = POE::Component::IRC::Plugin::ExamplePlugin->new( ... ); # Hook it up! $irc->plugin_add( 'ExamplePlugin', $plugin ); # OOPS, we lost the plugin object! my $pluginobj = $irc->plugin_get( 'ExamplePlugin' ); # We want a list of plugins and objects my $hashref = $irc->plugin_list(); # Oh! We want a list of plugin aliases. my @aliases = keys %{ $irc->plugin_list() }; # Ah, we want to remove the plugin $plugin = $irc->plugin_del( 'ExamplePlugin' ); The plugins themselves will conform to the standard API described here. What they can do is limited only by imagination and the IRC RFC's ;) # Import the constants use POE::Component::IRC::Plugin qw( :ALL ); # Our constructor sub new { ... } # Required entry point for PoCo-IRC sub PCI_register { my ($self, $irc) = @_; # Register events we are interested in $irc->plugin_register( $self, 'SERVER', qw( 355 kick whatever) ); # Return success return 1; } # Required exit point for PoCo-IRC sub PCI_unregister { my ($self, $irc) = @_; # PCI will automatically unregister events for the plugin # Do some cleanup... # Return success return 1; } # Registered events will be sent to methods starting with IRC_ # If the plugin registered for SERVER - irc_355 sub S_355 { my($self, $irc, $line) = @_; # Remember, we receive pointers to scalars, so we can modify them $$line = 'frobnicate!'; # Return an exit code return PCI_EAT_NONE; } # Default handler for events that do not have a corresponding plugin # method defined. sub _default { my ($self, $irc, $event) = splice @_, 0, 3; print "Default called for $event\n"; # Return an exit code return PCI_EAT_NONE; } Plugins can even embed their own POE sessions if they need to do fancy stuff. Below is a template for a plugin which does just that. package POE::Plugin::Template; use POE; use POE::Component::IRC::Plugin qw( :ALL ); sub new { my $package = shift; my $self = bless {@_}, $package; return $self; } sub PCI_register { my ($self, $irc) = splice @_, 0, 2; # We store a ref to the $irc object so we can use it in our # session handlers. $self->{irc} = $irc; $irc->plugin_register( $self, 'SERVER', qw(blah blah blah) ); POE::Session->create( object_states => [ $self => [qw(_start _shutdown)], ], ); return 1; } sub PCI_unregister { my ($self, $irc) = splice @_, 0, 2; # Plugin is dying make sure our POE session does as well. $poe_kernel->call( $self->{SESSION_ID} => '_shutdown' ); delete $self->{irc}; return 1; } sub _start { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->{SESSION_ID} = $_[SESSION]->ID(); # Make sure our POE session stays around. Could use aliases but that is so messy :) $kernel->refcount_increment( $self->{SESSION_ID}, __PACKAGE__ ); return; } sub _shutdown { my ($kernel, $self) = @_[KERNEL, OBJECT]; $kernel->alarm_remove_all(); $kernel->refcount_decrement( $self->{SESSION_ID}, __PACKAGE__ ); return; } =head1 EVENT TYPES =head2 SERVER hooks Hooks that are targeted toward data received from the server will get the exact same arguments as if it was a normal event, look at the PoCo-IRC docs for more information. NOTE: Server methods are identified in the plugin namespace by the subroutine prefix of S_*. I.e. an irc_kick event handler would be: sub S_kick {} The only difference is instead of getting scalars, the hook will get a reference to the scalar, to allow it to mangle the data. This allows the plugin to modify data *before* they are sent out to registered sessions. They are required to return one of the L so PoCo-IRC will know what to do. =head3 Names of potential hooks 001 socketerr connected plugin_del ... Keep in mind that they are always lowercased. Check out the L section of POE::Component::IRC's documentation for the complete list of events. =head2 USER hooks These type of hooks have two different argument formats. They are split between data sent to the server, and data sent through DCC connections. NOTE: User methods are identified in the plugin namespace by the subroutine prefix of U_*. I.e. an irc_kick event handler would be: sub U_kick {} Hooks that are targeted to user data have it a little harder. They will receive a reference to the raw line about to be sent out. That means they will have to parse it in order to extract data out of it. The reasoning behind this is that it is not possible to insert hooks in every method in the C<$irc> object, as it will become unwieldy and not allow inheritance to work. The DCC hooks have it easier, as they do not interact with the server, and will receive references to the arguments specified in the DCC plugin L regarding dcc commands. =head3 Names of potential hooks kick dcc_chat ison privmsg ... Keep in mind that they are always lowercased, and are extracted from the raw line about to be sent to the irc server. To be able to parse the raw line, some RFC reading is in order. These are the DCC events that are not given a raw line, they are: dcc - $nick, $type, $file, $blocksize, $timeout dcc_accept - $cookie, $myfile dcc_resume - $cookie dcc_chat - $cookie, @lines dcc_close - $cookie =head2 _default If a plugin has registered for an event but doesn't have a hook method defined for ir, component will attempt to call a plugin's C<_default> method. The first parameter after the plugin and irc objects will be the handler name. sub _default { my ($self, $irc, $event) = splice @_, 0, 3; # $event will be something like S_public or U_dcc, etc. return PCI_EAT_NONE; } The C<_default> handler is expected to return one of the exit codes so PoCo-IRC will know what to do. =head1 EXIT CODES =head2 PCI_EAT_NONE This means the event will continue to be processed by remaining plugins and finally, sent to interested sessions that registered for it. =head2 PCI_EAT_CLIENT This means the event will continue to be processed by remaining plugins but it will not be sent to any sessions that registered for it. This means nothing will be sent out on the wire if it was an USER event, beware! =head2 PCI_EAT_PLUGIN This means the event will not be processed by remaining plugins, it will go straight to interested sessions. =head2 PCI_EAT_ALL This means the event will be completely discarded, no plugin or session will see it. This means nothing will be sent out on the wire if it was an USER event, beware! =head1 EXPORTS Exports the return constants for plugins to use in @EXPORT_OK Also, the ':ALL' tag can be used to get all of them. =head1 SEE ALSO L L L L =head1 AUTHOR Apocalypse =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Constants.pm0000644000175000017500000000311213153565114022055 0ustar bingosbingospackage POE::Component::IRC::Constants; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Constants::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; require Exporter; use base qw(Exporter); our @EXPORT_OK = qw( PCI_REFCOUNT_TAG PRI_LOGIN PRI_HIGH PRI_NORMAL MSG_PRI MSG_TEXT CMD_PRI CMD_SUB ); our %EXPORT_TAGS = ( ALL => [@EXPORT_OK] ); use constant { # The name of the reference count P::C::I keeps in client sessions. PCI_REFCOUNT_TAG => 'P::C::I registered', # Message priorities. PRI_LOGIN => 10, # PASS/NICK/USER messages must go first. PRI_HIGH => 20, # KICK/MODE etc. is more important than chatter. PRI_NORMAL => 30, # Random chatter. MSG_PRI => 0, # Queued message priority. MSG_TEXT => 1, # Queued message text. # RCC: Since most of the commands are data driven, I have moved their # event/handler maps here and added priorities for each data driven # command. The priorities determine message importance when messages # are queued up. Lower ones get sent first. CMD_PRI => 0, # Command priority. CMD_SUB => 1, # Command handler. }; 1; =encoding utf8 =head1 NAME POE::Component::IRC::Constants - Defines constants required by L =head1 SYNOPSIS use POE::Component::IRC::Constants qw(:ALL); =head1 DESCRIPTION POE::Component::IRC::Constants defines constants required by L and derived sub-classes. =head1 AUTHOR Chris Williams =head1 SEE ALSO L =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Projects.pod0000644000175000017500000000762113153565114022051 0ustar bingosbingos=encoding utf8 =head1 NAME POE::Component::IRC::Projects - A listing of projects that use L =head1 SYNOPSIS perldoc POE::Component::IRC::Projects =head1 DESCRIPTION POE::Component::IRC::Projects strives to document projects that are using L>. Projects can include subclasses, bot frameworks, bots, etc. The only stipulation for inclusion is that the project utilises L>. Inclusion to ( or inversely, exclusion from ) this list does not imply any sort of endorsement ( or disapproval ) of the said project. =head1 BOT FRAMEWORKS ( CPAN ) An alphabetically ordered list of bot frameworks, that are available on CPAN. =over =item L Amethyst is a bot core capable of handling parsing and routing of messages between connections and brains. Amethyst can handle an arbitrary number of connections of arbitrary types (given an appropriate module in Amethyst::Connection::*), routing these messages fairly arbitrarily through multiple processing cores (brains, live in Amethyst::Brain::*), and responding to these messages on other arbitrary connections. =item L Basic bot system designed to make it easy to do simple bots, optionally forking longer processes (like searches) concurrently in the background. =item L This is a very small (but important) part of a pluggable IRC bot framework. It provides the developer with a simply framework for writing Bot components as Perl modules. =item L Bot::BasicBot::Pluggable based replacement for the venerable infobot. =item L A complete bot, similar to eggdrop using POE::Component::IRC. Allows access to all channel user management modes. Provides !seen functions, a complete help system, logging, dcc chat interface, and it runs as a daemon process. IRC::Bot utilizes Cache::FileCache for seen functions, and for session handling. =item L ThreatNet::Bot::AmmoBot is the basic foot soldier of the ThreatNet bot ecosystem, fetching ammunition and bringing it to the channel. It connects to a single ThreatNet channel, and then tails one or more files scanning for threat messages while following the basic channel rules. =back =head1 EXTENSIONS ( CPAN ) =over =item L A POE::Component::IRC plugin that provides RSS headline retrieval. =item L A POE::Component::IRC plugin that finds URIs in channel traffic. =item L A POE::Component::IRC plugin that runs Acme::POE::Knee races. =item L A POE::Component::IRC plugin that provides blowfish encryption. =item L A plugin for finding, resolving .FLV, and optionally storing YouTube URIs. =item L A slightly simpler OO interface to PoCoIRC =item L This module implements a class that provides moved message and onjoin services as an IRC bot. Based on the configuration parameters passed to it via its constructor it will connect to a channel on a server and immediately send everyone on that channel a message privately. It will also send the same message to the channel itself publically at the specified interval. All users joining the channel thereafter will also receive the message. =back =head1 PROXIES / BOUNCERS ( CPAN ) =over =item L A featureful easy-to-use IRC bouncer. =back POE-Component-IRC-6.90/lib/POE/Component/IRC/Cookbook/0000755000175000017500000000000013153565114021314 5ustar bingosbingosPOE-Component-IRC-6.90/lib/POE/Component/IRC/Cookbook/Gtk2.pod0000644000175000017500000001462613153565114022640 0ustar bingosbingos=encoding utf8 =head1 NAME POE::Component::IRC::Cookbook::Gtk2 - An IRC client with a Gtk2 interface =head1 SYNOPSIS This example uses L and L to present an event-driven GUI to the user. =head1 DESCRIPTION #!/usr/bin/env perl use strict; use warnings; use Gtk2 -init; use Gtk2::SimpleList; use IRC::Utils qw(parse_user strip_color strip_formatting decode_irc); use POE qw(Loop::Glib Component::IRC::State Component::IRC::Plugin::Connector); my $channel = "#IRC.pm-test"; my $irc = POE::Component::IRC::State->spawn( nick => 'gtk-example', server => 'irc.perl.org', port => 6667, ircname => 'Testing', debug => 1, plugin_debug => 1, ) or die "Oh noooo! $!"; POE::Session->create( package_states => [ (__PACKAGE__) => [qw( _start ui_start ui_input ui_menu_quit ui_about ui_about_ok irc_start irc_001 irc_public irc_notice irc_chan_sync irc_nick_sync irc_join irc_msg irc_433 )], ], ); $poe_kernel->run(); my $messages; my $buffer; my $input; my $nicks; my $window; sub _start { $_[KERNEL]->yield('ui_start'); $_[KERNEL]->yield('irc_start'); } sub ui_start { my ($kernel, $session, $heap) = @_[KERNEL, SESSION, HEAP]; my $window = Gtk2::Window->new("toplevel"); $heap->{main_window} = $window; $kernel->signal_ui_destroy($heap->{main_window}); $heap->{main_window}->set_size_request(640, 480); my $box = Gtk2::VBox->new(0, 0); my $menu_file = Gtk2::Menu->new(); my $menu_quit = Gtk2::MenuItem->new('_Exit'); $menu_quit->signal_connect(activate => $session->postback('ui_menu_quit')); $menu_file->append($menu_quit); my $menu_help = Gtk2::Menu->new(); my $menu_about = Gtk2::MenuItem->new('_About'); $menu_about->signal_connect(activate => $session->postback('ui_about')); $menu_help->append($menu_about); my $menu_item_file = Gtk2::MenuItem->new('_Program'); my $menu_item_help = Gtk2::MenuItem->new('_Help'); $menu_item_file->set_submenu($menu_file); $menu_item_help->set_submenu($menu_help); my $menu_bar = Gtk2::MenuBar->new(); $menu_bar->append($menu_item_file); $menu_bar->append($menu_item_help); $box->pack_start($menu_bar, 0, 0, 0); $heap->{main_window}->add($box); my $hbox = Gtk2::HBox->new(0, 0); $box->pack_start($hbox, 1, 1, 0); $nicks = Gtk2::SimpleList->new('nickname', 'text'); $nicks->set_headers_visible(0); $nicks->set_size_request(120, -1); $messages = Gtk2::TextView->new(); $messages->set_editable(0); $messages->set_size_request(600, -1); $hbox->pack_start($messages, 1, 1, 0); $hbox->pack_start(Gtk2::VSeparator->new(), 0, 1, 4); $hbox->pack_start($nicks, 1, 1, 0); $messages->set_cursor_visible(0); $buffer = Gtk2::TextBuffer->new(); my $blue = $buffer->create_tag("fg_blue", foreground => "blue"); my $yellow = $buffer->create_tag("fg_yellow", foreground => "yellow"); my $orange = $buffer->create_tag("fg_orange", foreground => "orange"); my $pink = $buffer->create_tag("fg_pink", foreground => "pink"); my $red = $buffer->create_tag("fg_red", foreground => "red"); $messages->set_buffer($buffer); my $label = Gtk2::Label->new("Counter"); $heap->{counter} = 0; $heap->{counter_label} = Gtk2::Label->new($heap->{counter}); $input = Gtk2::Entry->new; $box->pack_start($input, 0, 0, 4); $heap->{main_window}->show_all(); $input->grab_focus(); $input->signal_connect(activate => $session->postback('ui_input')); } sub push_buffer { my ($start, $end) = $buffer->get_bounds(); my $text = strip_color(strip_formatting($_[0])); shift; $buffer->insert_with_tags_by_name($end, $text, @_); $messages->scroll_to_iter($end,0, 0, 0, 0); } sub ui_about { my $session = $_[SESSION]; my $dialog = Gtk2::MessageDialog->new( $window, 'destroy-with-parent', 'info', 'ok', "POE::Component::IRC with Gtk2 example\nAuthor: Damian Kaczmarek" ); $dialog->signal_connect(response => $session->postback('ui_about_ok')); $dialog->show(); } sub ui_input { my ($self, $response) = @{ $_[ARG1] }; my $input = $self->get_text(); return if $input eq ""; if (my ($target, $msg) = $input =~ /^\/msg (\S+) (.*)$/) { $irc->yield(privmsg => $target, $msg); push_buffer("-> $target -> $msg\n", "fg_red"); } else { $irc->yield(privmsg => $channel, $input); push_buffer('<'.$irc->nick_name()."> $input\n"); } $self->set_text(""); } sub ui_about_ok { my ($dialog, $response) = @{ $_[ARG1] }; $dialog->destroy; } sub ui_menu_quit { $_[HEAP]{main_window}->destroy(); } sub irc_start { $irc->plugin_add('Connector', POE::Component::IRC::Plugin::Connector->new()); $irc->yield(register => 'all'); $irc->yield('connect' ); } sub irc_msg { my ($user, $recipients, $text) = @_[ARG0..ARG2]; my $nick = parse_user($user); push_buffer("PRIV <$nick> $text\n", "fg_red"); } sub irc_join { my ($user, $channel) = (@_[ARG0..ARG1]); my ($nick, $username, $host) = parse_user($user); push_buffer("$nick ($host) joined $channel\n", "fg_pink"); } sub irc_chan_sync { @{$nicks->{data}} = map { [$_] } $irc->channel_list($channel); push_buffer("Synchronized to $channel!\n"); } sub irc_nick_sync { @{$nicks->{data}} = map { [$_] } $irc->channel_list($channel); } sub irc_001 { push_buffer("Connected to IRC server!\n"); $irc->yield(join => $channel); } sub irc_notice { my ($user, $recipients, $text) = @_[ARG0..ARG2]; my $nick = parse_user($user); $text = decode_irc($text); push_buffer("$nick : $text\n", "fg_orange"); } sub irc_public { my ($user, $where, $what) = @_[ARG0 .. ARG2]; my $nick = parse_user($user); $what = decode_irc($what); push_buffer("<$nick> $what\n"); } sub irc_433 { my $new_nick = $irc->nick_name() . "_"; $irc->yield(nick => $new_nick); push_buffer("433 Nick taken ... changing to $new_nick\n", "fg_orange"); } =head1 AUTHOR Damian Kaczmarek POE-Component-IRC-6.90/lib/POE/Component/IRC/Cookbook/Reload.pod0000644000175000017500000000145613153565114023234 0ustar bingosbingos=encoding utf8 =head1 NAME POE::Component::IRC::Cookbook::Reload - Reload your bot's code after a change =head1 SYNOPSIS Wouldn't it be neat if you could update your bot's code, and have the changes be applied without dropping the connection to the IRC server? =head1 DESCRIPTION At first, this might seem complicated. You might have to mess with C/C, deal with scoping issues and what not. But when you really think about it, all you need is an IRC proxy. Let the proxy handle the IRC connection, and let the bot run as a separate process which you can restart at will. L itself can act as a proxy. See the L plugin for details. =head1 AUTHOR Hinrik Ern SigurEsson, hinrik.sig@gmail.com POE-Component-IRC-6.90/lib/POE/Component/IRC/Cookbook/Hailo.pod0000644000175000017500000000235613153565114023062 0ustar bingosbingos=encoding utf8 =head1 NAME POE::Component::IRC::Cookbook::Hailo - A blabbering IRC bot =head1 SYNOPSIS This bot uses L for most of its magic. As of yet, this recipe just contains a SYNOPSIS that is copied from its documentation. =head1 DESCRIPTION #!/usr/bin/env perl use strict; use warnings; use POE; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::IRC::Plugin::Connector; use POE::Component::IRC::Plugin::Hailo; use POE::Component::IRC::State; my $irc = POE::Component::IRC::State->spawn( nick => 'Brainy', server => 'irc.freenode.net', ); my @channels = ('#public_chan', '#bot_chan'); $irc->plugin_add('AutoJoin', POE::Component::IRC::Plugin::AutoJoin->new(Channels => \@channels)); $irc->plugin_add('Connector', POE::Component::IRC::Plugin::Connector->new()); $irc->plugin_add('Hailo', POE::Component::IRC::Plugin::Hailo->new( Own_channel => '#bot_chan', Ignore_regexes => [ qr{\w+://\w} ], # ignore lines containing URLs Hailo_args => { brain_resource => 'brain.sqlite', }, )); $irc->yield('connect'); $poe_kernel->run(); =head1 AUTHOR Hinrik Ern SigurEsson, hinrik.sig@gmail.com POE-Component-IRC-6.90/lib/POE/Component/IRC/Cookbook/Seen.pod0000644000175000017500000001000313153565114022704 0ustar bingosbingos=encoding utf8 =head1 NAME POE::Component::IRC::Cookbook::Seen - Implement the 'seen' command =head1 SYNOPSIS This little bot tracks the whereabouts of users and allows you to retrieve that information on command. 19:59:51 * seen_bot (n=hinrik@pool-71-164-43-32.chrlwv.east.verizon.net) has joined #test_channel1 19:59:55 bar 20:00:16 * seen_bot has quit (Remote closed the connection) 20:00:27 * seen_bot (n=hinrik@pool-71-164-43-32.chrlwv.east.verizon.net) has joined #test_channel1 20:00:29 seen_bot: seen seen_bot 20:00:29 literal: I last saw seen_bot at Mon Sep 22 20:00:27 2008 joining #test_channel1 20:00:34 seen_bot: seen foo 20:00:40 literal: I last saw foo at Mon Sep 22 19:59:56 2008 on #test_channel1 saying: bar 20:00:45 seen_bot: seen baz 20:00:48 literal: I haven't seen baz =head1 DESCRIPTION #!/usr/bin/env perl use strict; use warnings; use IRC::Utils qw(parse_user lc_irc); use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::IRC::Plugin::BotCommand; use Storable; use constant { USER_DATE => 0, USER_MSG => 1, DATA_FILE => 'seen', SAVE_INTERVAL => 20 * 60, # save state every 20 mins }; my $seen = { }; $seen = retrieve(DATA_FILE) if -s DATA_FILE; POE::Session->create( package_states => [ main => [ qw( _start irc_botcmd_seen irc_ctcp_action irc_join irc_part irc_public irc_quit save )] ], ); $poe_kernel->run(); sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; my $irc = POE::Component::IRC::State->spawn( Nick => 'seen_bot', Server => 'irc.freenode.net', ); $heap->{irc} = $irc; $irc->plugin_add('AutoJoin', POE::Component::IRC::Plugin::AutoJoin->new( Channels => [ '#test_channel1', '#test_channel2' ] )); $irc->plugin_add('BotCommand', POE::Component::IRC::Plugin::BotCommand->new( Commands => { seen => 'Usage: seen ' } )); $irc->yield(register => qw(ctcp_action join part public quit botcmd_seen)); $irc->yield('connect'); $kernel->delay_set('save', SAVE_INTERVAL); return; } sub save { my $kernel = $_[KERNEL]; warn "storing\n"; store($seen, DATA_FILE) or die "Can't save state"; $kernel->delay_set('save', SAVE_INTERVAL); } sub irc_ctcp_action { my $nick = parse_user($_[ARG0]); my $chan = $_[ARG1]->[0]; my $text = $_[ARG2]; add_nick($nick, "on $chan doing: * $nick $text"); } sub irc_join { my $nick = parse_user($_[ARG0]); my $chan = $_[ARG1]; add_nick($nick, "joining $chan"); } sub irc_part { my $nick = parse_user($_[ARG0]); my $chan = $_[ARG1]; my $text = $_[ARG2]; my $msg = 'parting $chan'; $msg .= " with message '$text'" if defined $text; add_nick($nick, $msg); } sub irc_public { my $nick = parse_user($_[ARG0]); my $chan = $_[ARG1]->[0]; my $text = $_[ARG2]; add_nick($nick, "on $chan saying: $text"); } sub irc_quit { my $nick = parse_user($_[ARG0]); my $text = $_[ARG1]; my $msg = 'quitting'; $msg .= " with message '$text'" if defined $text; add_nick($nick, $msg); } sub add_nick { my ($nick, $msg) = @_; $seen->{lc_irc($nick)} = [time, $msg]; } sub irc_botcmd_seen { my ($heap, $nick, $channel, $target) = @_[HEAP, ARG0..$#_]; $nick = parse_user($nick); my $irc = $heap->{irc}; if ($seen->{lc_irc($target)}) { my $date = localtime $seen->{lc_irc($target)}->[USER_DATE]; my $msg = $seen->{lc_irc($target)}->[USER_MSG]; $irc->yield(privmsg => $channel, "$nick: I last saw $target at $date $msg"); } else { $irc->yield(privmsg => $channel, "$nick: I haven't seen $target"); } } =head1 AUTHOR Hinrik Ern SigurEsson, hinrik.sig@gmail.com POE-Component-IRC-6.90/lib/POE/Component/IRC/Cookbook/Resolver.pod0000644000175000017500000000426213153565114023625 0ustar bingosbingos=encoding utf8 =head1 NAME POE::Component::IRC::Cookbook::Resolver - A bot that can resolve DNS records =head1 SYNOPSIS This bot uses L to DNS records for channel members. =head1 DESCRIPTION #!/usr/bin/env perl use strict; use warnings; use IRC::Utils qw(parse_user); use POE; use POE::Component::Client::DNS; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::IRC::Plugin::BotCommand; POE::Session->create( package_states => [ main => [ qw(_start irc_botcmd_resolve dns_response) ] ], ); $poe_kernel->run(); sub _start { my $heap = $_[HEAP]; my $irc = POE::Component::IRC::State->spawn( Nick => 'resolver_bot', Server => 'irc.freenode.net', ); $heap->{irc} = $irc; $irc->plugin_add('AutoJoin', POE::Component::IRC::Plugin::AutoJoin->new( Channels => [ '#test_channel1', '#test_channel2' ] )); $irc->plugin_add('BotCommand', POE::Component::IRC::Plugin::BotCommand->new( Commands => { resolve => 'Usage: resolve ' } )); $heap->{dns} = POE::Component::Client::DNS->spawn(); $irc->yield(register => 'botcmd_resolve'); $irc->yield('connect'); return; } sub irc_botcmd_resolve { my $dns = $_[HEAP]->{dns}; my $nick = parse_user( $_[ARG0] ); my ($channel, $host) = @_[ARG1, ARG2]; my $res = $dns->resolve( event => 'dns_response', host => $host, context => { channel => $channel, nick => $nick, }, ); $poe_kernel->yield(dns_response => $res) if $res; return; } sub dns_response { my $irc = $_[HEAP]->{irc}; my $res = $_[ARG0]; my @answers = $res->{response} ? map { $_->rdatastr } $res->{response}->answer() : (); $irc->yield( 'privmsg', $res->{context}->{channel}, $res->{context}->{nick} . (@answers ? ": @answers" : ': no answers for "' . $res->{host} . '"') ); return; } =head1 AUTHOR Hinrik Ern SigurEsson, hinrik.sig@gmail.com POE-Component-IRC-6.90/lib/POE/Component/IRC/Cookbook/Disconnecting.pod0000644000175000017500000000240213153565114024605 0ustar bingosbingos=encoding utf8 =head1 NAME POE::Component::IRC::Cookbook::Disconnecting - How to disconnect gracefully with PoCo-IRC =head1 SYNOPSIS Shutting down an IRC bot can be quick and messy, or slow and graceful. =head1 DESCRIPTION There are two ways you can shut down an IRC bot/client. The quick and dirty way is rather simple: exit; It exits the program, shutting down the socket, and everybody online sees yet another "Connection reset by peer" or "Remote end closed the socket" or something. As of version 6.50, all you need to do in order to shut down gracefully is to send a L|POE::Component::IRC/shutdown> event to the IRC component. It will make sure your quit message (if any) gets delivered, and will forcibly disconnect if there are any problems (faulty server or network issues). After doing this, it will unregister all sessions and clean up after itself. If you want to do something more elaborate on your own, take a look at the following documentation: L, L|POE::Component::IRC/connected>, L|POE::Component::IRC/quit>, L|POE::Component::IRC/disconnect>, and L|POE::Component::IRC/unregister>. =head1 AUTHOR Rocco Caputo and Hinrik Ern SigurEsson. POE-Component-IRC-6.90/lib/POE/Component/IRC/Cookbook/Translator.pod0000644000175000017500000000546413153565114024162 0ustar bingosbingos=encoding utf8 =head1 NAME POE::Component::IRC::Cookbook::Translator - A bot that can translate text =head1 SYNOPSIS This bot uses L to translate text for channel members. It makes use of the C plugin to handle the translate command. =head1 DESCRIPTION #!/usr/bin/env perl use strict; use warnings; use Encode qw(decode); use Encode::Guess; use IRC::Utils qw(decode_irc parse_user); use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; use POE::Component::IRC::Plugin::BotCommand; use POE::Component::Lingua::Translate; POE::Session->create( package_states => [ main => [ qw(_start irc_botcmd_trans translated) ] ], heap => { translators => { }, } ); $poe_kernel->run(); sub _start { my $heap = $_[HEAP]; my $irc = POE::Component::IRC::State->spawn( Nick => 'translator_bot', Server => 'irc.freenode.net', ); $heap->{irc} = $irc; $irc->plugin_add('AutoJoin', POE::Component::IRC::Plugin::AutoJoin->new( Channels => [ '#test_channel1', '#test_channel2' ] )); $irc->plugin_add('BotCommand', POE::Component::IRC::Plugin::BotCommand->new( Commands => { trans => 'Usage: trans , ' } )); $irc->yield(register => 'botcmd_trans'); $irc->yield('connect'); return; } sub irc_botcmd_trans { my $heap = $_[HEAP]; my $irc = $heap->{irc}; my $nick = parse_user( $_[ARG0] ); my $channel = $_[ARG1]; my ($from, $to, $text) = split /,|\s+/, $_[ARG2], 3; if (!exists $heap->{translators}->{$from . $to}) { eval { $heap->{translators}->{$from . $to} = POE::Component::Lingua::Translate->new( alias => $from . $to, back_end => 'Babelfish', src => $from, dest => $to, ); }; if ($@) { $irc->yield(privmsg => $channel, "$nick: There was an error: $@"); return; } } $poe_kernel->post($from . $to => translate => decode_irc($text), { channel => $channel, nick => $nick, } ); return; } sub translated { my $irc = $_[HEAP]->{irc}; my ($text, $context, $error) = @_[ARG0, ARG1, ARG2]; if ($error) { $irc->yield( 'privmsg', $context->{channel}, $context->{nick} . ": There was an error: $error", ); return; } $irc->yield( 'privmsg', $context->{channel}, $context->{nick} . ': ' . $text, ); return; } =head1 AUTHOR Hinrik Ern SigurEsson, hinrik.sig@gmail.com POE-Component-IRC-6.90/lib/POE/Component/IRC/Cookbook/BasicBot.pod0000644000175000017500000000355213153565114023513 0ustar bingosbingos=encoding utf8 =head1 NAME POE::Component::IRC::Cookbook::BasicBot - A basic IRC bot =head1 SYNOPSIS This a very basic bot that connects to IRC, joins a few channels, and announces its arrival. =head1 DESCRIPTION We start off quite simply: #!/usr/bin/env perl use strict; use warnings; Then we C the stuff we're going to...well, use. C<::State> is a subclass which keeps track of state information related to channels and nicknames. It is needed by the C plugin which takes care of keeping us on our channels. use POE; use POE::Component::IRC::State; use POE::Component::IRC::Plugin::AutoJoin; Next up is our POE session. We create it and list our event handlers. We then start the POE kernel. POE::Session->create( package_states => [ main => [ qw(_start irc_join) ] ] ); $poe_kernel->run(); Now all we have to do is write the handlers for C<_start> and C. In C<_start>, we create our IRC component, add an C plugin, register for the C event, and connect to the IRC server. sub _start { my $irc = POE::Component::IRC::State->spawn( Nick => 'basic_bot', Server => 'irc.freenode.net', ); $irc->plugin_add('AutoJoin', POE::Component::IRC::Plugin::AutoJoin->new( Channels => [ '#test_channel1', '#test_channel2' ] )); $irc->yield(register => 'join'); $irc->yield('connect'); } Now comes our C event handler. We send a message to the channel once we've joined it. sub irc_join { my $nick = (split /!/, $_[ARG0])[0]; my $channel = $_[ARG1]; my $irc = $_[SENDER]->get_heap(); # only send the message if we were the one joining if ($nick eq $irc->nick_name()) { $irc->yield(privmsg => $channel, 'Hi everybody!'); } } That's it! =head1 AUTHOR Hinrik Ern SigurEsson, hinrik.sig@gmail.com POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/0000755000175000017500000000000013153565114021004 5ustar bingosbingosPOE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/NickServID.pm0000644000175000017500000000643113153565114023307 0ustar bingosbingospackage POE::Component::IRC::Plugin::NickServID; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::NickServID::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use IRC::Utils qw( uc_irc parse_user ); use POE::Component::IRC::Plugin qw( :ALL ); sub new { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %self = @_; die "$package requires a Password" if !defined $self{Password}; return bless \%self, $package; } sub PCI_register { my ($self, $irc) = @_; $self->{nick} = $irc->{nick}; $self->{irc} = $irc; $irc->plugin_register($self, 'SERVER', qw(isupport nick notice)); return 1; } sub PCI_unregister { return 1; } # we identify after S_isupport so that pocoirc has a chance to turn on # CAPAB IDENTIFY-MSG (if the server supports it) before the AutoJoin # plugin joins channels sub S_isupport { my ($self, $irc) = splice @_, 0, 2; $irc->yield(nickserv => "IDENTIFY $self->{Password}"); return PCI_EAT_NONE; } sub S_nick { my ($self, $irc) = splice @_, 0, 2; my $mapping = $irc->isupport('CASEMAPPING'); my $new_nick = uc_irc( ${ $_[1] }, $mapping ); if ( $new_nick eq uc_irc($self->{nick}, $mapping) ) { $irc->yield(nickserv => "IDENTIFY $self->{Password}"); } return PCI_EAT_NONE; } sub S_notice { my ($self, $irc) = splice @_, 0, 2; my $sender = parse_user(${ $_[0] }); my $recipient = parse_user(${ $_[1] }->[0]); my $msg = ${ $_[2] }; return PCI_EAT_NONE if $recipient ne $irc->nick_name(); return PCI_EAT_NONE if $sender !~ /^nickserv$/i; return PCI_EAT_NONE if $msg !~ /now (?:identified|recognized)/; $irc->send_event_next('irc_identified'); return PCI_EAT_NONE; } # ERR_NICKNAMEINUSE sub S_433 { my ($self, $irc) = splice @_, 0, 2; my $offending = ${ $_[2] }->[0]; my $reason = ${ $_[2] }->[1]; if ($irc->nick_name() eq $offending && $reason eq "Nickname is registered to someone else") { $irc->yield(nickserv => "IDENTIFY $self->{Password}"); } return PCI_EAT_NONE; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::NickServID - A PoCo-IRC plugin which identifies with NickServ when needed =head1 SYNOPSIS use POE::Component::IRC::Plugin::NickServID; $irc->plugin_add( 'NickServID', POE::Component::IRC::Plugin::NickServID->new( Password => 'opensesame' )); =head1 DESCRIPTION POE::Component::IRC::Plugin::NickServID is a L plugin. It identifies with NickServ on connect and when you change your nick, if your nickname matches the supplied password. B: If you have a cloak and you don't want to be seen without it, make sure you don't join channels until after you've identified yourself. If you use the L, it will be taken care of for you. =head1 METHODS =head2 C Arguments: 'Password', the NickServ password. Returns a plugin object suitable for feeding to L's plugin_add() method. =head1 OUTPUT EVENTS =head2 C This event will be sent when you have identified with NickServ. No arguments are passed with it. =head1 AUTHOR Hinrik Ern SigurEsson, hinrik.sig@gmail.com =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/FollowTail.pm0000644000175000017500000001263113153565114023421 0ustar bingosbingospackage POE::Component::IRC::Plugin::FollowTail; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::FollowTail::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use File::Glob ':glob'; use File::Spec::Functions 'rel2abs'; use POE qw(Wheel::FollowTail); use POE::Component::IRC::Plugin qw( :ALL ); sub new { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %args = @_; $args{lc $_} = delete $args{$_} for keys %args; die "$package requires a 'filename' attribute" if !defined $args{filename}; $args{filename} = bsd_glob($args{filename}); die "File '$args{filename}' does not exist" if !-e $args{filename}; $args{filename} = rel2abs($args{filename}); return bless \%args, $package; } sub PCI_register { my ($self, $irc) = splice @_, 0, 2; $self->{irc} = $irc; POE::Session->create( object_states => [ $self => [ qw(_start _shutdown _input _error _reset) ], ], ); return 1; } sub PCI_unregister { my ($self, $irc) = splice @_, 0, 2; delete $self->{irc}; $poe_kernel->post( $self->{session_id} => '_shutdown' ); $poe_kernel->refcount_decrement( $self->{session_id}, __PACKAGE__ ); return 1; } sub _start { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->{session_id} = $_[SESSION]->ID(); $kernel->refcount_increment( $self->{session_id}, __PACKAGE__ ); $self->{wheel} = POE::Wheel::FollowTail->new( Filename => $self->{filename}, InputEvent => '_input', ErrorEvent => '_error', ResetEvent => '_reset', ( defined $self->{filter} && $self->{filter}->isa('POE::Filter') ? ( Filter => $self->{filter} ) : () ), ); return; } sub _shutdown { my ($kernel, $self, $term) = @_[KERNEL, OBJECT, ARG0]; delete $self->{wheel}; $kernel->refcount_decrement( $self->{session_id}, __PACKAGE__ ) if $term; return; } sub _input { my ($kernel, $self, $input) = @_[KERNEL, OBJECT, ARG0]; $self->{irc}->send_event( 'irc_tail_input', $self->{filename}, $input ); return; } sub _error { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->{irc}->send_event( 'irc_tail_error', $self->{filename}, @_[ARG0..ARG2] ); $kernel->yield('_shutdown','TERM'); return; } sub _reset { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->{irc}->send_event( 'irc_tail_reset', $self->{filename} ); return; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::FollowTail - A PoCo-IRC plugin to follow the tail of an ever-growing file =head1 SYNOPSIS use POE qw(Component::IRC Component::IRC::Plugin::FollowTail); my $nickname = 'Flibble' . $$; my $ircname = 'Flibble the Sailor Bot'; my $ircserver = 'irc.blahblahblah.irc'; my $filename = '/some/such/file/here'; my @channels = ( '#Blah', '#Foo', '#Bar' ); my $irc = POE::Component::IRC->spawn( nick => $nickname, server => $ircserver, port => $port, ircname => $ircname, ) or die "Oh noooo! $!"; POE::Session->create( package_states => [ main => [ qw(_start irc_001 irc_tail_input irc_tail_error irc_tail_reset) ], ], ); $poe_kernel->run(); sub _start { $irc->plugin_add( 'FollowTail' => POE::Component::IRC::Plugin::FollowTail->new( filename => $filename, )); $irc->yield( register => 'all' ); $irc->yield( connect => { } ); return; } sub irc_001 { $irc->yield( join => $_ ) for @channels; return; } sub irc_tail_input { my ($kernel, $sender, $filename, $input) = @_[KERNEL, SENDER, ARG0, ARG1]; $kernel->post( $sender, 'privmsg', $_, "$filename: $input" ) for @channels; return; } sub irc_tail_error { my ($kernel, $sender, $filename, $errnum, $errstring) = @_[KERNEL, SENDER, ARG0 .. ARG2]; $kernel->post( $sender, 'privmsg', $_, "$filename: ERROR: $errnum $errstring" ) for @channels; $irc->plugin_del( 'FollowTail' ); return; } sub irc_tail_reset { my ($kernel, $sender, $filename) = @_[KERNEL, SENDER, ARG0]; $kernel->post( $sender, 'privmsg', $_, "$filename: RESET EVENT" ) for @channels; return; } =head1 DESCRIPTION POE::Component::IRC::Plugin::FollowTail is a L plugin that uses L to follow the end of an ever-growing file. It generates C prefixed events for each new record that is appended to its file. =head1 METHODS =head2 C Takes two arguments: B<'filename'>, the name of the file to tail, mandatory; B<'filter'>, a POE::Filter object to pass to POE::Wheel::FollowTail, optional; Returns a plugin object suitable for feeding to L's C method. =head1 OUTPUT EVENTS The plugin generates the following additional L events: =head2 C Emitted for every complete record read. C will be the filename, C the record which was read. =head2 C Emitted whenever an error occurs. C will be the filename, C and C hold numeric and string values for $!, respectively. =head2 C Emitted every time a file is reset. C will be the filename. =head1 AUTHOR Chris 'BinGOs' Williams =head1 SEE ALSO L L =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/BotTraffic.pm0000644000175000017500000000646713153565114023402 0ustar bingosbingospackage POE::Component::IRC::Plugin::BotTraffic; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::BotTraffic::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use POE::Component::IRC::Plugin qw( :ALL ); use POE::Filter::IRCD; use POE::Filter::IRC::Compat; sub new { my ($package) = @_; return bless { }, $package; } sub PCI_register { my ($self, $irc) = splice @_, 0, 2; $self->{filter} = POE::Filter::IRCD->new(); $self->{compat} = POE::Filter::IRC::Compat->new(); $irc->plugin_register( $self, 'USER', qw(privmsg notice) ); return 1; } sub PCI_unregister { return 1; } sub U_notice { my ($self, $irc) = splice @_, 0, 2; my $output = ${ $_[0] }; my $line = $self->{filter}->get([ $output ])->[0]; my $text = $line->{params}->[1]; my $targets = [ split(/,/, $line->{params}->[0]) ]; $irc->send_event_next(irc_bot_notice => $targets => $text); return PCI_EAT_NONE; } sub U_privmsg { my ($self, $irc) = splice @_, 0, 2; my $output = ${ $_[0] }; my $line = $self->{filter}->get([ $output ])->[0]; my $text = $line->{params}->[1]; if ($text =~ /^\001/) { my $ctcp_event = $self->{compat}->get([$line])->[0]; return PCI_EAT_NONE if $ctcp_event->{name} ne 'ctcp_action'; $irc->send_event_next(irc_bot_action => @{ $ctcp_event->{args} }[1..2]); } else { my $chantypes = join('', @{ $irc->isupport('CHANTYPES') || ['#', '&']}); for my $recipient ( split(/,/, $line->{params}->[0]) ) { my $event = 'irc_bot_msg'; $event = 'irc_bot_public' if $recipient =~ /^[$chantypes]/; $irc->send_event_next($event => [ $recipient ] => $text); } } return PCI_EAT_NONE; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::BotTraffic - A PoCo-IRC plugin that generates events when you send messages =head1 SYNOPSIS use POE::Component::IRC::Plugin::BotTraffic; $irc->plugin_add( 'BotTraffic', POE::Component::IRC::Plugin::BotTraffic->new() ); sub irc_bot_public { my ($kernel, $heap) = @_[KERNEL, HEAP]; my $channel = $_[ARG0]->[0]; my $what = $_[ARG1]; print "I said '$what' on channel $channel\n"; return; } =head1 DESCRIPTION POE::Component::IRC::Plugin::BotTraffic is a L plugin. It watches for when your bot sends PRIVMSGs and NOTICEs to the server and generates the appropriate events. These events are useful for logging what your bot says. =head1 METHODS =head2 C No arguments required. Returns a plugin object suitable for feeding to L's C method. =head1 OUTPUT EVENTS These are the events generated by the plugin. Both events have C set to an arrayref of recipients and C the text that was sent. =head2 C C will be an arrayref of recipients. C will be the text sent. =head2 C C will be an arrayref of recipients. C will be the text sent. =head2 C C will be an arrayref of recipients. C will be the text sent. =head2 C C will be an arrayref of recipients. C will be the text sent. =head1 AUTHOR Chris 'BinGOs' Williams [chris@bingosnet.co.uk] =head1 SEE ALSO L =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/Connector.pm0000644000175000017500000001466313153565114023306 0ustar bingosbingospackage POE::Component::IRC::Plugin::Connector; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::Connector::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use POE; use POE::Component::IRC::Plugin qw( :ALL ); sub new { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %args = @_; $args{ lc $_ } = delete $args{$_} for keys %args; $args{lag} = 0; return bless \%args, $package; } sub PCI_register { my ($self, $irc) = splice @_, 0, 2; $self->{irc} = $irc; POE::Session->create( object_states => [ $self => [ qw(_start _auto_ping _reconnect _shutdown _start_ping _start_time_out _stop_ping _time_out) ], ], ); $irc->raw_events(1); $irc->plugin_register( $self, 'SERVER', qw(connected disconnected 001 error socketerr pong raw) ); return 1; } sub PCI_unregister { my ($self, $irc) = splice @_, 0, 2; delete $self->{irc}; $poe_kernel->post( $self->{SESSION_ID} => '_shutdown' ); $poe_kernel->refcount_decrement( $self->{SESSION_ID}, __PACKAGE__ ); return 1; } sub S_connected { my ($self, $irc) = splice @_, 0, 2; $poe_kernel->post( $self->{SESSION_ID}, '_start_time_out' ); return PCI_EAT_NONE; } sub S_001 { my ($self, $irc) = splice @_, 0, 2; $poe_kernel->post( $self->{SESSION_ID}, '_start_ping' ); return PCI_EAT_NONE; } sub S_disconnected { my ($self, $irc) = splice @_, 0, 2; $poe_kernel->post( $self->{SESSION_ID}, '_stop_ping' ); $poe_kernel->post( $self->{SESSION_ID}, '_reconnect' ); return PCI_EAT_NONE; } sub S_error { my ($self, $irc) = splice @_, 0, 2; $poe_kernel->post( $self->{SESSION_ID}, '_stop_ping' ); $poe_kernel->post( $self->{SESSION_ID}, '_reconnect' ); return PCI_EAT_NONE; } sub S_socketerr { my ($self, $irc) = splice @_, 0, 2; $poe_kernel->post( $self->{SESSION_ID}, '_stop_ping' ); $poe_kernel->post( $self->{SESSION_ID}, '_reconnect' ); return PCI_EAT_NONE; } sub S_pong { my ($self, $irc) = splice @_, 0, 2; my $ping = shift @{ $self->{pings} }; return PCI_EAT_NONE if !$ping; $self->{lag} = time() - $ping; $self->{seen_traffic} = 1; return PCI_EAT_NONE; } sub S_raw { my ($self,$irc) = splice @_, 0, 2; $self->{seen_traffic} = 1; return PCI_EAT_NONE; } sub lag { return $_[0]->{lag}; } sub _start { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->{SESSION_ID} = $_[SESSION]->ID(); $kernel->refcount_increment( $self->{SESSION_ID}, __PACKAGE__ ); $kernel->yield( '_start_ping' ) if $self->{irc}->connected(); return; } sub _start_ping { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->{pings} = [ ]; $kernel->delay( '_time_out' => undef ); $kernel->delay( '_auto_ping' => $self->{delay} || 300 ); return; } sub _auto_ping { my ($kernel, $self) = @_[KERNEL, OBJECT]; if (!$self->{seen_traffic}) { my $time = time(); $self->{irc}->yield( 'ping' => $time ); push @{ $self->{pings} }, $time; } $self->{seen_traffic} = 0; $kernel->yield( '_start_ping' ); return; } sub _stop_ping { my ($kernel, $self) = @_[KERNEL, OBJECT]; delete $self->{pings}; $kernel->delay( '_auto_ping' => undef ); $kernel->delay( '_time_out' => undef ); return; } sub _shutdown { my ($kernel,$self) = @_[KERNEL, OBJECT]; $kernel->yield( '_stop_ping' ); $kernel->delay('_reconnect'); return; } sub _reconnect { my ($kernel, $self, $session, $sender) = @_[KERNEL, OBJECT, SESSION, SENDER]; my %args; if (ref $self->{servers} eq 'ARRAY' && @{ $self->{servers} }) { @args{qw(Server Port)} = @{ $self->{servers}->[0] }; push @{ $self->{servers} }, shift @{ $self->{servers} }; } if ($sender eq $session) { $self->{irc}->yield('connect' => %args); } else { $kernel->delay( '_reconnect' => $self->{reconnect} || 60 ); } return; } sub _start_time_out { my ($kernel, $self) = @_[KERNEL, OBJECT]; $kernel->delay( '_time_out' => $self->{timeout} || 60 ); return; } sub _time_out { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->{irc}->disconnect(); return; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::Connector - A PoCo-IRC plugin that deals with the messy business of staying connected to an IRC server =head1 SYNOPSIS use POE qw(Component::IRC Component::IRC::Plugin::Connector); my $irc = POE::Component::IRC->spawn(); POE::Session->create( package_states => [ main => [ qw(_start lag_o_meter) ], ], ); $poe_kernel->run(); sub _start { my ($kernel, $heap) = @_[KERNEL ,HEAP]; $irc->yield( register => 'all' ); $heap->{connector} = POE::Component::IRC::Plugin::Connector->new(); $irc->plugin_add( 'Connector' => $heap->{connector} ); $irc->yield ( connect => { Nick => 'testbot', Server => 'someserver.com' } ); $kernel->delay( 'lag_o_meter' => 60 ); return; } sub lag_o_meter { my ($kernel,$heap) = @_[KERNEL,HEAP]; print 'Time: ' . time() . ' Lag: ' . $heap->{connector}->lag() . "\n"; $kernel->delay( 'lag_o_meter' => 60 ); return; } =head1 DESCRIPTION POE::Component::IRC::Plugin::Connector is a L plugin that deals with making sure that your IRC bot stays connected to the IRC network of your choice. It implements the general algorithm as demonstrated at L. =head1 METHODS =head2 C Takes two optional arguments: B<'delay'>, the frequency, in seconds, at which the plugin will ping the IRC server. Defaults to 300. B<'reconnect'>, the time in seconds, to wait before trying to reconnect to the server. Defaults to 60. B<'servers'>, an array reference of IRC servers to consider. Each element should be an array reference containing a server host and (optionally) a port number. The plugin will cycle through this list of servers whenever it reconnects. Returns a plugin object suitable for use in L's C method. =head2 C Returns the current 'lag' in seconds between sending PINGs to the IRC server and getting PONG responses. Probably not likely to be wholely accurate. =head1 AUTHOR Chris "BinGOs" Williams =head1 SEE ALSO L L =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/DCC.pm0000644000175000017500000006145313153565114021744 0ustar bingosbingospackage POE::Component::IRC::Plugin::DCC; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::DCC::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use File::Basename qw(fileparse); use File::Glob ':glob'; use File::Spec::Functions 'rel2abs'; use POE qw(Driver::SysRW Filter::Line Filter::Stream Wheel::ReadWrite Wheel::SocketFactory); use POE::Component::IRC::Plugin qw(:ALL); use Socket qw(INADDR_ANY unpack_sockaddr_in inet_aton inet_ntoa); use constant { OUT_BLOCKSIZE => 1024, # Send DCC data in 1k chunks IN_BLOCKSIZE => 10_240, # 10k per DCC socket read LISTEN_TIMEOUT => 300, # Five minutes for listening DCCs }; sub new { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %self = @_; return bless \%self, $package; } sub PCI_register { my ($self, $irc) = @_; $self->{irc} = $irc; POE::Session->create( object_states => [ $self => [qw( _start _dcc_read _dcc_failed _dcc_timeout _dcc_up _U_dcc _U_dcc_accept _U_dcc_chat _U_dcc_close _U_dcc_resume _cancel_timeout )], ], ); $irc->plugin_register($self, 'SERVER', qw(disconnected dcc_request)); $irc->plugin_register($self, 'USER', qw(dcc dcc_accept dcc_chat dcc_close dcc_resume)); return 1; } sub PCI_unregister { my ($self) = @_; delete $self->{irc}; delete $self->{$_} for qw(wheelmap dcc); $poe_kernel->refcount_decrement($self->{session_id}, __PACKAGE__); return 1; } sub _start { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->{session_id} = $_[SESSION]->ID(); $kernel->refcount_increment($self->{session_id}, __PACKAGE__); return; } # set the dcc ports sub dccports { my ($self, $value) = @_; $self->{dccports} = $value; return; } # set the NAT address sub nataddr { my ($self, $value) = @_; $self->{nataddr} = $value; return; } # returns information about a connection sub dcc_info { my ($self, $id) = @_; if (!$self->{dcc}->{$id}) { warn "dcc_info: Unknown wheel ID: $id\n"; return; } my %info; @info{qw(nick type port file size done peeraddr)} = @{ $self->{dcc}->{$id} }{qw( nick type port file size done peeraddr )}; return \%info; } sub _quote_file { my ($file) = @_; if ($file =~ /[\s"]/) { $file =~ s|"|\\"|g; $file = qq{"$file"}; } return $file; } sub S_disconnected { my ($self) = $_; # clean up old cookies for any ignored RESUME requests delete $self->{resuming}; return PCI_EAT_NONE; } sub S_dcc_request { my ($self, $irc) = splice @_, 0, 2; my ($user, $type, $port, $cookie, $file, $size) = map { ref =~ /REF|SCALAR/ && ${ $_ } } @_; my $nick = (split /!/, $user)[0]; if ($type eq 'ACCEPT' && $self->{resuming}->{"$port+$nick"}) { # the old cookie has the peer's address my $old_cookie = delete $self->{resuming}->{"$port+$nick"}; $irc->yield(dcc_accept => $old_cookie); } elsif ($type eq 'RESUME') { for my $cookie (values %{ $self->{dcc} }) { next if $cookie->{nick} ne $nick; next if $cookie->{port} ne $port; $file = _quote_file($file); $cookie->{done} = $size; $irc->yield(ctcp => $nick => "DCC ACCEPT $file $port $size"); last; } } return PCI_EAT_NONE; } # this is a stub handler for all U_dcc* events which redispatches them as # events to our own POE session so that we can do stuff related to it, # namely create wheels and set alarms/delays sub _default { my ($self, $irc, $event) = splice @_, 0, 3; return PCI_EAT_NONE if $event !~ /^U_dcc(?:_accept|_chat|_close|_resume)?$/; $event =~ s/^U_/_U_/; pop @_; my @args = map { $$_ } @_; $poe_kernel->call($self->{session_id}, $event, @args); return PCI_EAT_NONE; } # Attempt to initiate a DCC SEND or CHAT connection with another person. sub _U_dcc { my ($kernel, $self, $nick, $type, $file, $blocksize, $timeout) = @_[KERNEL, OBJECT, ARG0..$#_]; if (!defined $type) { warn "The 'dcc' command requires at least two arguments\n"; return; } my $irc = $self->{irc}; my ($bindport, $bindaddr, $factory, $port, $addr, $size); $type = uc $type; if ($type eq 'CHAT') { $file = 'chat'; # As per the semi-specification } elsif ($type eq 'SEND') { if (!defined $file) { warn "The 'dcc' command requires three arguments for a SEND\n"; return; } $file = rel2abs(bsd_glob($file)); $size = (stat $file)[7]; if (!defined $size) { $irc->send_event( 'irc_dcc_error', undef, "Couldn't get ${file}'s size: $!", $nick, $type, undef, $file, ); return; } } $bindaddr = $irc->localaddr(); if ($self->{dccports}) { $bindport = shift @{ $self->{dccports} }; if (!defined $bindport) { warn "dcc: Can't allocate listen port for DCC $type\n"; return; } } $factory = POE::Wheel::SocketFactory->new( BindAddress => $bindaddr || INADDR_ANY, BindPort => $bindport, SuccessEvent => '_dcc_up', FailureEvent => '_dcc_failed', Reuse => 'yes', ); ($port, $addr) = unpack_sockaddr_in($factory->getsockname()); $addr = inet_aton($self->{nataddr}) if $self->{nataddr}; if (!defined $addr) { warn "dcc: Can't determine our IP address! ($!)\n"; return; } $addr = unpack 'N', $addr; my $basename = fileparse($file); $basename = _quote_file($basename); # Tell the other end that we're waiting for them to connect. $irc->yield(ctcp => $nick => "DCC $type $basename $addr $port" . ($size ? " $size" : '')); my $alarm_id = $kernel->delay_set( '_dcc_timeout', ($timeout || LISTEN_TIMEOUT), $factory->ID, ); # Store the state for this connection. $self->{dcc}->{ $factory->ID } = { open => 0, nick => $nick, type => $type, file => $file, size => $size, port => $port, addr => $addr, done => 0, blocksize => ($blocksize || OUT_BLOCKSIZE), listener => 1, factory => $factory, alarm_id => $alarm_id, }; return; } # Accepts a proposed DCC connection to another client. See '_dcc_up' for # the rest of the logic for this. sub _U_dcc_accept { my ($self, $cookie, $myfile) = @_[OBJECT, ARG0, ARG1]; if (!defined $cookie) { warn "The 'dcc_accept' command requires at least one argument\n"; return; } if ($cookie->{type} eq 'SEND') { $cookie->{type} = 'GET'; $cookie->{file} = $myfile if defined $myfile; # filename override } my $factory = POE::Wheel::SocketFactory->new( RemoteAddress => $cookie->{addr}, RemotePort => $cookie->{port}, SuccessEvent => '_dcc_up', FailureEvent => '_dcc_failed', ); $self->{dcc}->{$factory->ID} = $cookie; $self->{dcc}->{$factory->ID}->{factory} = $factory; return; } # Send data over a DCC CHAT connection. sub _U_dcc_chat { my ($self, $id, @data) = @_[OBJECT, ARG0..$#_]; if (!defined $id || !@data) { warn "The 'dcc_chat' command requires at least two arguments\n"; return; } if (!exists $self->{dcc}->{$id}) { warn "dcc_chat: Unknown wheel ID: $id\n"; return; } if (!exists $self->{dcc}->{$id}->{wheel}) { warn "dcc_chat: No DCC wheel for id $id!\n"; return; } if ($self->{dcc}->{$id}->{type} ne 'CHAT') { warn "dcc_chat: id $id isn't associated with a DCC CHAT connection!\n"; return; } $self->{dcc}->{$id}->{wheel}->put(join "\n", @data); return; } # Terminate a DCC connection manually. sub _U_dcc_close { my ($kernel, $self, $id) = @_[KERNEL, OBJECT, ARG0]; my $irc = $self->{irc}; if (!defined $id) { warn "The 'dcc_close' command requires an id argument\n"; return; } if (!exists $self->{dcc}->{$id}) { warn "dcc_close: Unknown wheel ID: $id\n"; return; } if (!exists $self->{dcc}->{$id}->{wheel}) { warn "dcc_close: No DCC wheel for id $id!\n"; return; } # pending data, wait till it has been flushed if ($self->{dcc}->{$id}->{wheel}->get_driver_out_octets()) { $kernel->delay_set(_U_dcc_close => 2, $id); return; } $irc->send_event( 'irc_dcc_done', $id, @{ $self->{dcc}->{$id} }{qw( nick type port file size done peeraddr )}, ); # Reclaim our port if necessary. if ($self->{dcc}->{$id}->{listener} && $self->{dccports}) { push ( @{ $self->{dccports} }, $self->{dcc}->{$id}->{port} ); } $self->_remove_dcc($id); return; } ## no critic (InputOutput::RequireBriefOpen) sub _U_dcc_resume { my ($self, $cookie, $myfile) = @_[OBJECT, ARG0, ARG1]; my $irc = $self->{irc}; my $sender_file = _quote_file($cookie->{file}); $cookie->{file} = $myfile if defined $myfile; $cookie->{done} = -s $cookie->{file}; $cookie->{resuming} = 1; if (open(my $handle, '>>', $cookie->{file})) { $irc->yield(ctcp => $cookie->{nick} => "DCC RESUME $sender_file $cookie->{port} $cookie->{done}"); $self->{resuming}->{"$cookie->{port}+$cookie->{nick}"} = $cookie; } else { warn "dcc_resume: Can't append to file '$cookie->{file}'\n"; return; } return; } # Accept incoming data on a DCC socket. sub _dcc_read { my ($kernel, $self, $data, $id) = @_[KERNEL, OBJECT, ARG0, ARG1]; my $irc = $self->{irc}; $id = $self->{wheelmap}->{$id}; if ($self->{dcc}{$id}{alarm_id}) { $kernel->call($self->{session_id}, '_cancel_timeout', $id); } if ($self->{dcc}->{$id}->{type} eq 'GET') { # Acknowledge the received data. print {$self->{dcc}->{$id}->{fh}} $data; $self->{dcc}->{$id}->{done} += length $data; $self->{dcc}->{$id}->{wheel}->put( pack 'N', $self->{dcc}->{$id}->{done} ); # Send an event to let people know about the newly arrived data. $irc->send_event( 'irc_dcc_get', $id, @{ $self->{dcc}->{$id} }{qw( nick port file size done peeraddr )}, ); } elsif ($self->{dcc}->{$id}->{type} eq 'SEND') { # Record the client's download progress. $self->{dcc}->{$id}->{done} = unpack 'N', substr( $data, -4 ); $irc->send_event( 'irc_dcc_send', $id, @{ $self->{dcc}->{$id} }{qw( nick port file size done peeraddr )}, ); # Are we done yet? if ($self->{dcc}->{$id}->{done} >= $self->{dcc}->{$id}->{size}) { # Reclaim our port if necessary. if ( $self->{dcc}->{$id}->{listener} && $self->{dccports}) { push @{ $self->{dccports} }, $self->{dcc}->{$id}->{port}; } $irc->send_event( 'irc_dcc_done', $id, @{ $self->{dcc}->{$id} }{qw( nick type port file size done peeraddr )}, ); $self->_remove_dcc($id); return; } # Send the next 'blocksize'-sized packet. read $self->{dcc}->{$id}->{fh}, $data, $self->{dcc}->{$id}->{blocksize}; $self->{dcc}->{$id}->{wheel}->put( $data ); } else { $irc->send_event( 'irc_dcc_' . lc $self->{dcc}->{$id}->{type}, $id, @{ $self->{dcc}->{$id} }{qw(nick port)}, $data, $self->{dcc}->{$id}->{peeraddr}, ); } return; } # What happens when an attempted DCC connection fails. sub _dcc_failed { my ($self, $operation, $errnum, $errstr, $id) = @_[OBJECT, ARG0 .. ARG3]; my $irc = $self->{irc}; if (!exists $self->{dcc}->{$id}) { if (exists $self->{wheelmap}->{$id}) { $id = $self->{wheelmap}->{$id}; } else { warn "_dcc_failed: Unknown wheel ID: $id\n"; return; } } # Reclaim our port if necessary. if ( $self->{dcc}->{$id}->{listener} && $self->{dccports}) { push ( @{ $self->{dccports} }, $self->{dcc}->{$id}->{port} ); } DCC: { last DCC if $errnum != 0; # Did the peer of a DCC GET connection close the socket after the file # transfer finished? If so, it's not really an error. if ($self->{dcc}->{$id}->{type} eq 'GET') { if ($self->{dcc}->{$id}->{done} < $self->{dcc}->{$id}->{size}) { last DCC; } } if ($self->{dcc}->{$id}->{type} =~ /^(GET|CHAT)$/) { $irc->send_event( 'irc_dcc_done', $id, @{ $self->{dcc}->{$id} }{qw( nick type port file size done peeraddr )}, ); $self->_remove_dcc($id); } return; } # something went wrong if ($errnum == 0 && $self->{dcc}->{$id}->{type} eq 'GET') { $errstr = 'Aborted by sender'; } else { $errstr = $errstr ? $errstr = "$operation error $errnum: $errstr" : $errstr = "$operation error $errnum" ; } $irc->send_event( 'irc_dcc_error', $id, $errstr, @{ $self->{dcc}->{$id} }{qw( nick type port file size done peeraddr )}, ); $self->_remove_dcc($id); return; } # What happens when a DCC connection sits waiting for the other end to # pick up the phone for too long. sub _dcc_timeout { my ($kernel, $self, $id) = @_[KERNEL, OBJECT, ARG0]; if (exists $self->{dcc}->{$id} && !$self->{dcc}->{$id}->{open}) { $kernel->yield( '_dcc_failed', 'connection', 0, 'DCC connection timed out', $id, ); } return; } # This event occurs when a DCC connection is established. ## no critic (InputOutput::RequireBriefOpen) sub _dcc_up { my ($kernel, $self, $sock, $peeraddr, $id) = @_[KERNEL, OBJECT, ARG0, ARG1, ARG3]; my $irc = $self->{irc}; # Delete the listening socket and monitor the accepted socket # for incoming data delete $self->{dcc}->{$id}->{factory}; $self->{dcc}->{$id}->{open} = 1; $self->{dcc}->{$id}->{peeraddr} = inet_ntoa($peeraddr); $self->{dcc}->{$id}->{wheel} = POE::Wheel::ReadWrite->new( Handle => $sock, Driver => ($self->{dcc}->{$id}->{type} eq 'GET' ? POE::Driver::SysRW->new( BlockSize => IN_BLOCKSIZE ) : POE::Driver::SysRW->new() ), Filter => ($self->{dcc}->{$id}->{type} eq 'CHAT' ? POE::Filter::Line->new( Literal => "\012" ) : POE::Filter::Stream->new() ), InputEvent => '_dcc_read', ErrorEvent => '_dcc_failed', ); $self->{wheelmap}->{ $self->{dcc}->{$id}->{wheel}->ID } = $id; my $handle; if ($self->{dcc}->{$id}->{type} eq 'GET') { # check if we're resuming my $mode = $self->{dcc}->{$id}->{resuming} ? '>>' : '>'; if ( !open $handle, $mode, $self->{dcc}->{$id}->{file} ) { $kernel->yield(_dcc_failed => 'open file', $! + 0, $!, $id); return; } binmode $handle; $self->{dcc}->{$id}->{fh} = $handle; } elsif ($self->{dcc}->{$id}->{type} eq 'SEND') { if (!open $handle, '<', $self->{dcc}->{$id}->{file}) { $kernel->yield(_dcc_failed => 'open file', $! + 0, $!, $id); return; } binmode $handle; seek $handle, $self->{dcc}{$id}{done}, 0; # Send the first packet to get the ball rolling. read $handle, my $buffer, $self->{dcc}->{$id}->{blocksize}; $self->{dcc}->{$id}->{wheel}->put($buffer); $self->{dcc}->{$id}->{fh} = $handle; } # Tell any listening sessions that the connection is up. $irc->send_event( 'irc_dcc_start', $id, @{ $self->{dcc}->{$id} }{qw( nick type port file size peeraddr )}, ); return; } sub _cancel_timeout { my ($kernel, $self, $id) = @_[KERNEL, OBJECT, ARG0]; my $alarm_id = delete $self->{dcc}{$id}{alarm_id}; $kernel->alarm_remove($alarm_id); return; } sub _remove_dcc { my ($self, $id) = @_; if (exists $self->{dcc}{$id}{alarm_id}) { $poe_kernel->call($self->{session_id}, '_cancel_timeout', $id); } if (exists $self->{dcc}{$id}{wheel}) { delete $self->{wheelmap}{ $self->{dcc}{$id}{wheel}->ID }; if ($^O =~ /cygwin|MSWin/) { $self->{dcc}{$id}{wheel}->$_ for qw(shutdown_input shutdown_output); } } # flush the filehandle close $self->{dcc}{$id}{fh} if $self->{dcc}{$id}{type} eq 'GET'; delete $self->{dcc}{$id}; return; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::DCC - A PoCo-IRC plugin providing support for DCC transfers =head1 SYNOPSIS # send a file my $file = '/home/user/secret.pdf'; my $recipient = 'that_guy'; $irc->yield(dcc => $recipient => SEND => $file); # receive a file sub irc_dcc_request { my ($user, $type, $port, $cookie, $file, $size, $addr) = @_[ARG0..$#_]; return if $type ne 'SEND'; my $irc = $_[SENDER]->get_heap(); my $nick = (split /!/, $user)[0]; print "$nick wants to send me '$file' ($size bytes) from $addr:$port\n"); $irc->yield(dcc_accept => $cookie); } =head1 DESCRIPTION This plugin provides the IRC commands needed to make use of DCC. It is used internally by L so there's no need to add it manually. =head1 METHODS =head2 C Takes no arguments. Returns a plugin object suitable for feeding to L's C method. =head2 C Sets the TCP ports that can be used for DCC sends. Takes one argument, an arrayref containing the port numbers. =head2 C Sets the public NAT address to be used for DCC sends. =head2 C Takes one argument, a DCC connection id (see below). Returns a hash of information about the connection. The keys are: B<'nick'>, B<'type'>, B<'port'>, B<'file'>, B<'size'>, B<'done,'>, and B<'peeraddr'>. =head1 COMMANDS The plugin responds to the following L commands. =head2 C Send a DCC SEND or CHAT request to another person. Takes at least two arguments: the nickname of the person to send the request to and the type of DCC request (SEND or CHAT). For SEND requests, be sure to add a third argument for the filename you want to send. Optionally, you can add a fourth argument for the DCC transfer blocksize, but the default of 1024 should usually be fine. The fifth (and optional) argument is the request timeout value in seconds (default: 300). Incidentally, you can send other weird nonstandard kinds of DCCs too; just put something besides 'SEND' or 'CHAT' (say, 'FOO') in the type field, and you'll get back C events (with the same arguments as L|/irc_dcc_chat>) when data arrives on its DCC connection. If you are behind a firewall or Network Address Translation, you may want to consult L's L|POE::Component::IRC/spawn> for some parameters that are useful with this command. =head2 C Accepts an incoming DCC connection from another host. First argument: the magic cookie from an L|/irc_dcc_request> event. In the case of a DCC GET, the second argument can optionally specify a new name for the destination file of the DCC transfer, instead of using the sender's name for it. (See the L|/irc_dcc_request> section below for more details.) =head2 C Resumes a DCC SEND file transfer. First argument: the magic cookie from an L|/irc_dcc_request> event. An optional second argument provides the name of the file to which you want to write. =head2 C Sends lines of data to the person on the other side of a DCC CHAT connection. The first argument should be the wheel id of the connection which you got from an L|/irc_dcc_start> event, followed by all the data you wish to send (it'll be separated with newlines for you). =head2 C Terminates a DCC SEND or GET connection prematurely, and causes DCC CHAT connections to close gracefully. Takes one argument: the wheel id of the connection which you got from an L|/irc_dcc_start> (or similar) event. =head1 OUTPUT EVENTS =head2 C B This event is actually emitted by L, but documented here to keep all the DCC documentation in one place. In case you were wondering. You receive this event when another IRC client sends you a DCC (e.g. SEND or CHAT) request out of the blue. You can examine the request and decide whether or not to accept it (with L|/dcc_accept>) here. In the case of DCC SENDs, you can also request to resume the file with L|/dcc_resume>. B DCC doesn't provide a way to explicitly reject requests, so if you don't intend to accept one, just ignore it or send a L or L to the peer explaining why you're not going to accept. =over 4 =item * C: the peer's nick!user@host =item * C: the DCC type (e.g. 'CHAT' or 'SEND') =item * C: the port which the peer is listening on =item * C: this connection's "magic cookie" =item * C: the file name (SEND only) =item * C: the file size (SEND only) =item * C: the IP address which the peer is listening on =back =head2 C This event notifies you that a DCC connection has been successfully established. =over 4 =item * C: the connection's wheel id =item * C: the peer's nickname =item * C: the DCC type =item * C: the port number =item * C: the file name (SEND/GET only) =item * C: the file size (SEND/GET only) =item * C: the peer's IP address =back =head2 C Notifies you that one line of text has been received from the client on the other end of a DCC CHAT connection. =over 4 =item * C: the connection's wheel id =item * C: the peer's nickname =item * C: the port number =item * C: the text they sent =item * C: the peer's IP address =back =head2 C Notifies you that another block of data has been successfully transferred from the client on the other end of your DCC GET connection. =over 4 =item * C: the connection's wheel id =item * C: the peer's nickname =item * C: the port number =item * C: the file name =item * C: the file size =item * C: transferred file size =item * C: the peer's IP address =back =head2 C Notifies you that another block of data has been successfully transferred from you to the client on the other end of a DCC SEND connection. =over 4 =item * C: the connection's wheel id =item * C: the peer's nickname =item * C: the port number =item * C: the file name =item * C: the file size =item * C: transferred file size =item * C: the peer's IP address =back =head2 C You receive this event when a DCC connection terminates normally. Abnormal terminations are reported by L|/irc_dcc_error>. =over 4 =item * C: the connection's wheel id =item * C: the peer's nickname =item * C: the DCC type =item * C: the port number =item * C: the filename (SEND/GET only) =item * C: file size (SEND/GET only) =item * C: transferred file size (SEND/GET only) =item * C: the peer's IP address =back =head2 C You get this event whenever a DCC connection or connection attempt terminates unexpectedly or suffers some fatal error. Some of the following values might be undefined depending the stage at which the connection/attempt failed. =over 4 =item * C: the connection's wheel id =item * C: the error string =item * C: the peer's nickname =item * C: the DCC type =item * C: the port number =item * C: the file name =item * C: file size in bytes =item * C: transferred file size in bytes =item * C: the peer's IP address =back =head1 AUTHOR Dennis 'C' Taylor and Hinrik Ern SigurEsson, hinrik.sig@gmail.com =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/NickReclaim.pm0000644000175000017500000001120713153565114023524 0ustar bingosbingospackage POE::Component::IRC::Plugin::NickReclaim; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::NickReclaim::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use IRC::Utils qw(parse_user); use POE::Component::IRC::Plugin qw(PCI_EAT_NONE); sub new { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %args = @_; $args{ lc $_ } = delete $args{$_} for keys %args; if (!defined $args{poll} || $args{poll} !~ /^\d+$/) { $args{poll} = 30; } return bless \%args, $package; } sub PCI_register { my ($self, $irc) = @_; $irc->plugin_register( $self, 'SERVER', qw(001 433 nick quit) ); $irc->plugin_register( $self, 'USER', qw(nick) ); $self->{_desired_nick} = $irc->nick_name(); return 1; } sub PCI_unregister { return 1; } sub U_nick { my $self = shift; my ($nick) = ${ $_[1] } =~ /^NICK +(.+)/i; if (!defined $self->{_temp_nick} || $self->{_temp_nick} ne $nick) { delete $self->{_temp_nick}; $self->{_desired_nick} = $nick; } return PCI_EAT_NONE; } sub S_001 { my ($self, $irc) = splice @_, 0, 2; $self->{_reclaimed} = $irc->nick_name eq $self->{_desired_nick} ? 1 : 0; return PCI_EAT_NONE; } # ERR_NICKNAMEINUSE sub S_433 { my ($self, $irc) = splice @_, 0, 2; my $offending = ${ $_[2] }->[0]; if (!$irc->logged_in || $irc->nick_name() eq $offending) { my $temp_nick = "${offending}_"; $self->{_temp_nick} = $temp_nick; $irc->yield('nick', $temp_nick); } $irc->delay_remove($self->{_alarm_id}) if defined $self->{_alarm_id}; $self->{_alarm_id} = $irc->delay( ['nick', $self->{_desired_nick} ], $self->{poll} ); return PCI_EAT_NONE; } sub S_quit { my ($self, $irc) = splice @_, 0, 2; my $who = parse_user(${ $_[0] }); if ($who eq $irc->nick_name) { $irc->delay_remove($self->{_alarm_id}) if defined $self->{_alarm_id}; } elsif (!$self->{_reclaimed} && $who eq $self->{_desired_nick}) { $irc->delay_remove($self->{_alarm_id}) if defined $self->{_alarm_id}; $irc->yield('nick', $self->{_desired_nick}); } return PCI_EAT_NONE; } sub S_nick { my ($self, $irc) = splice @_, 0, 2; my $old_nick = parse_user(${ $_[0] }); my $new_nick = ${ $_[1] }; if ($new_nick eq $irc->nick_name) { if ($new_nick eq $self->{_desired_nick}) { $self->{_reclaimed} = 1; $irc->delay_remove($self->{_alarm_id}) if defined $self->{_alarm_id}; } } elsif ($old_nick eq $self->{_desired_nick}) { $irc->delay_remove($self->{_alarm_id}) if defined $self->{_alarm_id}; $irc->yield('nick', $self->{_desired_nick}); } return PCI_EAT_NONE; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::NickReclaim - A PoCo-IRC plugin for reclaiming your nickname =head1 SYNOPSIS use strict; use warnings; use POE qw(Component::IRC Component::IRC::Plugin::NickReclaim); my $nickname = 'Flibble' . $$; my $ircname = 'Flibble the Sailor Bot'; my $ircserver = 'irc.blahblahblah.irc'; my $port = 6667; my $irc = POE::Component::IRC->spawn( nick => $nickname, server => $ircserver, port => $port, ircname => $ircname, ) or die "Oh noooo! $!"; POE::Session->create( package_states => [ main => [ qw(_start) ], ], ); $poe_kernel->run(); sub _start { $irc->yield( register => 'all' ); # Create and load our NickReclaim plugin, before we connect $irc->plugin_add( 'NickReclaim' => POE::Component::IRC::Plugin::NickReclaim->new( poll => 30 ) ); $irc->yield( connect => { } ); return; } =head1 DESCRIPTION POE::Component::IRC::Plugin::NickReclaim - A L plugin automagically deals with your bot's nickname being in use and reclaims it when it becomes available again. It registers and handles 'irc_433' events. On receiving a 433 event it will reset the nickname to the 'nick' specified with C or C, appendedwith an underscore, and then poll to try and change it to the original nickname. If someone in your channel who has the nickname you're after quits or changes nickname, the plugin will try to reclaim it immediately. =head1 METHODS =head2 C Takes one optional argument: B<'poll'>, the number of seconds between nick change attempts, default is 30; Returns a plugin object suitable for feeding to L's C method. =head1 AUTHOR Chris 'BinGOs' Williams With amendments applied by Zoffix Znet =head1 SEE ALSO L =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/BotCommand.pm0000644000175000017500000004710313153565114023372 0ustar bingosbingospackage POE::Component::IRC::Plugin::BotCommand; our $AUTHORITY = 'cpan:HINRIK'; # vim: set expandtab ts=4 sw=4 ai: $POE::Component::IRC::Plugin::BotCommand::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use IRC::Utils qw( parse_user strip_color strip_formatting ); use POE::Component::IRC::Plugin qw( :ALL ); sub new { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %args = @_; $args{Method} = 'notice' if !defined $args{Method}; for my $cmd (keys %{ $args{Commands} }) { if (ref $args{Commands}->{$cmd} eq 'HASH') { croak "$cmd: no info provided" if !exists $args{Commands}->{$cmd}->{info} ; $args{Commands}->{lc $cmd}->{handler} = sprintf("irc_botcmd_%s", lc($cmd)) if !$args{Commands}->{lc $cmd}->{handler}; } $args{Commands}->{lc $cmd} = delete $args{Commands}->{$cmd}; } return bless \%args, $package; } sub PCI_register { my ($self, $irc) = splice @_, 0, 2; $self->{Addressed} = 1 if !defined $self->{Addressed}; $self->{Prefix} = '!' if !defined $self->{Prefix}; $self->{In_channels} = 1 if !defined $self->{In_channels}; $self->{In_private} = 1 if !defined $self->{In_private}; $self->{rx_cmd_args} = qr/^(\S+)(?:\s+(.+))?$/; $self->{irc} = $irc; $irc->plugin_register( $self, 'SERVER', qw(msg public) ); return 1; } sub PCI_unregister { return 1; } sub S_msg { my ($self, $irc) = splice @_, 0, 2; my $who = ${ $_[0] }; my $where = parse_user($who); my $what = ${ $_[2] }; return PCI_EAT_NONE if !$self->{In_private}; $what = $self->_normalize($what); if (!$self->{Bare_private}) { return PCI_EAT_NONE if $what !~ s/^\Q$self->{Prefix}\E//; } my ($cmd, $args); if (!(($cmd, $args) = $what =~ $self->{rx_cmd_args})) { return PCI_EAT_NONE; } $self->_handle_cmd($who, $where, $cmd, $args); return $self->{Eat} ? PCI_EAT_PLUGIN : PCI_EAT_NONE; } sub S_public { my ($self, $irc) = splice @_, 0, 2; my $who = ${ $_[0] }; my $where = ${ $_[1] }->[0]; my $what = ${ $_[2] }; my $me = $irc->nick_name(); return PCI_EAT_NONE if !$self->{In_channels}; $what = $self->_normalize($what); if ($self->{Addressed}) { return PCI_EAT_NONE if !(($what) = $what =~ m/^\s*\Q$me\E[:,;.!?~]?\s*(.*)$/); } else { return PCI_EAT_NONE if $what !~ s/^\Q$self->{Prefix}\E//; } my ($cmd, $args); if (!(($cmd, $args) = $what =~ $self->{rx_cmd_args})) { return PCI_EAT_NONE; } $self->_handle_cmd($who, $where, $cmd, $args); return $self->{Eat} ? PCI_EAT_PLUGIN : PCI_EAT_NONE; } sub _normalize { my ($self, $line) = @_; $line = strip_color($line); $line = strip_formatting($line); return $line; } sub _handle_cmd { my ($self, $who, $where, $cmd, $args) = @_; my $irc = $self->{irc}; my $chantypes = join('', @{ $irc->isupport('CHANTYPES') || ['#', '&']}); my $public = $where =~ /^[$chantypes]/ ? 1 : 0; $cmd = lc $cmd; my $cmd_unresolved = $cmd; if((my $cmd_resolved = $self->resolve_alias($cmd))) { $cmd = $cmd_resolved; } if (defined $self->{Commands}->{$cmd}) { if (ref $self->{Commands}->{$cmd} eq 'HASH') { my @args_array = defined $args ? split /\s+/, $args : (); if (defined($self->{Commands}->{$cmd}->{args}) && ref($self->{Commands}->{$cmd}->{args}) eq 'ARRAY' && @{ $self->{Commands}->{$cmd}->{args} } && (@args_array < @{ $self->{Commands}->{$cmd}->{args} } || (!defined $self->{Commands}->{$cmd}->{variable} && @args_array > @{ $self->{Commands}->{$cmd}->{args} })) ) { $irc->yield($self->{Method}, $where, "Not enough or too many arguments. See help for $cmd"); return; } if(defined $self->{Commands}->{$cmd}->{variable} || (defined($self->{Commands}->{$cmd}->{args}) && ref($self->{Commands}->{$cmd}->{args}) eq 'ARRAY' && @{ $self->{Commands}->{$cmd}->{args} })) { $args = {}; if( defined($self->{Commands}->{$cmd}->{args}) && ref($self->{Commands}->{$cmd}->{args}) eq 'ARRAY' && @{ $self->{Commands}->{$cmd}->{args} }) { for (@{ $self->{Commands}->{$cmd}->{args} }) { my $in_arg = shift @args_array; if (ref $self->{Commands}->{$cmd}->{$_} eq 'ARRAY') { my @values = @{ $self->{Commands}->{$cmd}->{$_} }; shift @values; use List::Util qw(none); # Check if argument has one of possible values if (none { $_ eq $in_arg} @values) { $irc->yield($self->{Method}, $where, "$_ can be one of ".join '|', @values); return; } } $args->{$_} = $in_arg; } } # Process remaining arguments if variable is set my $arg_cnt = 0; if (defined $self->{Commands}->{$cmd}->{variable}) { for (@args_array) { $args->{"opt".$arg_cnt++} = $_; } } } } } if (ref $self->{Auth_sub} eq 'CODE') { my ($authed, $errors) = $self->{Auth_sub}->($self->{irc}, $who, $where, $cmd, $args, $cmd_unresolved); if (!$authed) { my @errors = ref $errors eq 'ARRAY' ? @$errors : 'You are not authorized to use this command.'; if (!$self->{Ignore_unauthorized}) { for my $error (@errors) { $irc->yield($self->{Method}, $where, $error); } } return; } } if (defined $self->{Commands}->{$cmd}) { my $handler = (ref($self->{Commands}->{$cmd}) eq 'HASH' ? $self->{Commands}->{$cmd}->{handler} : "irc_botcmd_$cmd"); $irc->send_event_next($handler => $who, $where, $args, $cmd, $cmd_unresolved); } elsif ($cmd =~ /^help$/i) { my @help = $self->_get_help($args, $public); $irc->yield($self->{Method} => $where => $_) for @help; } elsif (!$self->{Ignore_unknown}) { my @help = $self->_get_help($cmd, $public); $irc->yield($self->{Method} => $where => $_) for @help; } return; } sub _get_help { my ($self, $args, $public) = @_; my $irc = $self->{irc}; my $p = $self->{Addressed} && $public ? $irc->nick_name().': ' : $self->{Prefix}; my @help; if (defined $args) { my $cmd = (split /\s+/, $args, 2)[0]; $cmd = lc $cmd; my $cmd_resolved = $self->resolve_alias($cmd) || $cmd; if (exists $self->{Commands}->{$cmd_resolved}) { if (ref $self->{Commands}->{$cmd_resolved} eq 'HASH') { push @help, "Syntax: $p$cmd". ( defined($self->{Commands}->{$cmd_resolved}->{args}) && ref($self->{Commands}->{$cmd_resolved}->{args}) eq 'ARRAY' ? " ".join ' ', @{ $self->{Commands}->{$cmd_resolved}->{args} } : "" ). (defined $self->{Commands}->{$cmd_resolved}->{variable} ? " ..." : ""); push @help, split /\015?\012/, "Description: ".$self->{Commands}->{$cmd_resolved}->{info}; if( defined($self->{Commands}->{$cmd_resolved}->{args}) && ref($self->{Commands}->{$cmd_resolved}->{args}) eq 'ARRAY' && @{ $self->{Commands}->{$cmd_resolved}->{args} }) { push @help, "Arguments:"; for my $arg (@{ $self->{Commands}->{$cmd_resolved}->{args} }) { next if not defined $self->{Commands}->{$cmd_resolved}->{$arg}; if (ref $self->{Commands}->{$cmd_resolved}->{$arg} eq 'ARRAY') { my @arg_usage = @{$self->{Commands}->{$cmd_resolved}->{$arg}}; push @help, " $arg: ".$arg_usage[0]. " (".(join '|', @arg_usage[1..$#arg_usage]).")" } else { push @help, " $arg: ". $self->{Commands}->{$cmd_resolved}->{$arg}; } } } push @help, "Alias of: ${p}${cmd_resolved}" . (ref($self->{Commands}->{$cmd_resolved}->{args}) eq 'ARRAY' ? " ".join ' ', @{ $self->{Commands}->{$cmd_resolved}->{args} } : "" ). (defined $self->{Commands}->{$cmd_resolved}->{variable} ? " ..." : "") if $cmd_resolved ne $cmd; my @aliases = grep { $_ ne $cmd } $self->list_aliases($cmd_resolved); if($cmd_resolved ne $cmd) { push @aliases, $cmd_resolved; } push @help, "Aliases: ".join( " ", @aliases) if scalar(@aliases); } else { @help = split /\015?\012/, $self->{Commands}->{$cmd}; } } else { push @help, "Unknown command: $cmd"; push @help, "To get a list of commands, use: ${p}help"; } } else { if (keys %{ $self->{Commands} }) { push @help, 'Commands: ' . join ', ', sort keys %{ $self->{Commands} }; push @help, "For more details, use: ${p}help "; } else { push @help, 'No commands are defined'; } } if(ref($self->{'Help_sub'}) eq 'CODE') { my ($cmd, $args) = (defined $args ? split /\s+/, $args, 2 : ('', '')); my $cmd_resolved = $self->resolve_alias($cmd) || $cmd; return $self->{'Help_sub'}->($self->{irc}, $cmd, $cmd_resolved, $args, @help); } else { return @help; } } sub add { my ($self, $cmd, $usage) = @_; $cmd = lc $cmd; return if exists $self->{Commands}->{$cmd}; if (ref $usage eq 'HASH') { return if !exists $usage->{info} || !@{ $usage->{args} }; } $self->{Commands}->{$cmd} = $usage; return 1; } sub remove { my ($self, $cmd) = @_; $cmd = lc $cmd; return if !exists $self->{Commands}->{$cmd}; delete $self->{Commands}->{$cmd}; return 1; } sub list { my ($self) = @_; return %{ $self->{Commands} }; } sub resolve_alias { my ($self, $alias) = @_; my %cmds = $self->list(); #TODO: refactor using smartmatch/Perl6::Junction if feasible while(my ($cmd, $info) = each(%cmds)) { next unless ref($info) eq 'HASH'; next unless $info->{aliases} && ref($info->{aliases}) eq 'ARRAY'; my @aliases = @{$info->{aliases}}; foreach my $cmdalias (@aliases) { return $cmd if $alias eq $cmdalias; } } return undef; } sub list_aliases { my ($self, $cmd) = @_; $cmd = lc $cmd; return if !exists $self->{Commands}->{$cmd}; return unless ref($self->{Commands}->{$cmd}) eq 'HASH'; return unless exists $self->{Commands}->{$cmd}->{aliases} && ref($self->{Commands}->{$cmd}->{aliases}) eq 'ARRAY'; return @{$self->{Commands}->{$cmd}->{aliases}}; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::BotCommand - A PoCo-IRC plugin which handles commands issued to your bot =head1 SYNOPSIS use POE; use POE::Component::Client::DNS; use POE::Component::IRC; use POE::Component::IRC::Plugin::BotCommand; my @channels = ('#channel1', '#channel2'); my $dns = POE::Component::Client::DNS->spawn(); my $irc = POE::Component::IRC->spawn( nick => 'YourBot', server => 'some.irc.server', ); POE::Session->create( package_states => [ main => [ qw(_start irc_001 irc_botcmd_slap irc_botcmd_lookup dns_response) ], ], ); $poe_kernel->run(); sub _start { $irc->plugin_add('BotCommand', POE::Component::IRC::Plugin::BotCommand->new( Commands => { slap => 'Takes one argument: a nickname to slap.', lookup => 'Takes two arguments: a record type (optional), and a host.', } )); $irc->yield(register => qw(001 botcmd_slap botcmd_lookup)); $irc->yield(connect => { }); } # join some channels sub irc_001 { $irc->yield(join => $_) for @channels; return; } # the good old slap sub irc_botcmd_slap { my $nick = (split /!/, $_[ARG0])[0]; my ($where, $arg) = @_[ARG1, ARG2]; $irc->yield(ctcp => $where, "ACTION slaps $arg"); return; } # non-blocking dns lookup sub irc_botcmd_lookup { my $nick = (split /!/, $_[ARG0])[0]; my ($where, $arg) = @_[ARG1, ARG2]; my ($type, $host) = $arg =~ /^(?:(\w+) )?(\S+)/; my $res = $dns->resolve( event => 'dns_response', host => $host, type => $type, context => { where => $where, nick => $nick, }, ); $poe_kernel->yield(dns_response => $res) if $res; return; } sub dns_response { my $res = $_[ARG0]; my @answers = map { $_->rdatastr } $res->{response}->answer() if $res->{response}; $irc->yield( 'notice', $res->{context}->{where}, $res->{context}->{nick} . (@answers ? ": @answers" : ': no answers for "' . $res->{host} . '"') ); return; } =head1 DESCRIPTION POE::Component::IRC::Plugin::BotCommand is a L plugin. It provides you with a standard interface to define bot commands and lets you know when they are issued. Commands are accepted as channel or private messages. The plugin will respond to the 'help' command by default, listing available commands and information on how to use them. However, if you add a help command yourself, that one will be used instead. =head1 METHODS =head2 C B<'Commands'>, a hash reference, with your commands as keys, and usage information as values. If the usage string contains newlines, the plugin will send one message for each line. If a command's value is a HASH ref like this: $irc->plugin_add('BotCommand', POE::Component::IRC::Plugin::BotCommand->new( Commands => { slap => { info => 'Slap someone', args => [qw(nickname)], nickname => 'nickname to slap' } } )); The args array reference is than used to validate number of arguments required and to name arguments passed to event handler. Help is than generated from C and other hash keys which represent arguments (they are optional). An optional C key can be specified inside the HASH ref to override the event handler. The irc_botcmd_ prefix is not automatically prepended to the handler name when overriding it. An optional C key can be specified inside the HASH ref containing a array ref with alias names. The aliases can be specified for help and to run the command. =head3 Accepting commands B<'In_channels'>, a boolean value indicating whether to accept commands in channels. Default is true. B<'In_private'>, a boolean value indicating whether to accept commands in private. Default is true. B<'Addressed'>, requires users to address the bot by name in order to issue commands. Default is true. B<'Prefix'>, a string which all commands must be prefixed with (except in channels when B<'Addressed'> is true). Default is '!'. You can set it to '' to allow bare commands. B<'Bare_private'>, a boolean value indicating whether bare commands (without the prefix) are allowed in private messages. Default is false. =head3 Authorization B<'Auth_sub'>, a subroutine reference which, if provided, will be called for every command. The subroutine will be called in list context. If the first value returned is true, the command will be processed as normal. If the value is false, then no events will be generated, and an error message will possibly be sent back to the user. You can override the default error message by returning a second value, an array reference of (zero or more) strings. Each string will be sent as a message to the user. Your subroutine will be called with the following arguments: =over 4 =item 1. The IRC component object =item 2. The nick!user@host of the user =item 3. The place where the command was issued (the nickname of the user if it was in private) =item 4. The name of the command =item 5. The command argument string =back B<'Ignore_unauthorized'>, if true, the plugin will ignore unauthorized commands, rather than printing an error message upon receiving them. This is only relevant if B<'Auth_sub'> is also supplied. Default is false. =head3 Help Command B<'Help_sub'>, a subroutine reference which, if provided, will be called upon the end of the predefined help command. The subroutine will be called in list context. Your subroutine will be called with the following arguments: =over 4 =item 1. The IRC component object =item 2. The command. =item 3. The resolved command(after alias processing). =item 4. The arguments. =item 5. The generated help text as array. =back =head3 Miscellaneous B<'Ignore_unknown'>, if true, the plugin will ignore undefined commands, rather than printing a help message upon receiving them. Default is false. B<'Method'>, how you want help messages to be delivered. Valid options are 'notice' (the default) and 'privmsg'. B<'Eat'>, set to true to make the plugin hide L|POE::Component::IRC/irc_public> events from other plugins when they look like commands. Probably only useful when a B<'Prefix'> is defined. Default is false. Returns a plugin object suitable for feeding to L's C method. =head2 C Adds a new command. Takes two arguments, the name of the command, and a string or hash reference containing its usage information (see C). Returns false if the command has already been defined or no info or arguments are provided, true otherwise. =head2 C Removes a command. Takes one argument, the name of the command. Returns false if the command wasn't defined to begin with, true otherwise. =head2 C Takes no arguments. Returns a list of key/value pairs, the keys being the command names and the values being the usage strings or hash references. =head2 C Takes one argument, a string to match against command aliases, if no matching command can be found undef is returned. =head1 OUTPUT EVENTS =head2 C You will receive an event like this for every valid command issued. E.g. if 'slap' were a valid command, you would receive an C event every time someone issued that command. It receives the following arguments: =over 4 =item * C: the nick!hostmask of the user who issued the command. =item * C is the name of the channel in which the command was issued, or the sender's nickname if this was a private message. =item * C: a string of arguments to the command, or hash reference with arguments in case you defined command along with arguments, or undef if there were no arguments =back =head1 AUTHOR Hinrik Ern SigurEsson, hinrik.sig@gmail.com =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/ISupport.pm0000644000175000017500000001371013153565114023131 0ustar bingosbingospackage POE::Component::IRC::Plugin::ISupport; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::ISupport::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use POE::Component::IRC::Plugin qw(:ALL); sub new { return bless { }, shift; } sub PCI_register { my ($self, $irc) = splice @_, 0, 2; $irc->plugin_register( $self => SERVER => qw(all) ); $self->{irc} = $irc; $self->{parser} = { CASEMAPPING => sub { my ($support, $key, $val) = @_; $support->{$key} = $val; }, CHANLIMIT => sub { my ($support, $key, $val) = @_; while ($val =~ /([^:]+):(\d+),?/g) { my ($k, $v) = ($1, $2); @{ $support->{$key} }{ split(//, $k) } = ($v) x length $k; } }, CHANMODES => sub { my ($support, $key, $val) = @_; $support->{$key} = [ split(/,/, $val) ]; }, CHANTYPES => sub { my ($support, $key, $val) = @_; $support->{$key} = [ split(//, $val) ]; }, ELIST => sub { my ($support, $key, $val) = @_; $support->{$key} = [ split(//, $val) ]; }, IDCHAN => sub { my ($support, $key, $val) = @_; while ($val =~ /([^:]+):(\d+),?/g) { my ($k, $v) = ($1, $2); @{ $support->{$key} }{ split(//, $k) } = ($v) x length $k; } }, MAXLIST => sub { my ($support, $key, $val) = @_; while ($val =~ /([^:]+):(\d+),?/g) { my ($k, $v) = ($1, $2); @{ $support->{$key} }{ split(//, $k) } = ($v) x length $k; } }, PREFIX => sub { my ($support, $key, $val) = @_; if (my ($k, $v) = $val =~ /\(([^)]+)\)(.*)/ ) { @{ $support->{$key} }{ split(//, $k) } = split(//, $v); } }, STATUSMSG => sub { my ($support, $key, $val) = @_; $support->{$key} = [ split(//, $val) ]; }, TARGMAX => sub { my ($support, $key, $val) = @_; while ($val =~ /([^:]+):(\d*),?/g) { my ($k, $v) = ($1, $2); $support->{$key}->{$k} = $v; } }, EXCEPTS => sub { my ($support, $flag) = @_; $support->{$flag} = 'e'; }, INVEX => sub { my ($support, $flag) = @_; $support->{$flag} = 'I'; }, }; return 1; } sub PCI_unregister { my ($self, $irc) = splice @_, 0, 2; delete $self->{irc}; return 1; } sub S_connected { my ($self, $irc) = splice @_, 0, 2; $self->{server} = { }; $self->{got_005} = 0; $self->{done_005} = 0; return PCI_EAT_NONE; } sub S_005 { my ($self, $irc, @args) = @_; my @vals = @{ ${ $args[2] } }; pop @vals; my $support = $self->{server}; for my $val (@vals) { if ($val =~ /=/) { my $key; ($key, $val) = split(/=/, $val, 2); if (defined $self->{parser}->{$key}) { $self->{parser}->{$key}->($support, $key, $val); } else { # AWAYLEN CHANNELLEN CHIDLEN CHARSET EXCEPTS INVEX KICKLEN # MAXBANS MAXCHANNELS MAXTARGETS MODES NETWORK NICKLEN STD # TOPICLEN WATCH $support->{$key} = $val; } } else { if (defined $self->{parser}->{$val}) { $self->{parser}->{$val}->($support, $val); } else { # ACCEPT CALLERID CAPAB CNOTICE CPRIVMSG FNC KNOCK MAXNICKLEN # NAMESX NOQUIT PENALTY RFC2812 SAFELIST UHNAMES USERIP # VCHANS WALLCHOPS WALLVOICES WHOX $support->{$val} = 'on'; } } } $self->{got_005}++; return PCI_EAT_NONE; } sub _default { my ($self, $irc, $event) = @_; return PCI_EAT_NONE if $self->{done_005}; return PCI_EAT_NONE if !$self->{got_005}; if ($event =~ /^S_(\d+)/ and $1 > 5) { $self->{done_005} = 1; $irc->send_event_now(irc_isupport => $self); } return PCI_EAT_NONE; } sub isupport { my $self = shift; my $value = uc ( $_[0] ) || return; return $self->{server}->{$value} if defined $self->{server}->{$value}; return; } sub isupport_dump_keys { my $self = shift; if ( keys %{ $self->{server} } > 0 ) { return keys %{ $self->{server} }; } return; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::ISupport - A PoCo-IRC plugin that handles server capabilities =head1 DESCRIPTION This handles the C messages that come from the server. They define the capabilities support by the server. =head1 METHODS =head2 C Takes no arguments. Returns a plugin object suitable for feeding to L's C method. =head2 C Takes one argument. the server capability to query. Returns a false value on failure or a value representing the applicable capability. A full list of capabilities is available at L. =head2 C Takes no arguments, returns a list of the available server capabilities, which can be used with C. =head1 INPUT This module handles the following PoCo-IRC signals: =head2 C (RPL_ISUPPORT or RPL_PROTOCTL) Denotes the capabilities of the server. =head2 C Once the next signal is received that is I than C, it emits an C signal. =head1 OUTPUT EVENTS =head2 C Emitted by: the first signal received after C C will be the plugin object itself for ease of use. This is emitted when the support report has finished. =head1 AUTHOR Jeff C Pinyan, F =head1 SEE ALSO L L =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/Whois.pm0000644000175000017500000001232413153565114022435 0ustar bingosbingospackage POE::Component::IRC::Plugin::Whois; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::Whois::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use POE; use POE::Component::IRC::Plugin qw( PCI_EAT_NONE ); use IRC::Utils qw(uc_irc); sub new { return bless { }, shift; } sub PCI_register { my( $self, $irc ) = @_; $irc->plugin_register( $self, 'SERVER', qw(307 310 311 312 313 314 317 318 319 330 338 369) ); return 1; } sub PCI_unregister { return 1; } # RPL_WHOISUSER sub S_311 { my ($self, $irc) = splice @_, 0, 2; my $mapping = $irc->isupport('CASEMAPPING'); my @args = @{ ${ $_[2] } }; my $real = pop @args; my ($rnick,$user,$host) = @args; my $nick = uc_irc $rnick, $mapping; $self->{WHOIS}->{ $nick }->{nick} = $rnick; $self->{WHOIS}->{ $nick }->{user} = $user; $self->{WHOIS}->{ $nick }->{host} = $host; $self->{WHOIS}->{ $nick }->{real} = $real; return PCI_EAT_NONE; } # RPL_WHOISOPERATOR sub S_313 { my ($self, $irc) = splice @_, 0, 2; my $mapping = $irc->isupport('CASEMAPPING'); my $nick = uc_irc ${ $_[2] }->[0], $mapping; my $oper = ${ $_[2] }->[1]; $self->{WHOIS}->{ $nick }->{oper} = $oper; return PCI_EAT_NONE; } # RPL_WHOISSERVER sub S_312 { my ($self, $irc) = splice @_, 0, 2; my $mapping = $irc->isupport('CASEMAPPING'); my ($nick,$server) = @{ ${ $_[2] } }; $nick = uc_irc $nick, $mapping; # This can be returned in reply to either a WHOIS or a WHOWAS *sigh* if ( defined $self->{WHOWAS}->{ $nick } ) { $self->{WHOWAS}->{ $nick }->{server} = $server; } else { $self->{WHOIS}->{ $nick }->{server} = $server; } return PCI_EAT_NONE; } # RPL_WHOISIDLE sub S_317 { my ($self, $irc) = splice @_, 0, 2; my $mapping = $irc->isupport('CASEMAPPING'); my ($nick,@args) = @{ ${ $_[2] } }; $nick = uc_irc $nick, $mapping; $self->{WHOIS}->{ $nick }->{idle} = $args[0]; $self->{WHOIS}->{ $nick }->{signon} = $args[1]; return PCI_EAT_NONE; } # RPL_WHOISCHANNELS sub S_319 { my ($self, $irc) = splice @_, 0, 2; my $mapping = $irc->isupport('CASEMAPPING'); my @args = @{ ${ $_[2] } }; my $nick = uc_irc shift ( @args ), $mapping; my @chans = split / /, shift @args; if ( !defined $self->{WHOIS}->{ $nick }->{channels} ) { $self->{WHOIS}->{ $nick }->{channels} = [ @chans ]; } else { push( @{ $self->{WHOIS}->{ $nick }->{channels} }, @chans ); } return PCI_EAT_NONE; } # RPL_WHOISACCOUNT sub S_330 { my ($self, $irc) = splice @_, 0, 2; my $mapping = $irc->isupport('CASEMAPPING'); my ($nick, $ident) = @{ ${ $_[2] } }; $self->{WHOIS}->{ uc_irc ( $nick, $mapping ) }->{identified} = $ident; return PCI_EAT_NONE; } { no warnings 'once'; *S_307 = \&S_330; # RPL_WHOISREGNICK } # RPL_WHOISMODES sub S_310 { my ($self, $irc) = splice @_, 0, 2; my $mapping = $irc->isupport('CASEMAPPING'); my ($nick, $modes) = @{ ${ $_[2] } }; $self->{WHOIS}->{ uc_irc ( $nick, $mapping ) }->{modes} = $modes; return PCI_EAT_NONE; } # RPL_WHOISACTUALLY (Hybrid/Ratbox/others) sub S_338 { my ($self, $irc) = splice @_, 0, 2; my $mapping = $irc->isupport('CASEMAPPING'); my $nick = uc_irc ${ $_[2] }->[0], $mapping; my $ip = ${ $_[2] }->[1]; $self->{WHOIS}->{ $nick }->{actually} = $ip; return PCI_EAT_NONE; } # RPL_ENDOFWHOIS sub S_318 { my ($self, $irc) = splice @_, 0, 2; my $mapping = $irc->isupport('CASEMAPPING'); my $nick = uc_irc ${ $_[2] }->[0], $mapping; my $whois = delete $self->{WHOIS}->{ $nick }; $irc->send_event_next( 'irc_whois', $whois ) if defined $whois; return PCI_EAT_NONE; } # RPL_WHOWASUSER sub S_314 { my ($self, $irc) = splice @_, 0, 2; my $mapping = $irc->isupport('CASEMAPPING'); my @args = @{ ${ $_[2] } }; my $real = pop @args; my ($rnick,$user,$host) = @args; my $nick = uc_irc $rnick, $mapping; $self->{WHOWAS}->{ $nick }->{nick} = $rnick; $self->{WHOWAS}->{ $nick }->{user} = $user; $self->{WHOWAS}->{ $nick }->{host} = $host; $self->{WHOWAS}->{ $nick }->{real} = $real; return PCI_EAT_NONE; } # RPL_ENDOFWHOWAS sub S_369 { my ($self, $irc) = splice @_, 0, 2; my $mapping = $irc->isupport('CASEMAPPING'); my $nick = uc_irc ${ $_[2] }->[0], $mapping; my $whowas = delete $self->{WHOWAS}->{ $nick }; $irc->send_event_next( 'irc_whowas', $whowas ) if defined $whowas; return PCI_EAT_NONE; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::Whois - A PoCo-IRC plugin that generates events for WHOIS and WHOWAS replies =head1 DESCRIPTION POE::Component::IRC::Plugin::Whois is the reimplementation of the C and C code from L as a plugin. It is used internally by L so there is no need to use this plugin yourself. =head1 METHODS =head2 C No arguments required. Returns a plugin object suitable for feeding to L's C method. =head1 AUTHOR Chris "BinGOs" Williams =head1 SEE ALSO L L =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/AutoJoin.pm0000644000175000017500000002002013153565114023064 0ustar bingosbingospackage POE::Component::IRC::Plugin::AutoJoin; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::AutoJoin::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use IRC::Utils qw(parse_user lc_irc); use POE::Component::IRC::Plugin qw(:ALL); sub new { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %self = @_; return bless \%self, $package; } sub PCI_register { my ($self, $irc) = @_; if (!$self->{Channels}) { if ($irc->isa('POE::Component::IRC::State')) { for my $chan (keys %{ $irc->channels() }) { my $lchan = lc_irc($chan, $irc->isupport('MAPPING')); # note that this will not get the real key on ircu servers # in channels where we don't have ops my $key = $irc->is_channel_mode_set($chan, 'k') ? $irc->channel_key($chan) : '' ; $self->{Channels}->{$lchan} = $key; } } else { $self->{Channels} = {}; } } elsif (ref $self->{Channels} eq 'ARRAY') { my %channels; $channels{lc_irc($_, $irc->isupport('MAPPING'))} = undef for @{ $self->{Channels} }; $self->{Channels} = \%channels; } $self->{tried_keys} = { }; $self->{Rejoin_delay} = 5 if !defined $self->{Rejoin_delay}; $self->{NickServ_delay} = 5 if !defined $self->{NickServ_delay}; $irc->plugin_register($self, 'SERVER', qw(001 474 isupport chan_mode join kick part identified)); $irc->plugin_register($self, 'USER', qw(join)); return 1; } sub PCI_unregister { return 1; } sub S_001 { my ($self, $irc) = splice @_, 0, 2; delete $self->{alarm_ids}; return PCI_EAT_NONE; } # we join channels after S_isupport in case the server supports # CAPAB IDENTIFY-MSG, so pocoirc can turn it on before we join channels sub S_isupport { my ($self, $irc) = splice @_, 0, 2; if (!grep { $_->isa('POE::Component::IRC::Plugin::NickServID') } values %{ $irc->plugin_list() }) { # we don't have to wait for NickServ, so let's join while (my ($chan, $key) = each %{ $self->{Channels} }) { $irc->yield(join => $chan => (defined $key ? $key : ())); } } else { while (my ($chan, $key) = each %{ $self->{Channels} }) { push @{ $self->{alarm_ids} }, $irc->delay( [join => $chan => (defined $key ? $key : ())], $self->{NickServ_delay}, ); } } return PCI_EAT_NONE; } sub S_identified { my ($self, $irc) = splice @_, 0, 2; if ($self->{alarm_ids}) { $irc->delay_remove($_) for @{ $self->{alarm_ids} }; delete $self->{alarm_ids}; while (my ($chan, $key) = each %{ $self->{Channels} }) { $irc->yield(join => $chan => (defined $key ? $key : ())); } } return PCI_EAT_NONE; } # ERR_BANNEDFROMCHAN sub S_474 { my ($self, $irc) = splice @_, 0, 2; my $chan = ${ $_[2] }->[0]; my $lchan = lc_irc($chan, $irc->isupport('MAPPING')); return PCI_EAT_NONE if !$self->{Retry_when_banned}; my $key = $self->{Channels}{$lchan}; $key = $self->{tried_keys}{$lchan} if defined $self->{tried_keys}{$lchan}; $irc->delay([join => $chan => (defined $key ? $key : ())], $self->{Retry_when_banned}); return PCI_EAT_NONE; } sub S_chan_mode { my ($self, $irc) = splice @_, 0, 2; pop @_; my $chan = ${ $_[1] }; my $mode = ${ $_[2] }; my $arg = defined $_[3] ? ${ $_[3] } : ''; my $lchan = lc_irc($chan, $irc->isupport('MAPPING')); $self->{Channels}->{$lchan} = $arg if $mode eq '+k'; $self->{Channels}->{$lchan} = '' if $mode eq '-k'; return PCI_EAT_NONE; } sub S_join { my ($self, $irc) = splice @_, 0, 2; my $joiner = parse_user(${ $_[0] }); my $chan = ${ $_[1] }; my $lchan = lc_irc($chan, $irc->isupport('MAPPING')); return PCI_EAT_NONE if $joiner ne $irc->nick_name(); delete $self->{alarm_ids}; if (defined $self->{tried_keys}{$lchan}) { $self->{Channels}->{$lchan} = $self->{tried_keys}{$lchan}; delete $self->{tried_keys}{$lchan}; } else { $self->{Channels}->{$lchan} = ''; } return PCI_EAT_NONE; } sub S_kick { my ($self, $irc) = splice @_, 0, 2; my $chan = ${ $_[1] }; my $victim = ${ $_[2] }; my $lchan = lc_irc($chan, $irc->isupport('MAPPING')); if ($victim eq $irc->nick_name()) { if ($self->{RejoinOnKick}) { $irc->delay([ 'join', $chan, (defined $self->{Channels}->{$lchan} ? $self->{Channels}->{$lchan} : ()) ], $self->{Rejoin_delay}); } delete $self->{Channels}->{$lchan}; } return PCI_EAT_NONE; } sub S_part { my ($self, $irc) = splice @_, 0, 2; my $parter = parse_user(${ $_[0] }); my $chan = ${ $_[1] }; my $lchan = lc_irc($chan, $irc->isupport('MAPPING')); delete $self->{Channels}->{$lchan} if $parter eq $irc->nick_name(); return PCI_EAT_NONE; } sub U_join { my ($self, $irc) = splice @_, 0, 2; my (undef, $chan, $key) = split /\s/, ${ $_[0] }, 3; my $lchan = lc_irc($chan, $irc->isupport('MAPPING')); $self->{tried_keys}->{$lchan} = $key if defined $key; return PCI_EAT_NONE; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::AutoJoin - A PoCo-IRC plugin which keeps you on your favorite channels =head1 SYNOPSIS use POE qw(Component::IRC::State Component::IRC::Plugin::AutoJoin); my $nickname = 'Chatter'; my $server = 'irc.blahblahblah.irc'; my %channels = ( '#Blah' => '', '#Secret' => 'secret_password', '#Foo' => '', ); POE::Session->create( package_states => [ main => [ qw(_start irc_join) ], ], ); $poe_kernel->run(); sub _start { my $irc = POE::Component::IRC::State->spawn( Nick => $nickname, Server => $server, ) or die "Oh noooo! $!"; $irc->plugin_add('AutoJoin', POE::Component::IRC::Plugin::AutoJoin->new( Channels => \%channels )); $irc->yield(register => qw(join); $irc->yield(connect => { } ); } sub irc_join { my $chan = @_[ARG1]; $irc->yield(privmsg => $chan => "hi $channel!"); } =head1 DESCRIPTION POE::Component::IRC::Plugin::AutoJoin is a L plugin. If you get disconnected, the plugin will join all the channels you were on the next time it gets connected to the IRC server. It can also rejoin a channel if the IRC component gets kicked from it. It keeps track of channel keys so it will be able to rejoin keyed channels in case of reconnects/kicks. If a L plugin has been added to the IRC component, then AutoJoin will wait for a reply from NickServ before joining channels on connect. This plugin requires the IRC component to be L or a subclass thereof. =head1 METHODS =head2 C Takes the following optional arguments: B<'Channels'>, either an array reference of channel names, or a hash reference keyed on channel name, containing the password for each channel. By default it uses the channels the component is already on if you are using L. B<'RejoinOnKick'>, set this to 1 if you want the plugin to try to rejoin a channel (once) if you get kicked from it. Default is 0. B<'Rejoin_delay'>, the time, in seconds, to wait before rejoining a channel after being kicked (if B<'RejoinOnKick'> is on). Default is 5. B<'Retry_when_banned'>, if you can't join a channel due to a ban, set this to the number of seconds to wait between retries. Default is 0 (disabled). B<'NickServ_delay'>, how long (in seconds) to wait for a reply from NickServ before joining channels. Default is 5. Returns a plugin object suitable for feeding to L's C method. =head1 AUTHOR Hinrik Ern SigurEsson, hinrik.sig@gmail.com =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/Logger.pm0000644000175000017500000004663113153565114022573 0ustar bingosbingospackage POE::Component::IRC::Plugin::Logger; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::Logger::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use Encode::Guess; use Fcntl qw(O_WRONLY O_APPEND O_CREAT); use File::Glob ':glob'; use File::Spec::Functions qw(catdir catfile rel2abs); use IO::Handle; use IRC::Utils qw(lc_irc parse_user strip_color strip_formatting decode_irc); use POE::Component::IRC::Plugin qw( :ALL ); use POE::Component::IRC::Plugin::BotTraffic; use POSIX qw(strftime); sub new { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %self = @_; if (!defined $self{Path} && ref $self{Log_sub} ne 'CODE') { die "$package requires a Path"; } return bless \%self, $package; } sub PCI_register { my ($self, $irc) = @_; if (!$irc->isa('POE::Component::IRC::State')) { die __PACKAGE__ . ' requires PoCo::IRC::State or a subclass thereof'; } if ( !grep { $_->isa('POE::Component::IRC::Plugin::BotTraffic') } values %{ $irc->plugin_list() } ) { $irc->plugin_add('BotTraffic', POE::Component::IRC::Plugin::BotTraffic->new()); } if ($self->{Restricted}) { $self->{dir_perm} = oct 700; $self->{file_perm} = oct 600; } else { $self->{dir_perm} = oct 755; $self->{file_perm} = oct 644; } $self->{Path} = bsd_glob($self->{Path}) if ref $self->{Log_sub} ne 'CODE'; if (defined $self->{Path} && ! -d $self->{Path}) { mkdir $self->{Path}, $self->{dir_perm} or die 'Cannot create directory ' . $self->{Path} . ": $!; aborted"; $self->{Path} = rel2abs($self->{Path}); } $self->{irc} = $irc; $self->{logging} = { }; $self->{Private} = 1 if !defined $self->{Private}; $self->{Public} = 1 if !defined $self->{Public}; $self->{DCC} = 1 if !defined $self->{DCC}; $self->{Format} = $self->default_format() if !defined $self->{Format}; $irc->plugin_register($self, 'SERVER', qw(001 332 333 chan_mode ctcp_action bot_action bot_msg bot_public bot_notice join kick msg nick part public notice quit topic dcc_start dcc_chat dcc_done)); $irc->plugin_register($self, 'USER', 'dcc_chat'); return 1; } sub PCI_unregister { return 1; } sub S_001 { my ($self, $irc) = splice @_, 0, 2; $self->{logging} = { }; return PCI_EAT_NONE; } sub S_332 { my ($self, $irc) = splice @_, 0, 2; my $chan = decode_irc(${ $_[2] }->[0]); my $topic = $self->_normalize(${ $_[2] }->[1]); # only log this if we were just joining the channel $self->_log_entry($chan, topic_is => $chan, $topic) if !$irc->channel_list($chan); return PCI_EAT_NONE; } sub S_333 { my ($self, $irc) = splice @_, 0, 2; my ($chan, $user, $time) = @{ ${ $_[2] } }; $chan = decode_irc($chan); # only log this if we were just joining the channel $self->_log_entry($chan, topic_set_by => $chan, $user, $time) if !$irc->channel_list($chan); return PCI_EAT_NONE; } sub S_chan_mode { my ($self, $irc) = splice @_, 0, 2; pop @_; my $nick = parse_user(${ $_[0] }); my $chan = decode_irc(${ $_[1] }); my $mode = ${ $_[2] }; my $arg = defined $_[3] ? ${ $_[3] } : ''; $self->_log_entry($chan, $mode => $nick, $arg); return PCI_EAT_NONE; } sub S_ctcp_action { my ($self, $irc) = splice @_, 0, 2; my $sender = parse_user(${ $_[0] }); my $recipients = ${ $_[1] }; my $msg = $self->_normalize(${ $_[2] }); for my $recipient (@{ $recipients }) { if ($recipient eq $irc->nick_name()) { $self->_log_entry($sender, action => $sender, $msg); } else { $recipient = decode_irc($recipient); $self->_log_entry($recipient, action => $sender, $msg); } } return PCI_EAT_NONE; } sub S_notice { my ($self, $irc) = splice @_, 0, 2; my $sender = parse_user(${ $_[0] }); my $targets = ${ $_[1] }; my $msg = $self->_normalize(${ $_[2] }); for my $target (@{ $targets }) { if ($target eq $irc->nick_name()) { $self->_log_entry($sender, notice => $sender, $msg); } else { $target = decode_irc($target); $self->_log_entry($target, notice => $sender, $msg); } } return PCI_EAT_NONE; } sub S_bot_action { my ($self, $irc) = splice @_, 0, 2; my $recipients = ${ $_[0] }; my $msg = $self->_normalize(${ $_[1] }); for my $recipient (@{ $recipients }) { $recipient = decode_irc($recipient); $self->_log_entry($recipient, action => $irc->nick_name(), $msg); } return PCI_EAT_NONE; } sub S_bot_msg { my ($self, $irc) = splice @_, 0, 2; my $recipients = ${ $_[0] }; my $msg = $self->_normalize(${ $_[1] }); for my $recipient (@{ $recipients }) { $self->_log_entry($recipient, privmsg => $irc->nick_name(), $msg); } return PCI_EAT_NONE; } sub S_bot_public { my ($self, $irc) = splice @_, 0, 2; my $channels = ${ $_[0] }; my $msg = $self->_normalize(${ $_[1] }); for my $chan (@{ $channels }) { $chan = decode_irc($chan); $self->_log_entry($chan, privmsg => $irc->nick_name(), $msg); } return PCI_EAT_NONE; } sub S_bot_notice { my ($self, $irc) = splice @_, 0, 2; my $targets = ${ $_[0] }; my $msg = $self->_normalize(${ $_[1] }); for my $target (@{ $targets }) { $target = decode_irc($target); $self->_log_entry($target, notice => $irc->nick_name(), $msg); } return PCI_EAT_NONE; } sub S_join { my ($self, $irc) = splice @_, 0, 2; my ($joiner, $user, $host) = parse_user(${ $_[0] }); my $chan = decode_irc(${ $_[1] }); $self->_log_entry($chan, join => $joiner, "$user\@$host", $chan); return PCI_EAT_NONE; } sub S_kick { my ($self, $irc) = splice @_, 0, 2; my $kicker = parse_user(${ $_[0] }); my $chan = decode_irc(${ $_[1] }); my $victim = ${ $_[2] }; my $msg = $self->_normalize(${ $_[3] }); $self->_log_entry($chan, kick => $kicker, $victim, $chan, $msg); return PCI_EAT_NONE; } sub S_msg { my ($self, $irc) = splice @_, 0, 2; my $sender = parse_user(${ $_[0] }); my $msg = $self->_normalize(${ $_[2] }); $self->_log_entry($sender, privmsg => $sender, $msg); return PCI_EAT_NONE; } sub S_nick { my ($self, $irc) = splice @_, 0, 2; my $old_nick = parse_user(${ $_[0] }); my $new_nick = ${ $_[1] }; my $channels = ${ $_[2] }; for my $chan (@{ $channels }) { $chan = decode_irc($chan); $self->_log_entry($chan, nick_change => $old_nick, $new_nick); } return PCI_EAT_NONE; } sub S_part { my ($self, $irc) = splice @_, 0, 2; my ($parter, $user, $host) = parse_user(${ $_[0] }); my $chan = decode_irc(${ $_[1] }); my $msg = ref $_[2] eq 'SCALAR' ? ${ $_[2] } : ''; $msg = $self->_normalize($msg); $self->_log_entry($chan, part => $parter, "$user\@$host", $chan, $msg); return PCI_EAT_NONE; } sub S_public { my ($self, $irc) = splice @_, 0, 2; my $sender = parse_user(${ $_[0] }); my $channels = ${ $_[1] }; my $msg = $self->_normalize(${ $_[2] }); for my $chan (@{ $channels }) { $chan = decode_irc($chan); $self->_log_entry($chan, privmsg => $sender, $msg); } return PCI_EAT_NONE; } sub S_quit { my ($self, $irc) = splice @_, 0, 2; my ($quitter, $user, $host) = parse_user(${ $_[0] }); my $msg = $self->_normalize(${ $_[1] }); my $channels = ${ $_[2] }; for my $chan (@{ $channels }) { $chan = decode_irc($chan); $self->_log_entry($chan, quit => $quitter, "$user\@$host", $msg); } return PCI_EAT_NONE; } sub S_topic { my ($self, $irc) = splice @_, 0, 2; my $changer = parse_user(${ $_[0] }); my $chan = decode_irc(${ $_[1] }); my $new_topic = $self->_normalize(${ $_[2] }); $self->_log_entry($chan, topic_change => $changer, $new_topic); return PCI_EAT_NONE; } sub S_dcc_start { my ($self, $irc) = splice @_, 0, 2; my $nick = ${ $_[1] }; my $type = ${ $_[2] }; my $port = ${ $_[3] }; my $addr = ${ $_[6] }; return PCI_EAT_NONE if $type ne 'CHAT'; $self->_log_entry("=$nick", dcc_start => $nick, "$addr:$port"); return PCI_EAT_NONE; } sub S_dcc_chat { my ($self, $irc) = splice @_, 0, 2; my $nick = ${ $_[1] }; my $msg = $self->_normalize(${ $_[3] }); if (my ($action) = $msg =~ /\001ACTION (.*?)\001/) { $self->_log_entry("=$nick", action => $nick, $action); } else { $self->_log_entry("=$nick", privmsg => $nick, $msg); } return PCI_EAT_NONE; } sub U_dcc_chat { my ($self, $irc) = splice @_, 0, 2; pop @_; my ($id, @lines) = @_; $_ = $$_ for @lines; my $me = $irc->nick_name(); my ($dcc) = grep { $_->isa('POE::Component::IRC::Plugin::DCC') } values %{ $irc->plugin_list() }; my $info = $dcc->dcc_info($$id); my $nick = $info->{nick}; for my $msg (@lines) { $msg = $self->_normalize($msg); if (my ($action) = $msg =~ /\001ACTION (.*?)\001/) { $self->_log_entry("=$nick", action => $me, $action); } else { $self->_log_entry("=$nick", privmsg => $me, $msg); } } return PCI_EAT_NONE; } sub S_dcc_done { my ($self, $irc) = splice @_, 0, 2; my $nick = ${ $_[1] }; my $type = ${ $_[2] }; my $port = ${ $_[3] }; my $addr = ${ $_[7] }; return PCI_EAT_NONE if $type ne 'CHAT'; $self->_log_entry("=$nick", dcc_done => $nick, "$addr:$port"); return PCI_EAT_NONE; } sub _log_entry { my ($self, $context, $type, @args) = @_; my ($date, $time) = split / /, (strftime '%Y-%m-%d %H:%M:%S ', localtime); $context = lc_irc $context, $self->{irc}->isupport('CASEMAPPING'); my $chantypes = join('', @{ $self->{irc}->isupport('CHANTYPES') || ['#', '&']}); if ($context =~ /^[$chantypes]/) { return if !$self->{Public}; } elsif ($context =~ /^=/) { return if !$self->{DCC}; } else { return if !$self->{Private}; } return if $type eq 'notice' && !$self->{Notices}; if (ref $self->{Log_sub} eq 'CODE') { $self->{Log_sub}->($context, $type, @args); return; } return if !defined $self->{Format}->{$type}; # slash is problematic in a filename, replace it with underscore $context =~ s!/!_!g; my $log_file; if ($self->{Sort_by_date}) { my $log_dir = catdir($self->{Path}, $context); if (! -d $log_dir) { mkdir $log_dir, $self->{dir_perm} or die "Couldn't create directory $log_dir: $!; aborted"; } $log_file = catfile($self->{Path}, $context, "$date.log"); } else { $log_file = catfile($self->{Path}, "$context.log"); } $log_file = $self->_open_log($log_file); if (!$self->{logging}->{$context}) { print $log_file "***\n*** LOGGING BEGINS\n***\n"; $self->{logging}->{$context} = 1; } my $line = "$time " . $self->{Format}->{$type}->(@args); $line = "$date $line" if !$self->{Sort_by_date}; print $log_file $line, "\n"; return; } sub _open_log { my ($self, $file_name) = @_; sysopen(my $log, $file_name, O_WRONLY|O_APPEND|O_CREAT, $self->{file_perm}) or die "Couldn't open or create file '$file_name': $!; aborted"; binmode($log, ':encoding(utf8)'); $log->autoflush(1); return $log; } sub _normalize { my ($self, $line) = @_; $line = decode_irc($line); $line = strip_color($line) if $self->{Strip_color}; $line = strip_formatting($line) if $self->{Strip_formatting}; return $line; } sub default_format { return { '+b' => sub { my ($nick, $mask) = @_; "--- $nick sets ban on $mask" }, '-b' => sub { my ($nick, $mask) = @_; "--- $nick removes ban on $mask" }, '+e' => sub { my ($nick, $mask) = @_; "--- $nick sets exempt on $mask" }, '-e' => sub { my ($nick, $mask) = @_; "--- $nick removes exempt on $mask" }, '+I' => sub { my ($nick, $mask) = @_; "--- $nick sets invite on $mask" }, '-I' => sub { my ($nick, $mask) = @_; "--- $nick removes invite on $mask" }, '+h' => sub { my ($nick, $subject) = @_; "--- $nick gives channel half-operator status to $subject" }, '-h' => sub { my ($nick, $subject) = @_; "--- $nick removes channel half-operator status from $subject" }, '+o' => sub { my ($nick, $subject) = @_; "--- $nick gives channel operator status to $subject" }, '-o' => sub { my ($nick, $subject) = @_; "--- $nick removes channel operator status from $subject" }, '+v' => sub { my ($nick, $subject) = @_; "--- $nick gives voice to $subject" }, '-v' => sub { my ($nick, $subject) = @_; "--- $nick removes voice from $subject" }, '+k' => sub { my ($nick, $key) = @_; "--- $nick sets channel keyword to $key" }, '-k' => sub { my ($nick) = @_; "--- $nick removes channel keyword" }, '+l' => sub { my ($nick, $limit) = @_; "--- $nick sets channel user limit to $limit" }, '-l' => sub { my ($nick) = @_; "--- $nick removes channel user limit" }, '+i' => sub { my ($nick) = @_; "--- $nick enables invite-only channel status" }, '-i' => sub { my ($nick) = @_; "--- $nick disables invite-only channel status" }, '+m' => sub { my ($nick) = @_; "--- $nick enables channel moderation" }, '-m' => sub { my ($nick) = @_; "--- $nick disables channel moderation" }, '+n' => sub { my ($nick) = @_; "--- $nick disables external messages" }, '-n' => sub { my ($nick) = @_; "--- $nick enables external messages" }, '+p' => sub { my ($nick) = @_; "--- $nick enables private channel status" }, '-p' => sub { my ($nick) = @_; "--- $nick disables private channel status" }, '+s' => sub { my ($nick) = @_; "--- $nick enables secret channel status" }, '-s' => sub { my ($nick) = @_; "--- $nick disables secret channel status" }, '+t' => sub { my ($nick) = @_; "--- $nick enables topic protection" }, '-t' => sub { my ($nick) = @_; "--- $nick disables topic protection" }, nick_change => sub { my ($old_nick, $new_nick) = @_; "--- $old_nick is now known as $new_nick" }, topic_is => sub { my ($chan, $topic) = @_; "--- Topic for $chan is: $topic" }, topic_change => sub { my ($nick, $topic) = @_; "--- $nick changes the topic to: $topic" }, privmsg => sub { my ($nick, $msg) = @_; "<$nick> $msg" }, notice => sub { my ($nick, $msg) = @_; ">$nick< $msg" }, action => sub { my ($nick, $action) = @_; "* $nick $action" }, dcc_start => sub { my ($nick, $address) = @_; "--> Opened DCC chat connection with $nick ($address)" }, dcc_done => sub { my ($nick, $address) = @_; "<-- Closed DCC chat connection with $nick ($address)" }, join => sub { my ($nick, $userhost, $chan) = @_; "--> $nick ($userhost) joins $chan" }, part => sub { my ($nick, $userhost, $chan, $msg) = @_; my $line = "<-- $nick ($userhost) leaves $chan"; $line .= " ($msg)" if $msg ne ''; return $line; }, quit => sub { my ($nick, $userhost, $msg) = @_; my $line = "<-- $nick ($userhost) quits"; $line .= " ($msg)" if $msg ne ''; return $line; }, kick => sub { my ($kicker, $victim, $chan, $msg) = @_; my $line = "<-- $kicker kicks $victim from $chan"; $line .= " ($msg)" if $msg ne ''; return $line; }, topic_set_by => sub { my ($chan, $user, $time) = @_; my $date = localtime $time; return "--- Topic for $chan was set by $user at $date"; }, } } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::Logger - A PoCo-IRC plugin which logs public, private, and DCC chat messages to disk =head1 SYNOPSIS use POE::Component::IRC::Plugin::Logger; $irc->plugin_add('Logger', POE::Component::IRC::Plugin::Logger->new( Path => '/home/me/irclogs', DCC => 0, Private => 0, Public => 1, )); =head1 DESCRIPTION POE::Component::IRC::Plugin::Logger is a L plugin. It logs messages and CTCP ACTIONs to either F<#some_channel.log> or F in the supplied path. In the case of DCC chats, a '=' is prepended to the nickname (like in irssi). The plugin tries to detect UTF-8 encoding of every message or else falls back to CP1252, like irssi (and, supposedly, mIRC) does by default. Resulting log files will be UTF-8 encoded. The default log format is similar to xchat's, except that it's sane and parsable. This plugin requires the IRC component to be L or a subclass thereof. It also requires a L to be in the plugin pipeline. It will be added automatically if it is not present. =head1 METHODS =head2 C Arguments: B<'Path'>, the place where you want the logs saved. B<'Private'>, whether or not to log private messages. Defaults to 1. B<'Public'>, whether or not to log public messages. Defaults to 1. B<'DCC'>, whether or not to log DCC chats. Defaults to 1. B<'Notices'>, whether or not to log NOTICEs. Defaults to 0. B<'Sort_by_date'>, whether or not to split log files by date, i.e. F<#channel/YYYY-MM-DD.log> instead of F<#channel.log>. If enabled, the date will be omitted from the timestamp. Defaults to 0. B<'Strip_color'>, whether or not to strip all color codes from messages. Defaults to 0. B<'Strip_formatting'>, whether or not to strip all formatting codes from messages. Defaults to 0. B<'Restricted'>, set this to 1 if you want all directories/files to be created without read permissions for other users (i.e. 700 for dirs and 600 for files). Defaults to 1. B<'Format'>, a hash reference representing the log format, if you want to define your own. See the source for details. B<'Log_sub'>, a subroutine reference which can be used to override the file logging. Use this if you want to store logs in a database instead, for example. It will be called with 3 arguments: the context (a channel name or nickname), a type (e.g. 'privmsg' or '+b', and any arguments to that type. You can make use L to create logs that match the default log format. B You must take care of handling date/time and stripping colors/formatting codes yourself. Returns a plugin object suitable for feeding to L's C method. =head2 C Returns a hash reference of type/subroutine pairs, for formatting logs according to the default log format. =head1 AUTHOR Hinrik Ern SigurEsson, hinrik.sig@gmail.com =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/CTCP.pm0000644000175000017500000001266513153565114022105 0ustar bingosbingospackage POE::Component::IRC::Plugin::CTCP; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::CTCP::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use POE::Component::IRC; use POE::Component::IRC::Plugin qw( :ALL ); use POSIX qw(strftime); sub new { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %args = @_; $args{ lc $_ } = delete $args{ $_ } for keys %args; $args{eat} = 1 if !defined ( $args{eat} ) || $args{eat} eq '0'; return bless \%args, $package; } sub PCI_register { my ($self,$irc) = splice @_, 0, 2; $self->{irc} = $irc; $irc->plugin_register( $self, 'SERVER', qw(ctcp_version ctcp_clientinfo ctcp_userinfo ctcp_time ctcp_ping ctcp_source) ); return 1; } sub PCI_unregister { delete $_[0]->{irc}; return 1; } ## no critic (TestingAndDebugging::ProhibitNoStrict) sub S_ctcp_version { my ($self, $irc) = splice @_, 0, 2; my $nick = ( split /!/, ${ $_[0] } )[0]; my $our_version; { no strict 'vars'; if (defined $POE::Component::IRC::VERSION && $POE::Component::IRC::VERSION ne '1, set by base.pm') { $our_version = 'dev-git'; } else { $our_version = $POE::Component::IRC::VERSION; } } $irc->yield( ctcpreply => $nick => 'VERSION ' . ( defined $self->{version} ? $self->{version} : "POE::Component::IRC-$our_version" )); return PCI_EAT_CLIENT if $self->eat(); return PCI_EAT_NONE; } sub S_ctcp_time { my ($self, $irc) = splice @_, 0, 2; my $nick = ( split /!/, ${ $_[0] } )[0]; $irc->yield(ctcpreply => $nick => strftime('TIME %a, %d %b %Y %H:%M:%S %z', localtime)); return PCI_EAT_CLIENT if $self->eat(); return PCI_EAT_NONE; } sub S_ctcp_ping { my ($self,$irc) = splice @_, 0, 2; my $nick = ( split /!/, ${ $_[0] } )[0]; my $timestamp = ${ $_[2] }; $irc->yield( ctcpreply => $nick => 'PING ' . $timestamp ); return PCI_EAT_CLIENT if $self->eat(); return PCI_EAT_NONE; } sub S_ctcp_clientinfo { my ($self, $irc) = splice @_, 0, 2; my $nick = ( split /!/, ${ $_[0] } )[0]; $irc->yield(ctcpreply => $nick => 'CLIENTINFO ' . ($self->{clientinfo} ? $self->{clientinfo} : 'http://search.cpan.org/perldoc?POE::Component::IRC::Plugin::CTCP' )); return PCI_EAT_CLIENT if $self->eat(); return PCI_EAT_NONE; } sub S_ctcp_userinfo { my ($self, $irc) = splice @_, 0, 2; my $nick = ( split /!/, ${ $_[0] } )[0]; $irc->yield( ctcpreply => $nick => 'USERINFO ' . ( $self->{userinfo} ? $self->{userinfo} : 'm33p' ) ); return PCI_EAT_CLIENT if $self->eat(); return PCI_EAT_NONE; } sub S_ctcp_source { my ($self, $irc) = splice @_, 0, 2; my $nick = ( split /!/, ${ $_[0] } )[0]; $irc->yield( ctcpreply => $nick => 'SOURCE ' . ($self->{source} ? $self->{source} : 'http://search.cpan.org/dist/POE-Component-IRC' )); return PCI_EAT_CLIENT if $self->eat(); return PCI_EAT_NONE; } sub eat { my $self = shift; my $value = shift; return $self->{eat} if !defined $value; return $self->{eat} = $value; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::CTCP - A PoCo-IRC plugin that auto-responds to CTCP requests =head1 SYNOPSIS use strict; use warnings; use POE qw(Component::IRC Component::IRC::Plugin::CTCP); my $nickname = 'Flibble' . $$; my $ircname = 'Flibble the Sailor Bot'; my $ircserver = 'irc.blahblahblah.irc'; my $port = 6667; my $irc = POE::Component::IRC->spawn( nick => $nickname, server => $ircserver, port => $port, ircname => $ircname, ) or die "Oh noooo! $!"; POE::Session->create( package_states => [ main => [ qw(_start) ], ], ); $poe_kernel->run(); sub _start { # Create and load our CTCP plugin $irc->plugin_add( 'CTCP' => POE::Component::IRC::Plugin::CTCP->new( version => $ircname, userinfo => $ircname, )); $irc->yield( register => 'all' ); $irc->yield( connect => { } ); return: } =head1 DESCRIPTION POE::Component::IRC::Plugin::CTCP is a L plugin. It watches for C, C, C, C and C events and autoresponds on your behalf. =head1 METHODS =head2 C Takes a number of optional arguments: B<'version'>, a string to send in response to C. Default is PoCo-IRC and version; B<'clientinfo'>, a string to send in response to C. Default is L. B<'userinfo'>, a string to send in response to C. Default is 'm33p'; B<'source'>, a string to send in response to C. Default is L. B<'eat'>, by default the plugin uses PCI_EAT_CLIENT, set this to 0 to disable this behaviour; Returns a plugin object suitable for feeding to L's C method. =head2 C With no arguments, returns true or false on whether the plugin is "eating" CTCP events that it has dealt with. An argument will set "eating" to on or off appropriately, depending on whether the value is true or false. =head1 AUTHOR Chris 'BinGOs' Williams =head1 SEE ALSO CTCP Specification L. =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/PlugMan.pm0000644000175000017500000002335213153565114022712 0ustar bingosbingospackage POE::Component::IRC::Plugin::PlugMan; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::PlugMan::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use IRC::Utils qw( matches_mask parse_user ); use POE::Component::IRC::Plugin qw( :ALL ); BEGIN { # Turn on the debugger's symbol source tracing $^P |= 0x10; # Work around bug in pre-5.8.7 perl where turning on $^P # causes caller() to be confused about eval {}'s in the stack. # (See http://rt.perl.org/rt3/Ticket/Display.html?id=35059 for more info.) eval 'sub DB::sub' if $] < 5.008007; } sub new { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %args = @_; $args{ lc $_ } = delete $args{ $_ } for keys %args; return bless \%args, $package; } ########################## # Plugin related methods # ########################## sub PCI_register { my ($self, $irc) = @_; $self->{irc} = $irc; $irc->plugin_register( $self, 'SERVER', qw(public msg) ); $self->{commands} = { PLUGIN_ADD => sub { my ($self, $method, $recipient, @cmd) = @_; my $msg = $self->load(@cmd) ? 'Done.' : 'Nope'; $self->{irc}->yield($method => $recipient => $msg); }, PLUGIN_DEL => sub { my ($self, $method, $recipient, @cmd) = @_; my $msg = $self->unload(@cmd) ? 'Done.' : 'Nope'; $self->{irc}->yield($method => $recipient => $msg); }, PLUGIN_RELOAD => sub { my ($self, $method, $recipient, @cmd) = @_; my $msg = $self->reload(@cmd) ? 'Done.' : 'Nope'; $self->{irc}->yield($method => $recipient => $msg); }, PLUGIN_LIST => sub { my ($self, $method, $recipient, @cmd) = @_; my @aliases = keys %{ $self->{irc}->plugin_list() }; my $msg = @aliases ? 'Plugins [ ' . join(', ', @aliases ) . ' ]' : 'No plugins loaded.'; $self->{irc}->yield($method => $recipient => $msg); }, PLUGIN_LOADED => sub { my ($self, $method, $recipient, @cmd) = @_; my @aliases = $self->loaded(); my $msg = @aliases ? 'Managed Plugins [ ' . join(', ', @aliases ) . ' ]' : 'No managed plugins loaded.'; $self->{irc}->yield($method => $recipient => $msg); }, }; return 1; } sub PCI_unregister { my ($self, $irc) = @_; delete $self->{irc}; return 1; } sub S_public { my ($self, $irc) = splice @_, 0 , 2; my $who = ${ $_[0] }; my $channel = ${ $_[1] }->[0]; my $what = ${ $_[2] }; my $me = $irc->nick_name(); my ($command) = $what =~ m/^\s*\Q$me\E[:,;.!?~]?\s*(.*)$/i; return PCI_EAT_NONE if !$command || !$self->_authed($who, $channel); my (@cmd) = split(/ +/, $command); my $cmd = uc (shift @cmd); if (defined $self->{commands}->{$cmd}) { $self->{commands}->{$cmd}->($self, 'privmsg', $channel, @cmd); } return PCI_EAT_NONE; } sub S_msg { my ($self, $irc) = splice @_, 0 , 2; my $who = ${ $_[0] }; my $nick = parse_user($who); my $channel = ${ $_[1] }->[0]; my $command = ${ $_[2] }; my (@cmd) = split(/ +/,$command); my $cmd = uc (shift @cmd); return PCI_EAT_NONE if !$self->_authed($who, $channel); if (defined $self->{commands}->{$cmd}) { $self->{commands}->{$cmd}->($self, 'notice', $nick, @cmd); } return PCI_EAT_NONE; } ############################### # Plugin manipulation methods # ############################### sub load { my ($self, $desc, $plugin) = splice @_, 0, 3; return if !$desc || !$plugin; my $object; my $module = ref $plugin || $plugin; if (! ref $plugin){ $module .= '.pm' if $module !~ /\.pm$/; $module =~ s/::/\//g; eval "require $plugin"; if ($@) { my $error = $@; delete $INC{$module}; $self->_unload_subs($plugin); die $error; } $object = $plugin->new( @_ ); return if !$object; } else { $object = $plugin; $plugin = ref $object; } my $args = [ @_ ]; $self->{plugins}->{ $desc }->{module} = $module; $self->{plugins}->{ $desc }->{plugin} = $plugin; my $return = $self->{irc}->plugin_add( $desc, $object ); if ( $return ) { # Stash away arguments for use later by _reload. $self->{plugins}->{ $desc }->{args} = $args; } else { # Cleanup delete $self->{plugins}->{ $desc }; } return $return; } sub unload { my ($self, $desc) = splice @_, 0, 2; return if !$desc; my $plugin = $self->{irc}->plugin_del( $desc ); return if !$plugin; my $module = $self->{plugins}->{ $desc }->{module}; my $file = $self->{plugins}->{ $desc }->{plugin}; delete $INC{$module}; delete $self->{plugins}->{ $desc }; $self->_unload_subs($file); return 1; } sub _unload_subs { my $self = shift; my $file = shift || return; for my $sym ( grep { index( $_, "$file:" ) == 0 } keys %DB::sub ) { eval { undef &$sym }; warn "$sym: $@\n" if $@; delete $DB::sub{$sym}; } return 1; } sub reload { my ($self, $desc) = splice @_, 0, 2; return if !defined $desc; my $plugin_state = $self->{plugins}->{ $desc }; return if !$plugin_state; warn "Unloading plugin $desc\n" if $self->{debug}; return if !$self->unload( $desc ); warn "Loading plugin $desc " . $plugin_state->{plugin} . ' [ ' . join(', ',@{ $plugin_state->{args} }) . " ]\n" if $self->{debug}; return if !$self->load( $desc, $plugin_state->{plugin}, @{ $plugin_state->{args} } ); return 1; } sub loaded { my $self = shift; return keys %{ $self->{plugins} }; } sub _authed { my ($self, $who, $chan) = @_; return $self->{auth_sub}->($self->{irc}, $who, $chan) if $self->{auth_sub}; return 1 if matches_mask($self->{botowner}, $who); return; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::PlugMan - A PoCo-IRC plugin that provides plugin management services. =head1 SYNOPSIS use strict; use warnings; use POE qw(Component::IRC::State); use POE::Component::IRC::Plugin::PlugMan; my $botowner = 'somebody!*@somehost.com'; my $irc = POE::Component::IRC::State->spawn(); POE::Session->create( package_states => [ main => [ qw(_start irc_plugin_add) ], ], ); sub _start { $irc->yield( register => 'all' ); $irc->plugin_add( 'PlugMan' => POE::Component::IRC::Plugin::PlugMan->new( botowner => $botowner ) ); return; } sub irc_plugin_add { my ($desc, $plugin) = @_[ARG0, ARG1]; if ($desc eq 'PlugMan') { $plugin->load( 'Connector', 'POE::Component::IRC::Plugin::Connector' ); } return; } =head1 DESCRIPTION POE::Component::IRC::Plugin::PlugMan is a POE::Component::IRC plugin management plugin. It provides support for 'on-the-fly' loading, reloading and unloading of plugin modules, via object methods that you can incorporate into your own code and a handy IRC interface. =head1 METHODS =head2 C Takes two optional arguments: B<'botowner'>, an IRC mask to match against for people issuing commands via the IRC interface; B<'auth_sub'>, a sub reference which will be called to determine if a user may issue commands via the IRC interface. Overrides B<'botowner'>. It will be called with three arguments: the IRC component object, the nick!user@host and the channel name as arguments. It should return a true value if the user is authorized, a false one otherwise. B<'debug'>, set to a true value to see when stuff goes wrong; Not setting B<'botowner'> or B<'auth_sub'> effectively disables the IRC interface. If B<'botowner'> is specified the plugin checks that it is being loaded into a L or sub-class and will fail to load otherwise. Returns a plugin object suitable for feeding to L's C method. =head2 C Loads a managed plugin. Takes two mandatory arguments, a plugin descriptor and a plugin package name. Any other arguments are used as options to the loaded plugin constructor. $plugin->load( 'Connector', 'POE::Component::IRC::Plugin::Connector', delay, 120 ); Returns true or false depending on whether the load was successfully or not. =head2 C Unloads a managed plugin. Takes one mandatory argument, a plugin descriptor. $plugin->unload( 'Connector' ); Returns true or false depending on whether the unload was successfully or not. =head2 C Unloads and loads a managed plugin, with applicable plugin options. Takes one mandatory argument, a plugin descriptor. $plugin->reload( 'Connector' ); =head2 C Takes no arguments. $plugin->loaded(); Returns a list of descriptors of managed plugins. =head1 INPUT An IRC interface is enabled by specifying a "botowner" mask to L|/new>. Commands may be either invoked via a PRIVMSG directly to your bot or in a channel by prefixing the command with the nickname of your bot. One caveat, the parsing of the irc command is very rudimentary (it merely splits the line on spaces). =head2 C Takes the same arguments as L|/load>. =head2 C Takes the same arguments as L|/unload>. =head2 C Takes the same arguments as L|/reload>. =head2 C Returns a list of descriptors of managed plugins. =head2 C Returns a list of descriptors of *all* plugins loaded into the current PoCo-IRC component. =head1 AUTHOR Chris 'BinGOs' Williams =head1 SEE ALSO L L =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/Proxy.pm0000644000175000017500000003157213153565114022473 0ustar bingosbingospackage POE::Component::IRC::Plugin::Proxy; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::Proxy::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use Socket qw(inet_ntoa); use POE qw(Wheel::SocketFactory Wheel::ReadWrite Filter::IRCD Filter::Line Filter::Stackable); use POE::Component::IRC::Plugin qw(PCI_EAT_NONE); sub new { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %args = @_; $args{ lc $_ } = delete $args{ $_ } for keys %args; return bless \%args, $package; } sub PCI_register { my ($self, $irc) = splice @_, 0, 2; if (!$irc->isa('POE::Component::IRC::State')) { die __PACKAGE__ . ' requires PoCo::IRC::State or a subclass thereof'; } $irc->raw_events(1); $self->{irc} = $irc; $irc->plugin_register( $self, 'SERVER', qw( connected disconnected 001 error socketerr raw ) ); POE::Session->create( object_states => [ $self => [qw( _client_error _client_flush _client_input _listener_accept _listener_failed _start _shutdown _spawn_listener )], ], ); return 1; } sub PCI_unregister { my ($self, $irc) = splice @_, 0, 2; $poe_kernel->post($self->{SESSION_ID} => _shutdown => delete $self->{irc}); $poe_kernel->refcount_decrement($self->{SESSION_ID}, __PACKAGE__); return 1; } sub S_connected { my ($self, $irc) = splice @_, 0, 2; $self->{stashed} = 0; $self->{stash} = [ ]; return PCI_EAT_NONE; } sub S_001 { my ($self, $irc) = splice @_, 0, 2; $poe_kernel->post($self->{SESSION_ID} => '_shutdown'); $poe_kernel->post($self->{SESSION_ID} => '_spawn_listener'); return PCI_EAT_NONE; } sub S_disconnected { my ($self, $irc) = splice @_, 0, 2; $poe_kernel->post($self->{SESSION_ID} => '_shutdown'); return PCI_EAT_NONE; } sub S_socketerr { my ($self, $irc) = splice @_, 0, 2; $poe_kernel->post($self->{SESSION_ID} => '_shutdown'); return PCI_EAT_NONE; } sub S_error { my ($self, $irc) = splice @_, 0, 2; $poe_kernel->post($self->{SESSION_ID} => '_shutdown'); return PCI_EAT_NONE; } sub S_raw { my ($self, $irc) = splice @_, 0, 2; my $line = ${ $_[0] }; my $input = $self->{irc_filter}->get( [$line] )->[0]; return PCI_EAT_NONE if $input->{command} eq 'PING'; for my $wheel_id (keys %{ $self->{wheels} }) { $self->_send_to_client($wheel_id, $line); } return PCI_EAT_NONE if $self->{stashed}; if ($input->{command} =~ /^(?:NOTICE|\d{3})$/) { push @{ $self->{stash} }, $line; } $self->{stashed} = 1 if $input->{command} =~ /^(?:376|422)$/; return PCI_EAT_NONE; } sub _send_to_client { my ($self, $wheel_id, $line) = splice @_, 0, 3; return if !defined $self->{wheels}->{ $wheel_id }->{wheel}; return if !$self->{wheels}->{ $wheel_id }->{reg}; $self->{wheels}->{ $wheel_id }->{wheel}->put($line); return; } sub _close_wheel { my ($self, $wheel_id) = splice @_, 0, 2; return if !defined $self->{wheels}->{ $wheel_id }; delete $self->{wheels}->{ $wheel_id }; $self->{irc}->send_event(irc_proxy_close => $wheel_id); return; } sub _start { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->{SESSION_ID} = $_[SESSION]->ID(); $kernel->refcount_increment($self->{SESSION_ID}, __PACKAGE__); $self->{irc_filter} = POE::Filter::IRCD->new(); $self->{ircd_filter} = POE::Filter::Stackable->new( Filters => [ POE::Filter::Line->new(), $self->{irc_filter}, ], ); if ($self->{irc}->connected()) { $kernel->yield('_spawn_listener'); } return; } sub _spawn_listener { my $self = $_[OBJECT]; $self->{listener} = POE::Wheel::SocketFactory->new( BindAddress => $self->{bindaddress} || 'localhost', BindPort => $self->{bindport} || 0, SuccessEvent => '_listener_accept', FailureEvent => '_listener_failed', Reuse => 'yes', ); if (!$self->{listener}) { my $irc = $self->{irc}; $irc->plugin_del($self); return; } $self->{irc}->send_event(irc_proxy_up => $self->{listener}->getsockname()); return; } sub _listener_accept { my ($self, $socket, $peeradr, $peerport) = @_[OBJECT, ARG0 .. ARG2]; my $wheel = POE::Wheel::ReadWrite->new( Handle => $socket, InputFilter => $self->{ircd_filter}, OutputFilter => POE::Filter::Line->new(), InputEvent => '_client_input', ErrorEvent => '_client_error', FlushedEvent => '_client_flush', ); if ($wheel) { my $wheel_id = $wheel->ID(); $self->{wheels}->{ $wheel_id }->{wheel} = $wheel; $self->{wheels}->{ $wheel_id }->{port} = $peerport; $self->{wheels}->{ $wheel_id }->{peer} = inet_ntoa( $peeradr ); $self->{wheels}->{ $wheel_id }->{start} = time; $self->{wheels}->{ $wheel_id }->{reg} = 0; $self->{wheels}->{ $wheel_id }->{register} = 0; $self->{irc}->send_event(irc_proxy_connect => $wheel_id); } else { $self->{irc}->send_event(irc_proxy_rw_fail => inet_ntoa( $peeradr ) => $peerport); } return; } sub _listener_failed { delete ( $_[OBJECT]->{listener} ); return; } sub _client_flush { my ($self, $wheel_id) = @_[OBJECT, ARG0]; return if !defined $self->{wheels}->{ $wheel_id } || !$self->{wheels}->{ $wheel_id }->{quiting}; $self->_close_wheel($wheel_id); return; } # this code needs refactoring ## no critic (Subroutines::ProhibitExcessComplexity) sub _client_input { my ($self, $input, $wheel_id) = @_[OBJECT, ARG0, ARG1]; my ($irc, $wheels) = ($self->{irc}, $self->{wheels}); return if $wheels->{$wheel_id}{quiting}; if ($input->{command} eq 'QUIT') { $self->_close_wheel($wheel_id); return; } if ($input->{command} eq 'PASS' && $wheels->{$wheel_id}{reg} < 2) { $wheels->{$wheel_id}{pass} = $input->{params}[0]; } if ($input->{command} eq 'NICK' && $wheels->{$wheel_id}{reg} < 2) { $wheels->{$wheel_id}{nick} = $input->{params}[0]; $wheels->{$wheel_id}{register}++; } if ($input->{command} eq 'USER' && $wheels->{$wheel_id}{reg} < 2) { $wheels->{$wheel_id}{user} = $input->{params}[0]; $wheels->{$wheel_id}{register}++; } if (!$wheels->{$wheel_id}{reg} && $wheels->{$wheel_id}{register} >= 2) { my $password = delete $wheels->{$wheel_id}{pass}; $wheels->{$wheel_id}{reg} = 1; if (!$password || $password ne $self->{password}) { $self->_send_to_client($wheel_id, 'ERROR :Closing Link: * [' . ($wheels->{$wheel_id}{user} || 'unknown') . '@' . $wheels->{$wheel_id}{peer} . '] (Unauthorised connection)' ); $wheels->{$wheel_id}{quiting}++; return; } my $nickname = $irc->nick_name(); my $fullnick = $irc->nick_long_form($nickname); if ($nickname ne $wheels->{$wheel_id}{nick}) { $self->_send_to_client($wheel_id, "$wheels->{$wheel_id}{nick} NICK :$nickname"); } for my $line (@{ $self->{stash} }) { $self->_send_to_client($wheel_id, $line); } for my $channel ($irc->nick_channels($nickname)) { $self->_send_to_client($wheel_id, ":$fullnick JOIN $channel"); $irc->yield(names => $channel); $irc->yield(topic => $channel); } $irc->send_event(irc_proxy_authed => $wheel_id); return; } return if !$wheels->{$wheel_id}{reg}; if ($input->{command} =~ /^(?:NICK|USER|PASS)$/) { return; } if ($input->{command} eq 'PING') { $self->_send_to_client($wheel_id, "PONG $input->{params}[0]"); return; } if ($input->{command} eq 'PONG' and $input->{params}[0] =~ /^[0-9]+$/) { $wheels->{$wheel_id}{lag} = time() - $input->{params}[0]; return; } $irc->yield(quote => $input->{raw_line}); return; } sub _client_error { my ($self, $wheel_id) = @_[OBJECT, ARG3]; $self->_close_wheel($wheel_id); return; } sub _shutdown { my $self = $_[OBJECT]; my $irc = $self->{irc} || $_[ARG0]; my $mysockaddr = $self->getsockname(); delete $self->{listener}; for my $wheel_id ( $self->list_wheels() ) { $self->_close_wheel( $wheel_id ); } delete $self->{wheels}; $irc->send_event(irc_proxy_down => $mysockaddr); return; } sub getsockname { my ($self) = @_; return if !$self->{listener}; return $self->{listener}->getsockname(); } sub list_wheels { my ($self) = @_; return keys %{ $self->{wheels} }; } sub wheel_info { my ($self, $wheel_id) = @_; return if !defined $self->{wheels}->{ $wheel_id }; return $self->{wheels}->{ $wheel_id }->{start} if !wantarray; return map { $self->{wheels}->{ $wheel_id }->{$_} } qw(peer port start lag); } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::Proxy - A PoCo-IRC plugin that provides a lightweight IRC proxy/bouncer =head1 SYNOPSIS use strict; use warnings; use POE qw(Component::IRC::State Component::IRC::Plugin::Proxy Component::IRC::Plugin::Connector); my $irc = POE::Component::IRC::State->spawn(); POE::Session->create( package_states => [ main => [ qw(_start) ], ], heap => { irc => $irc }, ); $poe_kernel->run(); sub _start { my ($kernel, $heap) = @_[KERNEL, HEAP]; $heap->{irc}->yield( register => 'all' ); $heap->{proxy} = POE::Component::IRC::Plugin::Proxy->new( bindport => 6969, password => "m00m00" ); $heap->{irc}->plugin_add( 'Connector' => POE::Component::IRC::Plugin::Connector->new() ); $heap->{irc}->plugin_add( 'Proxy' => $heap->{proxy} ); $heap->{irc}->yield ( connect => { Nick => 'testbot', Server => 'someserver.com' } ); return; } =head1 DESCRIPTION POE::Component::IRC::Plugin::Proxy is a L plugin that provides lightweight IRC proxy/bouncer server to your L bots. It enables multiple IRC clients to be hidden behind a single IRC client-server connection. Spawn a L session and add in a POE::Component::IRC::Plugin::Proxy plugin object, specifying a bindport and a password the connecting IRC clients have to use. When the component is connected to an IRC network a listening port is opened by the plugin for multiple IRC clients to connect. Neat, huh? >;o) This plugin will activate L's raw events (L|POE::Component::IRC/irc_raw>) by calling C<< $irc->raw_events(1) >>. This plugin requires the IRC component to be L or a subclass thereof. =head1 METHODS =head2 C Takes a number of arguments: B<'password'>, the password to require from connecting clients; B<'bindaddress'>, a local address to bind the listener to, default is 'localhost'; B<'bindport'>, what port to bind to, default is 0, ie. randomly allocated by OS; Returns an object suitable for passing to L's C method. =head2 C Takes no arguments. Accesses the listeners C method. See L for details of the return value; =head2 C Takes no arguments. Returns a list of wheel ids of the current connected clients. =head2 C Takes one parameter, a wheel ID to query. Returns undef if an invalid wheel id is passed. In a scalar context returns the time that the client connected in unix time. In a list context returns a list consisting of the peer address, port, tthe connect time and the lag in seconds for that connection. =head1 OUTPUT EVENTS The plugin emits the following L events: =head2 C Emitted when the listener is successfully started. C is the result of the listener C. =head2 C Emitted when a client connects to the listener. C is the wheel ID of the client. =head2 C Emitted when the L fails on a connection. C is the wheel ID of the client. =head2 C Emitted when a connecting client successfully negotiates an IRC session with the plugin. C is the wheel ID of the client. =head2 C Emitted when a connected client disconnects. C is the wheel ID of the client. =head2 C Emitted when the listener is successfully shutdown. C is the result of the listener C. =head1 QUIRKS Connecting IRC clients will not be able to change nickname. This is a feature. =head1 AUTHOR Chris 'BinGOs' Williams =head1 SEE ALSO L L =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/CycleEmpty.pm0000644000175000017500000000721313153565114023423 0ustar bingosbingospackage POE::Component::IRC::Plugin::CycleEmpty; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::CycleEmpty::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use IRC::Utils qw( parse_user uc_irc ); use POE::Component::IRC::Plugin qw( :ALL ); sub new { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %self = @_; return bless \%self, $package; } sub PCI_register { my ($self, $irc) = @_; if (!$irc->isa('POE::Component::IRC::State')) { die __PACKAGE__ . " requires PoCo::IRC::State or a subclass thereof"; } $self->{cycling} = { }; $self->{irc} = $irc; $irc->plugin_register($self, 'SERVER', qw(join kick part quit)); return 1; } sub PCI_unregister { return 1; } sub S_join { my ($self, $irc) = splice @_, 0, 2; my $chan = ${ $_[1] }; delete $self->{cycling}->{$chan}; return PCI_EAT_NONE; } sub S_kick { my ($self, $irc) = splice @_, 0, 2; my $chan = ${ $_[1] }; my $victim = ${ $_[2] }; $self->_cycle($chan) if $victim ne $irc->nick_name(); return PCI_EAT_NONE; } sub S_part { my ($self, $irc) = splice @_, 0, 2; my $parter = parse_user(${ $_[0] }); my $chan = ${ $_[1] }; $self->_cycle($chan) if $parter ne $irc->nick_name(); return PCI_EAT_NONE; } sub S_quit { my ($self, $irc) = splice @_, 0, 2; my $quitter = parse_user(${ $_[0] }); my $channels = @{ $_[2] }[0]; if ($quitter ne $irc->nick_name()) { for my $chan (@{ $channels }) { $self->_cycle($chan); } } return PCI_EAT_NONE; } sub _cycle { my ($self, $chan) = @_; my $irc = $self->{irc}; if ($irc->channel_list($chan) == 1) { if (!$irc->is_channel_operator($chan, $irc->nick_name)) { $self->{cycling}->{ uc_irc($chan) } = 1; my $topic = $irc->channel_topic($chan); $irc->yield(part => $chan); $irc->yield(join => $chan => $irc->channel_key($chan)); $irc->yield(topic => $chan => $topic->{Value}) if defined $topic->{Value}; $irc->yield(mode => $chan => '+k ' . $irc->channel_key($chan)) if defined $irc->channel_key($chan); } } return; } sub is_cycling { my ($self, $value) = @_; return 1 if $self->{cycling}->{ uc_irc($value) }; return; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::CycleEmpty - A PoCo-IRC plugin which cycles channels if they become empty and opless. =head1 SYNOPSIS use POE::Component::IRC::Plugin::CycleEmpty; $irc->plugin_add('CycleEmpty', POE::Component::IRC::Plugin::CycleEmpty->new()); =head1 DESCRIPTION POE::Component::IRC::Plugin::CycleEmpty is a L plugin. When a channel member quits, gets kicked, or parts, the plugin will cycle the channel if the IRC component is alone on that channel and is not a channel operator. If there was a topic or a key set on the channel, they will be restored upon rejoining. This is useful for regaining ops in small channels if the IRC network does not have ChanServ or IRCNet's +R channel mode. This plugin requires the IRC component to be L or a subclass thereof. =head1 METHODS =head2 C Returns a plugin object suitable for feeding to L's C method. =head2 C One argument: A channel name Returns 1 if the plugin is currently cycling that channel, 0 otherwise. Useful if need to ignore the fact that the Component just parted the channel in question. =head1 AUTHOR Hinrik Ern SigurEsson, hinrik.sig@gmail.com =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/Console.pm0000644000175000017500000002226213153565114022750 0ustar bingosbingospackage POE::Component::IRC::Plugin::Console; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::Console::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use IRC::Utils qw(decode_irc); use POE qw(Wheel::SocketFactory Wheel::ReadWrite Filter::IRCD Filter::Line Filter::Stackable); use POE::Component::IRC::Plugin qw( :ALL ); use Scalar::Util qw(looks_like_number); sub new { my $package = shift; croak "$package requires an even number of arguments" if @_ & 1; my %self = @_; return bless \%self, $package; } sub PCI_register { my ($self, $irc) = splice @_, 0, 2; $self->{irc} = $irc; $irc->plugin_register( $self, 'SERVER', qw(all) ); $irc->plugin_register( $self, 'USER', qw(all) ); POE::Session->create( object_states => [ $self => [ qw(_client_error _client_flush _client_input _listener_accept _listener_failed _start _shutdown) ], ], ); return 1; } sub PCI_unregister { my ($self, $irc) = splice @_, 0, 2; delete $self->{irc}; $poe_kernel->post( $self->{SESSION_ID} => '_shutdown' ); $poe_kernel->refcount_decrement( $self->{SESSION_ID}, __PACKAGE__ ); return 1; } sub _dump { my ($arg) = @_; if (ref $arg eq 'ARRAY') { my @elems; for my $elem (@$arg) { push @elems, _dump($elem); } return '['. join(', ', @elems) .']'; } elsif (ref $arg eq 'HASH') { my @pairs; for my $key (keys %$arg) { push @pairs, [$key, _dump($arg->{$key})]; } return '{'. join(', ', map { "$_->[0] => $_->[1]" } @pairs) .'}'; } elsif (ref $arg) { require overload; return overload::StrVal($arg); } elsif (defined $arg) { return $arg if looks_like_number($arg); return "'".decode_irc($arg)."'"; } else { return 'undef'; } } sub _default { my ($self, $irc, $event) = splice @_, 0, 3; return PCI_EAT_NONE if $event eq 'S_raw'; pop @_; my @args = map { $$_ } @_; my @output; for my $i (0..$#args) { push @output, "ARG$i: " . _dump($args[$i]); } for my $wheel_id ( keys %{ $self->{wheels} } ) { next if ( $self->{exit}->{ $wheel_id } or ( not defined ( $self->{wheels}->{ $wheel_id } ) ) ); next if !$self->{authed}{ $wheel_id }; $self->{wheels}->{ $wheel_id }->put("$event: ".join(', ', @output)); } return PCI_EAT_NONE; } sub _start { my ($kernel, $self) = @_[KERNEL, OBJECT]; $self->{SESSION_ID} = $_[SESSION]->ID(); $kernel->refcount_increment( $self->{SESSION_ID}, __PACKAGE__ ); $self->{ircd_filter} = POE::Filter::Stackable->new( Filters => [ POE::Filter::Line->new(), POE::Filter::IRCD->new(), ]); $self->{listener} = POE::Wheel::SocketFactory->new( BindAddress => 'localhost', BindPort => $self->{bindport} || 0, SuccessEvent => '_listener_accept', FailureEvent => '_listener_failed', Reuse => 'yes', ); if ($self->{listener}) { $self->{irc}->send_event( 'irc_console_service' => $self->{listener}->getsockname() ); } else { $self->{irc}->plugin_del( $self ); } return; } sub _listener_accept { my ($kernel, $self, $socket, $peeradr, $peerport) = @_[KERNEL, OBJECT, ARG0 .. ARG2]; my $wheel = POE::Wheel::ReadWrite->new( Handle => $socket, InputFilter => $self->{ircd_filter}, OutputFilter => POE::Filter::Line->new(), InputEvent => '_client_input', ErrorEvent => '_client_error', FlushedEvent => '_client_flush', ); if ( !defined $wheel ) { $self->{irc}->send_event( 'irc_console_rw_fail' => $peeradr => $peerport ); return; } my $wheel_id = $wheel->ID(); $self->{wheels}->{ $wheel_id } = $wheel; $self->{authed}->{ $wheel_id } = 0; $self->{exit}->{ $wheel_id } = 0; $self->{irc}->send_event( 'irc_console_connect' => $peeradr => $peerport => $wheel_id ); return; } sub _listener_failed { delete $_[OBJECT]->{listener}; return; } sub _client_input { my ($kernel, $self, $input, $wheel_id) = @_[KERNEL, OBJECT, ARG0, ARG1]; if ($self->{authed}->{ $wheel_id } && lc ( $input->{command} ) eq 'exit') { $self->{exit}->{ $wheel_id } = 1; if (defined $self->{wheels}->{ $wheel_id }) { $self->{wheels}->{ $wheel_id }->put("ERROR * quiting *"); } return; } if ( $self->{authed}->{ $wheel_id } ) { $self->{irc}->yield( lc ( $input->{command} ) => @{ $input->{params} } ); return; } if (lc ( $input->{command} ) eq 'pass' && $input->{params}->[0] eq $self->{password} ) { $self->{authed}->{ $wheel_id } = 1; $self->{wheels}->{ $wheel_id }->put('NOTICE * Password accepted *'); $self->{irc}->send_event( 'irc_console_authed' => $wheel_id ); return; } $self->{wheels}->{ $wheel_id }->put('NOTICE * Password required * enter PASS *'); return; } sub _client_flush { my ($self, $wheel_id) = @_[OBJECT, ARG0]; return if !$self->{exit}->{ $wheel_id }; delete $self->{wheels}->{ $wheel_id }; return; } sub _client_error { my ($self, $wheel_id) = @_[OBJECT, ARG3]; delete $self->{wheels}->{ $wheel_id }; delete $self->{authed}->{ $wheel_id }; $self->{irc}->send_event( 'irc_console_close' => $wheel_id ); return; } sub _shutdown { my ($kernel, $self) = @_[KERNEL, OBJECT]; delete $self->{listener}; delete $self->{wheels}; delete $self->{authed}; return; } sub getsockname { my $self = shift; return if !$self->{listener}; return $self->{listener}->getsockname(); } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::Console - A PoCo-IRC plugin that provides a lightweight debugging and control console for your bot =head1 SYNOPSIS use POE qw(Component::IRC Component::IRC::Plugin::Console); my $nickname = 'Flibble' . $$; my $ircname = 'Flibble the Sailor Bot'; my $ircserver = 'irc.blahblahblah.irc'; my $port = 6667; my $bindport = 6969; my @channels = ( '#Blah', '#Foo', '#Bar' ); my $irc = POE::Component::IRC->spawn( nick => $nickname, server => $ircserver, port => $port, ircname => $ircname, ) or die "Oh noooo! $!"; POE::Session->create( package_states => [ main => [ qw(_start irc_001 irc_console_service irc_console_connect irc_console_authed irc_console_close irc_console_rw_fail) ], ], ); $poe_kernel->run(); sub _start { $irc->plugin_add( 'Console' => POE::Component::IRC::Plugin::Console->new( bindport => $bindport, password => 'opensesame' ); $irc->yield( register => 'all' ); $irc->yield( connect => { } ); return; } sub irc_001 { $irc->yield( join => $_ ) for @channels; return; } sub irc_console_service { my $getsockname = $_[ARG0]; return; } sub irc_console_connect { my ($peeradr, $peerport, $wheel_id) = @_[ARG0 .. ARG2]; return; } sub irc_console_authed { my $wheel_id = $_[ARG0]; return; } sub irc_console_close { my $wheel_id = $_[ARG0]; return; } sub irc_console_rw_fail { my ($peeradr, $peerport) = @_[ARG0, ARG1]; return; } =head1 DESCRIPTION POE::Component::IRC::Plugin::Console is a L plugin that provides an interactive console running over the loopback network. One connects to the listening socket using a telnet client (or equivalent), authenticate using the applicable password. Once authed one will receive all events that are processed through the component. One may also issue all the documented component commands. =head1 METHODS =head2 C Takes two arguments: B<'password'>, the password to set for *all* console connections; B<'bindport'>, specify a particular port to bind to, defaults to 0, ie. randomly allocated; Returns a plugin object suitable for feeding to L's C method. =head2 C Gives access to the underlying listener's C method. See L for details. =head1 OUTPUT EVENTS The plugin generates the following additional L events: =head2 C Emitted when a listener is successfully spawned. C is the result of C, see above for details. =head2 C Emitted when a client connects to the console. C is the peeradr, C is the peer port and C is the wheel id of the connection. =head2 C Emitted when a client has successfully provided a valid password. C is the wheel id of the connection. =head2 C Emitted when a client terminates a connection. C is the wheel id of the connection. =head2 C Emitted when a L could not be created on a socket. C is the peer's address, C is the peer's port. =head1 AUTHOR Chris 'BinGOs' Williams =head1 SEE ALSO L L =cut POE-Component-IRC-6.90/lib/POE/Component/IRC/Plugin/BotAddressed.pm0000644000175000017500000000755413153565114023720 0ustar bingosbingospackage POE::Component::IRC::Plugin::BotAddressed; our $AUTHORITY = 'cpan:HINRIK'; $POE::Component::IRC::Plugin::BotAddressed::VERSION = '6.90'; use strict; use warnings FATAL => 'all'; use Carp; use POE::Component::IRC::Plugin qw( :ALL ); sub new { my ($package) = shift; croak "$package requires an even number of arguments" if @_ & 1; my %args = @_; $args{lc $_} = delete $args{$_} for keys %args; return bless \%args, $package; } sub PCI_register { my ($self, $irc) = splice @_, 0, 2; $irc->plugin_register( $self, 'SERVER', qw(ctcp_action public) ); return 1; } sub PCI_unregister { return 1; } sub S_ctcp_action { my ($self, $irc) = splice @_, 0, 2; my $who = ${ $_[0] }; my $recipients = ${ $_[1] }; my $what = ${ $_[2] }; my $me = $irc->nick_name(); my $chantypes = join('', @{ $irc->isupport('CHANTYPES') || ['#', '&']}); my $eat = PCI_EAT_NONE; return $eat if $what !~ /$me/i; for my $recipient (@{ $recipients }) { if ($recipient =~ /^[$chantypes]/) { $eat = PCI_EAT_ALL if $self->{eat}; $irc->send_event_next(irc_bot_mentioned_action => $who => [$recipient] => $what); } } return $eat; } sub S_public { my ($self, $irc) = splice @_, 0, 2; my $who = ${ $_[0] }; my $channels = ${ $_[1] }; my $what = ${ $_[2] }; my $me = $irc->nick_name(); my ($cmd) = $what =~ m/^\s*[@%]?\Q$me\E[:,;.!?~]?\s*(.*)$/i; return PCI_EAT_NONE if !defined $cmd && $what !~ /$me/i; for my $channel (@{ $channels }) { if (defined $cmd) { $irc->send_event_next(irc_bot_addressed => $who => [$channel] => $cmd ); } else { $irc->send_event_next(irc_bot_mentioned => $who => [$channel] => $what); } } return $self->{eat} ? PCI_EAT_ALL : PCI_EAT_NONE; } 1; =encoding utf8 =head1 NAME POE::Component::IRC::Plugin::BotAddressed - A PoCo-IRC plugin that generates events when you are addressed =head1 SYNOPSIS use POE::Component::IRC::Plugin::BotAddressed; $irc->plugin_add( 'BotAddressed', POE::Component::IRC::Plugin::BotAddressed->new() ); sub irc_bot_addressed { my ($kernel, $heap) = @_[KERNEL, HEAP]; my $nick = ( split /!/, $_[ARG0] )[0]; my $channel = $_[ARG1]->[0]; my $what = $_[ARG2]; print "$nick addressed me in channel $channel with the message '$what'\n"; } sub irc_bot_mentioned { my ($nick) = ( split /!/, $_[ARG0] )[0]; my ($channel) = $_[ARG1]->[0]; my ($what) = $_[ARG2]; print "$nick mentioned my name in channel $channel with the message '$what'\n"; } =head1 DESCRIPTION POE::Component::IRC::Plugin::BotAddressed is a L plugin. It watches for public channel traffic (i.e. C and C) and will generate an C, C or C event if its name comes up in channel discussion. =head1 METHODS =head2 C One optional argument: B<'eat'>, set to true to make the plugin eat the C / C event and only generate an appropriate event, default is false. Returns a plugin object suitable for feeding to L's C method. =head1 OUTPUT EVENTS =head2 C Has the same parameters passed as L|POE::Component::IRC/irc_public>. C contains the message with the addressed nickname removed, ie. Assuming that your bot is called LameBOT, and someone says 'LameBOT: dance for me', you will actually get 'dance for me'. =head2 C Has the same parameters passed as L|POE::Component::IRC/irc_public>. =head2 C Has the same parameters passed as L|POE::Component::IRC/irc_ctcp_*>. =head1 AUTHOR Chris 'BinGOs' Williams =cut POE-Component-IRC-6.90/META.yml0000644000175000017500000000242513153565114015252 0ustar bingosbingos--- abstract: 'A fully event-driven IRC client module' author: - 'Chris Williams ' - 'Hinrik Örn Sigurðsson ' build_requires: Test::Differences: '0.61' Test::More: '0.47' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.010, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: POE-Component-IRC no_index: directory: - examples - t - utils - xt recommends: POE::Component::Client::DNS: '0.99' requires: IRC::Utils: '0.12' List::Util: '1.33' POE: '1.311' POE::Component::Syndicator: '0' POE::Driver::SysRW: '0' POE::Filter::IRCD: '2.42' POE::Filter::Line: '0' POE::Filter::Stackable: '0' POE::Filter::Stream: '0' POE::Session: '0' POE::Wheel::ReadWrite: '0' POE::Wheel::SocketFactory: '0' perl: '5.008001' resources: bugtracker: https://rt.cpan.org/Public/Dist/Display.html?Name=POE-Component-IRC homepage: http://metacpan.org/release/POE-Component-IRC license: http://dev.perl.org/licenses/ repository: git://github.com/bingos/poe-component-irc.git version: '6.90' x_authority: cpan:HINRIK x_serialization_backend: 'YAML::Tiny version 1.70' POE-Component-IRC-6.90/Makefile.PL0000644000175000017500000000461113153565114015752 0ustar bingosbingos# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.010. use strict; use warnings; use 5.008001; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "A fully event-driven IRC client module", "AUTHOR" => "Chris Williams , Hinrik \x{d6}rn Sigur\x{f0}sson ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "POE-Component-IRC", "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.008001", "NAME" => "POE::Component::IRC", "PREREQ_PM" => { "IRC::Utils" => "0.12", "List::Util" => "1.33", "POE" => "1.311", "POE::Component::Syndicator" => 0, "POE::Driver::SysRW" => 0, "POE::Filter::IRCD" => "2.42", "POE::Filter::Line" => 0, "POE::Filter::Stackable" => 0, "POE::Filter::Stream" => 0, "POE::Session" => 0, "POE::Wheel::ReadWrite" => 0, "POE::Wheel::SocketFactory" => 0 }, "TEST_REQUIRES" => { "Test::Differences" => "0.61", "Test::More" => "0.47" }, "VERSION" => "6.90", "test" => { "TESTS" => "t/01_base/*.t t/02_behavior/*.t t/03_subclasses/*.t t/04_plugins/01_ctcp/*.t t/04_plugins/02_connector/*.t t/04_plugins/03_botaddressed/*.t t/04_plugins/04_bottraffic/*.t t/04_plugins/05_isupport/*.t t/04_plugins/06_plugman/*.t t/04_plugins/07_console/*.t t/04_plugins/08_proxy/*.t t/04_plugins/09_nickreclaim/*.t t/04_plugins/10_followtail/*.t t/04_plugins/11_cycleempty/*.t t/04_plugins/12_autojoin/*.t t/04_plugins/13_botcommand/*.t t/04_plugins/14_logger/*.t t/04_plugins/15_nickservid/*.t t/04_plugins/16_whois/*.t t/04_plugins/17_dcc/*.t t/05_regression/*.t" } ); my %FallbackPrereqs = ( "IRC::Utils" => "0.12", "List::Util" => "1.33", "POE" => "1.311", "POE::Component::Syndicator" => 0, "POE::Driver::SysRW" => 0, "POE::Filter::IRCD" => "2.42", "POE::Filter::Line" => 0, "POE::Filter::Stackable" => 0, "POE::Filter::Stream" => 0, "POE::Session" => 0, "POE::Wheel::ReadWrite" => 0, "POE::Wheel::SocketFactory" => 0, "Test::Differences" => "0.61", "Test::More" => "0.47" ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs);