diff --git a/MANIFEST b/MANIFEST index ef71bdda..89860d60 100644 --- a/MANIFEST +++ b/MANIFEST @@ -35,7 +35,6 @@ lib/POE/Component/IRC/Cookbook/BasicBot.pm lib/POE/Component/IRC/Cookbook/Disconnecting.pm lib/POE/Component/IRC/Cookbook/Resolver.pm lib/POE/Component/IRC/Cookbook/Translator.pm -lib/POE/Component/IRC/Pipeline.pm lib/POE/Component/IRC/Plugin.pm lib/POE/Component/IRC/Plugin/AutoJoin.pm lib/POE/Component/IRC/Plugin/BotAddressed.pm diff --git a/Makefile.PL b/Makefile.PL index 4a7b93cf..44e7b9a5 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -43,6 +43,7 @@ requires 'File::Basename' => 0; requires 'File::Spec' => 0; requires 'Socket' => 0; requires 'POE' => 0.3202; +requires 'POE::Component::Pluggable' => '1.06'; requires 'POE::Wheel::SocketFactory' => 0; requires 'POE::Wheel::ReadWrite' => 0; requires 'POE::Driver::SysRW' => 0; diff --git a/lib/POE/Component/IRC.pm b/lib/POE/Component/IRC.pm index ba9c659c..9b062cb6 100755 --- a/lib/POE/Component/IRC.pm +++ b/lib/POE/Component/IRC.pm @@ -9,12 +9,12 @@ use POE::Filter::IRCD; use POE::Filter::IRC::Compat; use POE::Component::IRC::Common qw(:ALL); use POE::Component::IRC::Constants qw(:ALL); -use POE::Component::IRC::Pipeline; 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; +use base qw(POE::Component::Pluggable); our $VERSION = '5.78'; our $REVISION = do {my@r=(q$Revision$=~/\d+/g);sprintf"%d"."%04d"x$#r,@r}; @@ -112,11 +112,6 @@ sub _create { _stop debug connect - dcc - dcc_accept - dcc_resume - dcc_chat - dcc_close _resolve_addresses _do_connect _send_login @@ -138,7 +133,12 @@ sub _create { $self->{OBJECT_STATES_HASHREF} = { %event_map, - quote => 'sl', + quote => 'sl', + dcc => '_dcc_dispatch', + dcc_accept => '_dcc_dispatch', + dcc_resume => '_dcc_dispatch', + dcc_chat => '_dcc_dispatch', + dcc_close => '_dcc_dispatch', }; return; @@ -253,9 +253,9 @@ sub send_event { # Hack to make plugin_add/del send events from OUR session sub __send_event { - my($self, $event, @args) = @_[ OBJECT, ARG0, ARG1 .. $#_ ]; + my ($self, $event, @args) = @_[OBJECT, ARG0..$#_]; # Actually send the event... - $self->_send_event( $event, @args ); + $self->_send_event($event, @args); return 1; } @@ -265,7 +265,7 @@ sub __send_event { # Changed to a method by BinGOs, 21st January 2005. # Amended by BinGOs (2nd February 2005) use call to send events to # *our* session first. -sub _send_event { +sub _send_event { my ($self, $event, @args) = @_; my $kernel = $poe_kernel; my $session = $kernel->get_active_session()->ID(); @@ -276,7 +276,8 @@ sub _send_event { # don't eat the events before *our* session can process them. *sigh* for my $value (values %{ $self->{events}->{irc_all} }, - values %{ $self->{events}->{$event} }) { + values %{ $self->{events}->{$event} }) + { $sessions{$value} = $value; } @@ -286,11 +287,11 @@ sub _send_event { my @extra_args; # Let the plugin system process this - return 1 if $self->_plugin_process( + return 1 if $self->_pluggable_process( 'SERVER', $event, \( @args ), - \@extra_args + \@extra_args, ) == PCI_EAT_ALL; push @args, @extra_args if @extra_args; @@ -808,79 +809,13 @@ sub ctcp { return; } -sub dcc { - my ($kernel, $self, $nick, $type, $file, $blocksize, $timeout) - = @_[KERNEL, OBJECT, ARG0..ARG4]; +sub _dcc_dispatch { + my ($state, $self, @args) = @_[STATE, OBJECT, ARG0..$#_]; - $type = uc $type; + # DCC type (SEND, USER, etc) should be in upper case + $args[2] = uc $args[2] if $state eq 'dcc'; - # Let the plugin system process this - return 1 if $self->_plugin_process( - 'USER', - 'DCC', - \$nick, - \$type, - \$file, - \$blocksize, - \$timeout, - ) == PCI_EAT_ALL; - - return; -} - -sub dcc_accept { - my ($kernel, $self, $cookie, $myfile) = @_[KERNEL, OBJECT, ARG0, ARG1]; - - # Let the plugin system process this - return 1 if $self->_plugin_process( - 'USER', - 'DCC_ACCEPT', - \$cookie, - \$myfile - ) == PCI_EAT_ALL; - - return; -} - -sub dcc_chat { - my ($kernel, $self, $id, @data) = @_[KERNEL, OBJECT, ARG0..$#_]; - - # Let the plugin system process this - return 1 if $self->_plugin_process( - 'USER', - 'DCC_CHAT', - \$id, - \( @data ), - ) == PCI_EAT_ALL; - - return; -} - -# Terminate a DCC connection manually. -sub dcc_close { - my ($kernel, $self, $id) = @_[KERNEL, OBJECT, ARG0]; - - # Let the plugin system process this - return 1 if $self->_plugin_process( - 'USER', - 'DCC_CLOSE', - \$id, - ) == PCI_EAT_ALL; - - return; -} - -sub dcc_resume { - my ($kernel, $self, $cookie) = @_[KERNEL, OBJECT, ARG0]; - - # Let the plugin system process this - return 1 if $self->_plugin_process( - 'USER', - 'DCC_RESUME', - \$cookie, - ) == PCI_EAT_ALL; - - return; + $self->_pluggable_process(USER => $state => \(@args)); } # The way /notify is implemented in IRC clients. @@ -963,6 +898,12 @@ sub spawn { my $self = bless { }, $package; $self->_create(); + $self->_pluggable_init( + prefix => 'irc_', + reg_prefix => 'PCI_', + types => { SERVER => 'S', USER => 'U' }, + ); + my $options = delete $params{options}; my $alias = delete $params{alias}; @@ -1172,7 +1113,8 @@ sub register { if (!$self->{sessions}->{$sender_id}->{refcnt} && $session != $sender) { $kernel->refcount_increment($sender_id, PCI_REFCOUNT_TAG); } - $self->{sessions}->{$sender_id}->{refcnt}++ + + $self->{sessions}->{$sender_id}->{refcnt}++; } # BINGOS: @@ -1200,8 +1142,10 @@ sub shutdown { $kernel->alarm_remove_all(); $kernel->alias_remove($_) for $kernel->alias_list($session); delete $self->{$_} for qw(socketfactory dcc wheelmap); + # Delete all plugins that are loaded. - $self->plugin_del($_) for keys %{ $self->plugin_list() }; + $self->_pluggable_destroy(); + $self->{resolver}->shutdown() if $self->{resolver}; $kernel->call($session => sl_high => $cmd) if $self->{socket}; @@ -1247,7 +1191,7 @@ sub sl_prioritized { # Get the first word for the plugin system if (my ($event) = $msg =~ /^(\w+)\s*/ ) { # Let the plugin system process this - return 1 if $self->_plugin_process( + return 1 if $self->_pluggable_process( 'USER', $event, \$msg, @@ -1589,187 +1533,10 @@ sub resolver { return $_[0]->{resolver}; } -# accesses the plugin pipeline -sub pipeline { - my ($self) = @_; - - if (!eval { $self->{PLUGINS}->isa('POE::Component::IRC::Pipeline') }) { - $self->{PLUGINS} = POE::Component::IRC::Pipeline->new($self); - } - return $self->{PLUGINS}; -} - -# Adds a new plugin object -sub plugin_add { - my ($self, $name, $plugin) = @_; - my $pipeline = $self->pipeline; - - if (!defined $name || !defined $plugin) { - carp 'Please supply a name and the plugin object to be added!'; - return; - } - - return $pipeline->push($name => $plugin); -} - -# Removes a plugin object -sub plugin_del { - my ($self, $name) = @_; - - if (!defined $name) { - carp 'Please supply a name/object for the plugin to be removed!'; - return; - } - - my $return = scalar $self->pipeline->remove($name); - carp "$@" if $@; - - return $return; -} - -# Gets the plugin object -sub plugin_get { - my ($self, $name) = @_; - - if (!defined $name) { - carp 'Please supply a name/object for the plugin to be removed!'; - return; - } - - return scalar $self->pipeline->get($name); -} - -# Lists loaded plugins -sub plugin_list { - my ($self) = @_; - my $pipeline = $self->pipeline; - my %return; - - for my $plugin (@{ $pipeline->{PIPELINE} }) { - $return{ $pipeline->{PLUGS}{$plugin} } = $plugin; - } - - return \%return; -} - -# Lists loaded plugins in order! -sub plugin_order { - my ($self) = @_; - return $self->pipeline->{PIPELINE}; -} - -# Lets a plugin register for certain events -sub plugin_register { - my ($self, $plugin, $type, @events) = @_; - my $pipeline = $self->pipeline; - - if (!defined $plugin) { - carp 'Please supply the plugin object to register!'; - return; - } - - if (!defined $type || $type !~ /SERVER|USER/) { - carp 'Type should be SERVER or USER!'; - return; - } - - if (!@events) { - carp 'Please supply at least one event to register!'; - return; - } - - for my $event (@events) { - if (ref $event eq 'ARRAY') { - @{ $pipeline->{HANDLES}{$plugin}{$type} }{ map { lc } @$event } = (1) x @$event; - } - else { - $pipeline->{HANDLES}{$plugin}{$type}{lc $event} = 1; - } - } - - return 1; -} - -# Lets a plugin unregister events -sub plugin_unregister { - my ($self, $plugin, $type, @events) = @_; - my $pipeline = $self->pipeline; - - if (!defined $type || $type !~ /SERVER|USER/) { - carp 'Type should be SERVER or USER!'; - return; - } - - if (!defined $plugin) { - carp 'Please supply the plugin object to register!'; - return; - } - - if (!@events) { - carp 'Please supply at least one event to unregister!'; - return; - } - - for my $event (@events) { - if (ref $event eq 'ARRAY') { - for my $e (map { lc } @$event) { - if (!delete $pipeline->{HANDLES}{$plugin}{$type}{$e}) { - carp "The event '$e' does not exist!"; - next; - } - } - } - else { - $event = lc $event; - if (!delete $pipeline->{HANDLES}{$plugin}{$type}{$event}) { - carp "The event '$event' does not exist!"; - next; - } - } - } - - return 1; -} - -# Process an input event for plugins -sub _plugin_process { - my ($self, $type, $event, @args) = @_; - my $pipeline = $self->pipeline; - - $event = lc $event; - $event =~ s/^irc_//; - - my $sub = ($type eq 'SERVER' ? 'S' : 'U') . "_$event"; - my $return = PCI_EAT_NONE; - - if ( $self->can($sub) ) { - eval { $self->$sub( $self, @args ) }; - warn "$@\n" if $@; - } - - for my $plugin (@{ $pipeline->{PIPELINE} }) { - next if $self eq $plugin; - next if !$pipeline->{HANDLES}{$plugin}{$type}{$event} - && !$pipeline->{HANDLES}{$plugin}{$type}{all}; - - my $ret = PCI_EAT_NONE; - my $name = ($pipeline->get($plugin))[1]; - - if ( $plugin->can($sub) ) { - eval { $ret = $plugin->$sub($self, @args) }; - warn "${name}->$sub call failed with '$@'\n" if $@ && $self->{plugin_debug}; - } - elsif ( $plugin->can('_default') ) { - eval { $ret = $plugin->_default($self, $sub, @args) }; - warn "${name}->_default call failed with '$@'\n" if $@ && $self->{plugin_debug}; - } - - return $return if $ret == PCI_EAT_PLUGIN; - $return = PCI_EAT_ALL if $ret == PCI_EAT_CLIENT; - return PCI_EAT_ALL if $ret == PCI_EAT_ALL; - } - - return $return; +sub _pluggable_event { + my ($self, @args) = @_; + $self->yield(__send_event => @args); + return; } 1; @@ -1933,6 +1700,10 @@ A number of useful plugins have made their way into the core distribution: =over +=item L + +Provides DCC support. Loaded by default. + =item L Keeps you on your favorite channels throughout reconnects and even kicks. @@ -2139,7 +1910,9 @@ make it die() >;] =head1 METHODS -These are methods supported by the POE::Component::IRC object. +These are methods supported by the POE::Component::IRC object. It also +inherits a few from L. +See its documentation for details. =head2 C @@ -2152,7 +1925,7 @@ Takes no arguments. Returns a scalar containing the current nickname that the bot is using. =head2 C - + Takes no arguments. Returns the IP address being used. =head2 C @@ -2246,11 +2019,6 @@ Returns an arrayref that was originally requested to be delayed. Returns a reference to the L object that is internally created by the component. -=head2 C - -Returns a reference to the L -object used by the plugin system. - =head2 C Sends an event through the components event handling system. These will get @@ -2460,7 +2228,7 @@ 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, C, C, C, C +=head3 C See the L (loaded by default) documentation for DCC-related commands. @@ -2768,15 +2536,6 @@ message. Sent whenever someone leaves a channel that you're on. ARG0 is the person's nick!hostmask. ARG1 is the channel name. ARG2 is the part message. -=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 Sent whenever you receive a PRIVMSG command that was sent to a @@ -2887,7 +2646,28 @@ Emitted whenever a SOCKS connection is rejected by a SOCKS server. ARG0 is the SOCKS code, ARG1 the SOCKS server address, ARG2 the SOCKS port and ARG3 the SOCKS user id ( if defined ). -=head3 All numeric events (see RFC 1459) +=head2 Somewhat Less Important Events + +=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. Don't worry +about it. ARG0 is the text of the server's message. + +=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 @@ -2901,18 +2681,6 @@ is the name of the server which sent the message. ARG1 is the text of the message. ARG2 is an ARRAYREF of the parsed message, so there is no need to parse ARG1 yourself. -=head2 Somewhat Less Important Events - -=head3 C - -See the L (loaded by default) -documentation for DCC-related events. - -=head3 C - -A weird, non-RFC-compliant message from an IRC server. Don't worry -about it. ARG0 is the text of the server's message. - =head1 SIGNALS The component will handle a number of custom signals that you may send using @@ -2942,7 +2710,7 @@ _start handler: my ($kernel, $session) = @_[KERNEL, SESSION]; # Registering with multiple pocoircs for 'all' IRC events - $kernel->signal( $kernel, 'POCOIRC_REGISTER', $session->ID(), 'all' ); + $kernel->signal($kernel, 'POCOIRC_REGISTER', $session->ID(), 'all'); return: } @@ -2962,7 +2730,7 @@ Each poco-irc will send your session an C event: $heap->{irc_objects}->{ $sender_id } = $irc_object; # Make the poco connect - $irc_object->yield( connect => { } ); + $irc_object->yield(connect => { }); return; } @@ -2975,7 +2743,7 @@ 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' ); + $poe_kernel->signal($poe_kernel, 'POCOIRC_SHUTDOWN'); Any additional parameters passed to the signal will become your quit messages on each IRC network. diff --git a/lib/POE/Component/IRC/Pipeline.pm b/lib/POE/Component/IRC/Pipeline.pm deleted file mode 100644 index 16565571..00000000 --- a/lib/POE/Component/IRC/Pipeline.pm +++ /dev/null @@ -1,530 +0,0 @@ -package POE::Component::IRC::Pipeline; - -use strict; -use warnings; -use Carp; - -our $VERSION = '0.06'; - -sub new { - my ($package, $irc) = @_; - - return bless { - PLUGS => {}, - PIPELINE => [], - HANDLES => {}, - IRC => $irc, - DEBUG => $irc->{plugin_debug}, - }, $package; -} - -sub push { - my ($self, $alias, $plug) = @_; - - if ($self->{PLUGS}{$alias}) { - carp "Plugin named '$alias' already exists ($self->{PLUGS}{$alias})"; - return; - } - - if (!eval { $plug->PCI_register($self->{IRC}) } ) { - carp "${alias}->PCI_register call failed with '$@'" if $@ && $self->{DEBUG}; - return; - } - - push @{ $self->{PIPELINE} }, $plug; - $self->{PLUGS}{$alias} = $plug; - $self->{PLUGS}{$plug} = $alias; - $self->{IRC}->yield(__send_event => irc_plugin_add => $alias => $plug); - - return scalar @{ $self->{PIPELINE} }; -} - -sub pop { - my ($self) = @_; - - return if !@{ $self->{PIPELINE} }; - - my $plug = pop @{ $self->{PIPELINE} }; - my $alias = delete $self->{PLUGS}{$plug}; - delete $self->{PLUGS}{$alias}; - delete $self->{HANDLES}{$plug}; - - eval { $plug->PCI_unregister($self->{IRC}) }; - carp "${alias}->PCI_unregister call failed with '$@'" if $@ && $self->{DEBUG}; - $self->{IRC}->yield(__send_event => irc_plugin_del => $alias, $plug); - - return wantarray() ? ($plug, $alias) : $plug; -} - -sub unshift { - my ($self, $alias, $plug) = @_; - - if ($self->{PLUGS}{$alias}) { - $@ = "Plugin named '$alias' already exists ($self->{PLUGS}{$alias})"; - return; - } - - if (!eval { $plug->PCI_register($self->{IRC}) } ) { - carp "${alias}->PCI_register call failed with '$@'" if $@ && $self->{DEBUG}; - return; - } - - unshift @{ $self->{PIPELINE} }, $plug; - $self->{PLUGS}{$alias} = $plug; - $self->{PLUGS}{$plug} = $alias; - $self->{IRC}->yield(__send_event => irc_plugin_add => $alias => $plug); - - return scalar @{ $self->{PIPELINE} }; -} - -sub shift { - my ($self) = @_; - - return if !@{ $self->{PIPELINE} }; - - my $plug = shift @{ $self->{PIPELINE} }; - my $alias = delete $self->{PLUGS}{$plug}; - delete $self->{PLUGS}{$alias}; - delete $self->{HANDLES}{$plug}; - - eval { $plug->PCI_unregister($self->{IRC}) }; - carp "${alias}->PCI_unregister call failed with '$@'" if $@ && $self->{DEBUG}; - - $self->{IRC}->yield(__send_event => irc_plugin_del => $alias, $plug); - return wantarray() ? ($plug, $alias) : $plug; -} - - -sub replace { - my ($self, $old, $new_a, $new_p) = @_; - - my ($old_a, $old_p) = ref $old - ? ($self->{PLUGS}{$old}, $old) - : ($old, $self->{PLUGS}{$old}); - - if (!$old_p) { - carp "Plugin '$old_a' does not exist"; - return; - } - - delete $self->{PLUGS}{$old_p}; - delete $self->{PLUGS}{$old_a}; - delete $self->{HANDLES}{$old_p}; - eval { $old_p->PCI_unregister($self->{IRC}) }; - carp "${old_a}->PCI_unregister call failed with '$@'" if $@ && $self->{DEBUG}; - $self->{IRC}->yield(__send_event => irc_plugin_del => $old_a, $old_p); - - if ($self->{PLUGS}{$new_a}) { - carp "Plugin named '$new_a' already exists ($self->{PLUGS}{$new_a})"; - return; - } - - if (!eval { $new_p->PCI_register($self->{IRC}) } ) { - carp "${new_a}->PCI_register call failed with '$@'" if $@ && $self->{DEBUG}; - return; - } - - $self->{PLUGS}{$new_p} = $new_a; - $self->{PLUGS}{$new_a} = $new_p; - - for my $plugin (@{ $self->{PIPELINE} }) { - $plugin = $new_p; - last if $plugin == $old_p; - } - - $self->{IRC}->yield(__send_event => irc_plugin_add => $new_a => $new_p); - return 1; -} - - -sub remove { - my ($self, $old) = @_; - - my ($old_a, $old_p) = ref $old - ? ($self->{PLUGS}{$old}, $old) - : ($old, $self->{PLUGS}{$old}); - - if (!defined $old_p) { - carp "Plugin '$old_a' does not exist"; - return; - } - - delete $self->{PLUGS}{$old_p}; - delete $self->{PLUGS}{$old_a}; - delete $self->{HANDLES}{$old_p}; - - for (my $i = 0; $i <= $#{ $self->{PIPELINE} }; $i++) { - if ($self->{PIPELINE}->[$i] == $old_p) { - splice @{ $self->{PIPELINE} }, $i, 1; - last; - } - } - - eval { $old_p->PCI_unregister($self->{IRC}) }; - carp "${old_a}->PCI_unregister call failed with '$@'" if $@ && $self->{DEBUG}; - $self->{IRC}->yield(__send_event => irc_plugin_del => $old_a, $old_p); - - return wantarray ? ($old_p, $old_a) : $old_p; -} - - -sub get { - my ($self, $old) = @_; - - my ($old_a, $old_p) = ref $old - ? ($self->{PLUGS}{$old}, $old) - : ($old, $self->{PLUGS}{$old}); - - if (!defined $old_p) { - carp "Plugin '$old_a' does not exist"; - return; - } - - return wantarray ? ($old_p, $old_a) : $old_p; -} - - -sub get_index { - my ($self, $old) = @_; - - my ($old_a, $old_p) = ref $old - ? ($self->{PLUGS}{$old}, $old) - : ($old, $self->{PLUGS}{$old}); - - if (!defined $old_p) { - carp "Plugin '$old_a' does not exist"; - return -1; - } - - for (my $i = 0; $i <= $#{ $self->{PIPELINE} }; $i++) { - return $i if $self->{PIPELINE}->[$i] == $old_p; - } - - return -1; -} - - -sub insert_before { - my ($self, $old, $new_a, $new_p) = @_; - - my ($old_a, $old_p) = ref $old - ? ($self->{PLUGS}{$old}, $old) - : ($old, $self->{PLUGS}{$old}); - - if (!defined $old_p) { - carp "Plugin '$old_a' does not exist"; - return; - } - - if ($self->{PLUGS}{$new_a}) { - carp "Plugin named '$new_a' already exists ($self->{PLUGS}{$new_a})"; - return; - } - - if (!eval { $new_p->PCI_register($self->{IRC}) } ) { - carp "${new_a}->PCI_register call failed with '$@'" if $@ && $self->{DEBUG}; - return; - } - - $self->{PLUGS}{$new_p} = $new_a; - $self->{PLUGS}{$new_a} = $new_p; - - for (my $i = 0; $i <= $#{ $self->{PIPELINE} }; $i++) { - splice(@{ $self->{PIPELINE} }, $i, 0, $new_p); - last if $self->{PIPELINE}->[$i] == $old_p; - } - - $self->{IRC}->yield(__send_event => irc_plugin_add => $new_a => $new_p); - return 1; -} - - -sub insert_after { - my ($self, $old, $new_a, $new_p) = @_; - - my ($old_a, $old_p) = ref $old - ? ($self->{PLUGS}{$old}, $old) - : ($old, $self->{PLUGS}{$old}); - - if (!defined $old_p) { - carp "Plugin '$old_a' does not exist"; - return; - } - - if ($self->{PLUGS}{$new_a}) { - carp "Plugin named '$new_a' already exists ($self->{PLUGS}{$new_a})"; - return; - } - - if (!eval { $new_p->PCI_register($self->{IRC}) } ) { - carp "${new_a}->PCI_register call failed with '$@'" if $@ && $self->{DEBUG}; - return; - } - - $self->{PLUGS}{$new_p} = $new_a; - $self->{PLUGS}{$new_a} = $new_p; - - for (my $i = 0; $i <= $#{ $self->{PIPELINE} }; $i++) { - splice(@{ $self->{PIPELINE} }, $i+1, 0, $new_p); - last if $self->{PIPELINE}->[$i] == $old_p; - } - - $self->{IRC}->yield(__send_event => irc_plugin_add => $new_a => $new_p); - return 1; -} - - -sub bump_up { - my ($self, $old, $diff) = @_; - my $idx = $self->get_index($old); - - return -1 if $idx < 0; - - my $pipeline = $self->{PIPELINE}; - $diff ||= 1; - my $pos = $idx - $diff; - if ($pos < 0) { - carp "$idx - $diff is negative, moving to head of the pipeline"; - } - - splice(@$pipeline, $pos, 0, splice(@$pipeline, $idx, 1)); - return $pos; -} - - -sub bump_down { - my ($self, $old, $diff) = @_; - my $idx = $self->get_index($old); - - return -1 if $idx < 0; - - my $pipeline = $self->{PIPELINE}; - $diff ||= 1; - my $pos = $idx + $diff; - if ($pos >= @$pipeline) { - carp "$idx + $diff is too high, moving to back of the pipeline"; - } - - splice(@$pipeline, $pos, 0, splice(@$pipeline, $idx, 1)); - return $pos; -} - -1; -__END__ - -=head1 NAME - -POE::Component::IRC::Pipeline - the plugin pipeline for POE::Component::IRC. - -=head1 SYNOPSIS - - use POE qw( Component::IRC ); - use POE::Component::IRC::Pipeline; - use My::Plugin; - - my $irc = POE::Component::IRC->spawn; - - # the following operations are presented in pairs - # the first is the general procedure, the second is - # the specific way using the pipeline directly - - # to install a plugin - $irc->plugin_add(mine => My::Plugin->new); - $irc->pipeline->push(mine => My::Plugin->new); - - # to remove a plugin - $irc->plugin_del('mine'); # or the object - $irc->pipeline->remove('mine'); # or the object - - # to get a plugin - my $plug = $irc->plugin_get('mine'); - my $plug = $irc->pipeline->get('mine'); - - # there are other very specific operations that - # the pipeline offers, demonstrated here: - - # to get the pipeline object itself - my $pipe = $irc->pipeline; - - # to install a plugin at the front of the pipeline - $pipe->unshift(mine => My::Plugin->new); - - # to remove the plugin at the end of the pipeline - my $plug = $pipe->pop; - - # to remove the plugin at the front of the pipeline - my $plug = $pipe->shift; - - # to replace a plugin with another - $pipe->replace(mine => newmine => My::Plugin->new); - - # to insert a plugin before another - $pipe->insert_before(mine => newmine => My::Plugin->new); - - # to insert a plugin after another - $pipe->insert_after(mine => newmine => My::Plugin->new); - - # to get the location in the pipeline of a plugin - my $index = $pipe->get_index('mine'); - - # to move a plugin closer to the front of the pipeline - $pipe->bump_up('mine'); - - # to move a plugin closer to the end of the pipeline - $pipe->bump_down('mine'); - -=head1 DESCRIPTION - -POE::Component::IRC::Pipeline defines the Plugin pipeline system for -POE::Component::IRC instances. - -=head1 METHODS - -=over - -=item C - -Takes one argument, the POE::Component::IRC object to attach to. - -=item C - -Take two arguments, an alias for a plugin and the plugin object itself. -Adds the plugin to the end of the pipeline and registers it. If successful, -it returns the size of the pipeline. - - my $new_size = $pipe->push($name, $plug); - -=item C - -Take two arguments, an alias for a plugin and the plugin object itself. -Adds the plugin to the beginning of the pipeline and registers it. -This will yield an 'irc_plugin_add' event. If successful, it returns the -size of the pipeline. - - my $new_size = $pipe->push($name, $plug); - -=item C - -Take three arguments, the old plugin or its alias, an alias for the new plugin -and the new plugin object itself. Removes the old plugin (yielding an -'irc_plugin_del' event) and replaces it with the new plugin.This will yield an -'irc_plugin_add' event. If successful, it returns a true value. - - my $success = $pipe->replace($name, $new_name, $new_plug); - my $success = $pipe->replace($plug, $new_name, $new_plug); - -=item C - -Takes three arguments, the plugin that is relative to the operation, an alias -for the new plugin and the new plugin object itself. The new plugin is placed -just prior to the other plugin in the pipeline. If successful, it returns a -true value. - - my $success = $pipe->insert_before($name, $new_name, $new_plug); - my $success = $pipe->insert_before($plug, $new_name, $new_plug); - -=item C - -Takes three arguments, the plugin that is relative to the operation, an alias -for the new plugin and the new plugin object itself. The new plugin is placed -just after to the other plugin in the pipeline. If successful, it returns -a true value. - - my $success = $pipe->insert_after($name, $new_name, $new_plug); - my $success = $pipe->insert_after($plug, $new_name, $new_plug); - -=item C - -Takes one or two arguments, the plugin or its alias, and the distance to bump -the plugin. The distance defaults to 1. The plugin will be moved the given -distance closer to the front of the pipeline. A warning is issued alerting you -if it would have been moved past the beginning of the pipeline, and the plugin -is placed at the beginning. If successful, the new index of the plugin in -the pipeline is returned. - - my $pos = $pipe->bump_up($name); - my $pos = $pipe->bump_up($plug); - my $pos = $pipe->bump_up($name, $delta); - my $pos = $pipe->bump_up($plug, $delta); - -=item C - -Takes one or two arguments, the plugin or its alias, and the distance to bump -the plugin. The distance defaults to 1. The plugin will be moved the given -distance closer to the end of the pipeline. A warning is issued alerting you -if it would have been moved past the end of the pipeline, and the plugin is -placed at the end.If successful, the new index of the plugin in the pipeline -is returned. - - my $pos = $pipe->bump_down($name); - my $pos = $pipe->bump_down($plug); - my $pos = $pipe->bump_down($name, $delta); - my $pos = $pipe->bump_down($plug, $delta); - -=item C - -Takes one argument, a plugin or its alias. The plugin is removed from the -pipeline. This will yield an 'irc_plugin_del' event. If successful, it returns -plugin and its alias in list context or just the plugin in scalar context. - - my ($plug, $name) = $pipe->remove($the_name); - my ($plug, $name) = $pipe->remove($the_plug); - my $plug = $pipe->remove($the_name); - my $plug = $pipe->remove($the_plug); - -=item C - -Takes no arguments. The first plugin in the pipeline is removed. This will -yield an 'irc_plugin_del' event. If successful, it returns the plugin and its -alias in list context or just the plugin in scalar context. - - my ($plug, $name) = $pipe->shift; - my $plug = $pipe->shift; - -=item C - -Takes no arguments. The last plugin in the pipeline is removed. This will yield -an 'irc_plugin_del' event. If successful, it returns the plugin and its alias -in list context or just the plugin in scalar context. - - my ($plug, $name) = $pipe->pop; - my $plug = $pipe->pop; - -=item C - -Takes one argument, a plugin or its alias. If successful, it returns the -plugin and its alias in list context or just the plugin in scalar context. - - my ($plug, $name) = $pipe->get($the_name); - my ($plug, $name) = $pipe->get($the_plug); - my $plug = $pipe->get($the_name); - my $plug = $pipe->get($the_plug); - -=item C - -Takes one argument, a plugin or its alias. It returns the index -in the pipeline if successful, otherwise B<-1 will be returned, not undef>. - - my $pos = $pipe->get_index($name); - my $pos = $pipe->get_index($plug); - -=back - -=head1 BUGS - -None known so far. - -=head1 SEE ALSO - -L, - -L. Also look at - -L which does something -similar for session events. - -=head1 AUTHOR - -Jeff C Pinyan, . - -=cut diff --git a/lib/POE/Component/IRC/Plugin.pm b/lib/POE/Component/IRC/Plugin.pm index f2838744..bcd2c67a 100644 --- a/lib/POE/Component/IRC/Plugin.pm +++ b/lib/POE/Component/IRC/Plugin.pm @@ -1,10 +1,9 @@ -# Declare our package package POE::Component::IRC::Plugin; use strict; use warnings; -our $VERSION = '0.10'; +our $VERSION = '0.11'; require Exporter; use base qw(Exporter); @@ -25,65 +24,63 @@ __END__ POE::Component::IRC::Plugin - Provides plugin documentation for PoCo-IRC -=head1 ABSTRACT +=head1 SYNOPSIS -Provides plugin documentation for PoCo-IRC + # A simple ROT13 'encryption' plugin -=head1 CHANGES - -=head2 0.08 - -Added EXAMPLES section. - -=head2 0.07 - -The plugin sytem has changed to use L -now. See its documentation for information about the underlying operations of -the pipeline. - -There's a new method, plugin_order, which returns an array reference of the -plugins in the pipeline in the order in which they are executed. - -There's a new method, pipeline, which returns the POE::Component::IRC::Pipeline -object so you can deal with its finer-tuned controls yourself. - -The _plugin_unregister_do method is no more. - -=head2 0.06 + package Rot13; -Updated _plugin_process so that it runs plugin method calls in an 'eval'. -Rogue plugins shouldn't be able to crash the component now. + use strict; + use warnings; + use POE::Component::IRC::Plugin qw( :ALL ); -If a plugin doesn't have a event handler method defined now, the component -will try to call a _default() handler instead. + # Plugin object constructor + sub new { + my $package = shift; + return bless {}, $package; + } -=head2 0.05 + sub PCI_register { + my ($self, $irc) = splice @_, 0, 2; -Realized that there would be collision between USER/SERVER methods, so made it -distinct by using S_* and U_* Clarified the documentation to stress that 'irc_' -is not required for event names. Changed the description of the 2 new events to -stress that they are sent *after* the action is done. + $irc->plugin_register( $self, 'SERVER', qw(public) ); + return 1; + } -=head2 0.04 + # This is method is mandatory but we don't actually have anything to do. + sub PCI_unregister { + return 1; + } -Changed _plugin_register/unregister to non-private methods + sub S_public { + my ($self, $irc) = splice @_, 0, 2; -=head2 0.03 + # Parameters are passed as scalar-refs including arrayrefs. + my $nick = ( split /!/, ${ $_[0] } )[0]; + my $channel = ${ $_[1] }->[0]; + my $msg = ${ $_[2] }; -As per perigrin's suggestion, added 2 new event types to monitor plugin add/del -Updated the name from PoCo-IRC-Plugins to PoCo-IRC-Plugin -Updated return value ( PCI_EAT_PLUGINS to PCI_EAT_PLUGIN ) -Updated plugin_del to also accept the plugin object instead of a name + if (my ($rot13) = $msg =~ /^rot13 (.+)/) { + $rot13 =~ tr[a-zA-Z][n-za-mN-ZA-M]; -=head2 0.02 + # 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; + } -Modified plugin_del() so it returns the plugin object + # Default action is to allow other plugins to process it. + return PCI_EAT_NONE; + } -=head2 0.01 +=head1 DESCRIPTION -Initial release +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 POE::Component::Pluggable. -=head1 Why do we need this? +=head1 HISTORY Certain individuals in #PoE on MAGNet said we didn't need to bloat the PoCo-IRC code... @@ -112,21 +109,26 @@ 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 $irc object system, but what if we also used this opportunity 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 -This is the document coders/users should refer to when using/developing plugins -for POE::Component::IRC. - 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* @@ -218,120 +220,62 @@ they can do is limited only by imagination and the IRC RFC's ;) return PCI_EAT_NONE; } -=head1 Available methods to use on the $irc object - -=head2 pipeline - -This method returns (or creates) the pipeline object into which plugins are -stored. - -=head2 plugin_add - -Accepts two arguments: - -The alias for the plugin - -The actual plugin object - -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 PoCo-IRC object. - -This method goes through the pipeline's push() method. - -This method will call $plugin->PCI_register( $irc ) - -Returns the number of plugins now in the pipeline if plugin was initialized, a -false value otherwise. +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. -=head2 plugin_get - -Accepts one argument: - -The alias for the plugin - -This method goes through the pipeline's get() method. - -Returns the plugin object if it was found, a false value if not. - -=head2 plugin_del - -Accepts one argument: - -The alias for the plugin or the plugin object itself - -This method goes through the pipeline's remove() method. - -This method will call $plugin->PCI_unregister( $irc ) - -Returns the plugin object if the plugin was removed, a false value if not. - -=head2 plugin_list - -Has no arguments. - -Returns a hashref of plugin objects, keyed on alias, or an empty list if there -are no plugins loaded. - -=head2 plugin_order - -Has no arguments. - -Returns an arrayref of plugin objects, in the order which they are encountered -in the pipeline. - -=head2 plugin_register - -Accepts the following arguments: - -The plugin object - -The type of the hook ( 'SERVER' or 'USER' ) - -The event name(s) to watch - -The event names can be as many as possible, or an arrayref. They correspond -to the irc_* events listed in PoCo-IRC, and naturally, arbitrary events too. - -You do not need to supply events with irc_ in front of them, just the names. - -It is possible to register for all events by specifying 'all' as an event. - -Returns a true value if everything checked out fine, a false value if -something's seriously wrong. - -=head2 plugin_unregister - -Accepts the following arguments: - -The plugin object + package POE::Plugin::Template; -The type of the hook ( 'SERVER' or 'USER' ) + use POE; + use POE::Component::IRC::Plugin qw( :ALL ); -The event name(s) to unwatch + sub new { + my $package = shift; + my $self = bless {@_}, $package; + return $self; + } -The event names can be as many as possible, or an arrayref. They correspond -to the irc_* events listed in PoCo-IRC, and naturally, arbitrary events too. + sub PCI_register { + my ($self, $irc) = splice @_, 0, 2; -You do not need to supply events with irc_ in front of them, just the names. + # We store a ref to the $irc object so we can use it in our + # session handlers. + $self->{irc} = $irc; -Returns a true value if all the event name(s) were successfully unregistered, -a false value if some were not. + $irc->plugin_register( $self, 'SERVER', qw(blah blah blah) ); -=head1 New SERVER events available to PoCo-IRC + $self->{SESSION_ID} = POE::Session->create( + object_states => [ + $self => [qw(_start _shutdown)], + ], + )->ID(); -=head2 irc_plugin_add + return 1; + } -This event will be triggered after a plugin is added. It receives two -arguments, the first being the plugin name, and the second being the plugin -object. + 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; + } -=head2 irc_plugin_del + 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; + } -This event will be triggered after a plugin is deleted. It receives two -arguments, the first being the plugin name, and the second being the plugin -object. + sub _shutdown { + my ($kernel, $self) = @_[KERNEL, OBJECT]; + $kernel->alarm_remove_all(); + $kernel->refcount_decrement( $self->{SESSION_ID}, __PACKAGE__ ); + return; + } -=head1 Event arguments +=head1 EVENT TYPES =head2 SERVER hooks @@ -348,8 +292,8 @@ 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 PoCo-IRC will know what -to do. +They are required to return one of the L so PoCo-IRC +will know what to do. =head3 Names of potential hooks @@ -357,10 +301,11 @@ to do. socketerr connected plugin_del + ... -Keep in mind that they are always lowercased, check out the POE::Component::IRC -documentation and look at the Important Events section for the complete list of -names. +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 @@ -377,12 +322,12 @@ 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 $irc object, as it will become unwieldy and not allow inheritance +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 PoCo-IRC pod regarding dcc -commands. +receive references to the arguments specified in the DCC plugin +L regarding dcc commands. =head3 Names of potential hooks @@ -390,13 +335,14 @@ commands. 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 + dcc - $nick, $type, $file, $blocksize, $timeout dcc_accept - $cookie, $myfile dcc_resume - $cookie dcc_chat - $cookie, @lines @@ -404,9 +350,9 @@ line, they are: =head2 _default -If a plugin doesn't have a specific hook method defined for an event, the -component will attempt to call a plugin's _default() method. The first -parameter after the plugin and irc objects will be the handler name. +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; @@ -415,10 +361,10 @@ parameter after the plugin and irc objects will be the handler name. return PCI_EAT_NONE; } -The _default() handler is expected to return one of the exit codes so PoCo-IRC +The C<_default()> handler is expected to return one of the exit codes so PoCo-IRC will know what to do. -=head1 Exit Codes +=head1 EXIT CODES =head2 PCI_EAT_NONE @@ -442,127 +388,18 @@ 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 Plugin ordering system - -See L - -=head1 EXPORT +=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 EXAMPLES - -=over - -=item 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; - } - -=item A template for a plugin with it's own L - - 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) ); - - $self->{SESSION_ID} = POE::Session->create( - object_states => [ - $self => [qw(_start _shutdown)], - ], - )->ID(); - - 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; - } - -=back - =head1 SEE ALSO L -L +L + +L L @@ -570,9 +407,4 @@ L Apocalypse -=head1 PROPS - -The idea is heavily borrowed from X-Chat, BIG thanks goes out to the genius -that came up with the EAT_* system :) - =cut diff --git a/t/0_compile.t b/t/0_compile.t index 3a31b97c..8a58d42b 100644 --- a/t/0_compile.t +++ b/t/0_compile.t @@ -10,7 +10,6 @@ my @modules = qw( POE::Component::IRC::State POE::Component::IRC::Qnet POE::Component::IRC::Qnet::State - POE::Component::IRC::Pipeline POE::Component::IRC::Constants POE::Component::IRC::Common POE::Component::IRC::Test::Plugin