1package POE::Component::Pluggable; 2$POE::Component::Pluggable::VERSION = '1.28'; 3#ABSTRACT: A base class for creating plugin-enabled POE Components. 4 5use strict; 6use warnings; 7use Carp; 8use POE::Component::Pluggable::Pipeline; 9use POE::Component::Pluggable::Constants qw(:ALL); 10 11sub _pluggable_init { 12 my ($self, %opts) = @_; 13 14 $self->{'_pluggable_' . lc $_} = delete $opts{$_} for keys %opts; 15 $self->{_pluggable_reg_prefix} = 'plugin_' if !$self->{_pluggable_reg_prefix}; 16 $self->{_pluggable_prefix} = 'pluggable_' if !$self->{_pluggable_prefix}; 17 18 if (ref $self->{_pluggable_types} eq 'ARRAY') { 19 $self->{_pluggable_types} = { map { $_ => $_ } @{ $self->{_pluggable_types} } }; 20 } 21 elsif (ref $self->{_pluggable_types} ne 'HASH') { 22 croak "Argument 'types' must be supplied"; 23 } 24 25 return 1; 26} 27 28sub _pluggable_destroy { 29 my ($self) = @_; 30 $self->plugin_del( $_ ) for keys %{ $self->plugin_list() }; 31 return; 32} 33 34sub _pluggable_event { 35 return; 36} 37 38sub _pluggable_process { 39 my ($self, $type, $event, @args) = @_; 40 41 if (!defined $type || !defined $event) { 42 carp 'Please supply an event type and name!'; 43 return; 44 } 45 46 $event = lc $event; 47 my $pipeline = $self->pipeline; 48 my $prefix = $self->{_pluggable_prefix}; 49 $event =~ s/^\Q$prefix\E//; 50 my $sub = join '_', $self->{_pluggable_types}{$type}, $event; 51 my $return = PLUGIN_EAT_NONE; 52 my $self_ret = $return; 53 54 if ($self->can($sub)) { 55 eval { $self_ret = $self->$sub( $self, @args ) }; 56 $self->_handle_error($self, $sub, $self_ret); 57 } 58 elsif ( $self->can('_default') ) { 59 eval { $self_ret = $self->_default( $self, $sub, @args ) }; 60 $self->_handle_error($self, '_default', $self_ret); 61 } 62 63 return $return if $self_ret == PLUGIN_EAT_PLUGIN; 64 $return = PLUGIN_EAT_ALL if $self_ret == PLUGIN_EAT_CLIENT; 65 return PLUGIN_EAT_ALL if $self_ret == PLUGIN_EAT_ALL; 66 67 for my $plugin (@{ $pipeline->{PIPELINE} }) { 68 if ($self eq $plugin 69 || !$pipeline->{HANDLES}{$plugin}{$type}{$event} 70 && !$pipeline->{HANDLES}{$plugin}{$type}{all}) { 71 next; 72 } 73 74 my $ret = PLUGIN_EAT_NONE; 75 76 my $alias = ($pipeline->get($plugin))[1]; 77 if ($plugin->can($sub)) { 78 eval { $ret = $plugin->$sub($self,@args) }; 79 $self->_handle_error($plugin, $sub, $ret, $alias); 80 } 81 elsif ( $plugin->can('_default') ) { 82 eval { $ret = $plugin->_default($self,$sub,@args) }; 83 $self->_handle_error($plugin, '_default', $ret, $alias); 84 } 85 86 $ret = PLUGIN_EAT_NONE unless defined $ret; 87 return $return if $ret == PLUGIN_EAT_PLUGIN; 88 $return = PLUGIN_EAT_ALL if $ret == PLUGIN_EAT_CLIENT; 89 return PLUGIN_EAT_ALL if $ret == PLUGIN_EAT_ALL; 90 } 91 92 return $return; 93} 94 95sub _handle_error { 96 my ($self, $object, $sub, $return, $source) = @_; 97 $source = defined $source ? "plugin '$source'" : 'self'; 98 99 if ($@) { 100 chomp $@; 101 my $error = "$sub call on $source failed: $@"; 102 warn "$error\n" if $self->{_pluggable_debug}; 103 104 $self->_pluggable_event( 105 "$self->{_pluggable_prefix}plugin_error", 106 $error, ($object == $self ? ($object, $source) : ()), 107 ); 108 } 109 elsif ( !defined $return || 110 ($return != PLUGIN_EAT_NONE 111 && $return != PLUGIN_EAT_PLUGIN 112 && $return != PLUGIN_EAT_CLIENT 113 && $return != PLUGIN_EAT_ALL) ) { 114 my $error = "$sub call on $source did not return a valid EAT constant"; 115 warn "$error\n" if $self->{_pluggable_debug}; 116 117 $self->_pluggable_event( 118 "$self->{_pluggable_prefix}plugin_error", 119 $error, ($object == $self ? ($object, $source) : ()), 120 ); 121 } 122 123 return; 124} 125 126# accesses the plugin pipeline 127sub pipeline { 128 my ($self) = @_; 129 eval { $self->{_PLUGINS}->isa('POE::Component::Pluggble::Pipeline') }; 130 $self->{_PLUGINS} = POE::Component::Pluggable::Pipeline->new($self) if $@; 131 return $self->{_PLUGINS}; 132} 133 134# Adds a new plugin object 135sub plugin_add { 136 my ($self, $name, $plugin) = @_; 137 138 if (!defined $name || !defined $plugin) { 139 carp 'Please supply a name and the plugin object to be added!'; 140 return; 141 } 142 143 return $self->pipeline->push($name, $plugin); 144} 145 146# Removes a plugin object 147sub plugin_del { 148 my ($self, $name) = @_; 149 150 if (!defined $name) { 151 carp 'Please supply a name/object for the plugin to be removed!'; 152 return; 153 } 154 155 my $return = scalar $self->pipeline->remove($name); 156 return $return; 157} 158 159# Gets the plugin object 160sub plugin_get { 161 my ($self, $name) = @_; 162 163 if (!defined $name) { 164 carp 'Please supply a name/object for the plugin to be removed!'; 165 return; 166 } 167 168 return scalar $self->pipeline->get($name); 169} 170 171# Lists loaded plugins 172sub plugin_list { 173 my ($self) = @_; 174 my $pipeline = $self->pipeline; 175 176 my %return = map {$pipeline->{PLUGS}{$_} => $_} @{ $pipeline->{PIPELINE} }; 177 return \%return; 178} 179 180# Lists loaded plugins in order! 181sub plugin_order { 182 my ($self) = @_; 183 return $self->pipeline->{PIPELINE}; 184} 185 186sub plugin_register { 187 my ($self, $plugin, $type, @events) = @_; 188 my $pipeline = $self->pipeline; 189 190 if (!grep { $_ eq $type } keys %{ $self->{_pluggable_types} }) { 191 carp "The event type '$type' is not supported!"; 192 return; 193 } 194 195 if (!defined $plugin) { 196 carp 'Please supply the plugin object to register events for!'; 197 return; 198 } 199 200 if (!@events) { 201 carp 'Please supply at least one event to register!'; 202 return; 203 } 204 205 for my $ev (@events) { 206 if (ref $ev and ref $ev eq 'ARRAY') { 207 $pipeline->{HANDLES}{$plugin}{$type}{lc $_} = 1 for @$ev; 208 } 209 else { 210 $pipeline->{HANDLES}{$plugin}{$type}{lc $ev} = 1; 211 } 212 } 213 214 return 1; 215} 216 217sub plugin_unregister { 218 my ($self, $plugin, $type, @events) = @_; 219 my $pipeline = $self->pipeline; 220 221 if (!grep { $_ eq $type } keys %{ $self->{_pluggable_types} }) { 222 carp "The event type '$type' is not supported!"; 223 return; 224 } 225 226 if (!defined $plugin) { 227 carp 'Please supply the plugin object to register!'; 228 return; 229 } 230 231 if (!@events) { 232 carp 'Please supply at least one event to unregister!'; 233 return; 234 } 235 236 for my $ev (@events) { 237 if (ref $ev and ref $ev eq "ARRAY") { 238 for my $e (map { lc } @$ev) { 239 if (!delete $pipeline->{HANDLES}{$plugin}{$type}{$e}) { 240 carp "The event '$e' does not exist!"; 241 next; 242 } 243 } 244 } 245 else { 246 $ev = lc $ev; 247 if (!delete $pipeline->{HANDLES}{$plugin}{$type}{$ev}) { 248 carp "The event '$ev' does not exist!"; 249 next; 250 } 251 } 252 } 253 254 return 1; 255} 256 257qq[Plug me in]; 258 259__END__ 260 261=pod 262 263=encoding UTF-8 264 265=head1 NAME 266 267POE::Component::Pluggable - A base class for creating plugin-enabled POE Components. 268 269=head1 VERSION 270 271version 1.28 272 273=head1 SYNOPSIS 274 275 # A simple POE Component that sends ping events to registered sessions 276 # and plugins every second. 277 278 { 279 package SimplePoCo; 280 281 use strict; 282 use warnings; 283 use base qw(POE::Component::Pluggable); 284 use POE; 285 use POE::Component::Pluggable::Constants qw(:ALL); 286 287 sub spawn { 288 my ($package, %opts) = @_; 289 my $self = bless \%opts, $package; 290 291 $self->_pluggable_init( 292 prefix => 'simplepoco_', 293 types => [qw(EXAMPLE)], 294 debug => 1, 295 ); 296 297 POE::Session->create( 298 object_states => [ 299 $self => { shutdown => '_shutdown' }, 300 $self => [qw(_send_ping _start register unregister __send_event)], 301 ], 302 ); 303 304 return $self; 305 } 306 307 sub shutdown { 308 my ($self) = @_; 309 $poe_kernel->post($self->{session_id}, 'shutdown'); 310 } 311 312 sub _pluggable_event { 313 my ($self) = @_; 314 $poe_kernel->post($self->{session_id}, '__send_event', @_); 315 } 316 317 sub _start { 318 my ($kernel, $self) = @_[KERNEL, OBJECT]; 319 $self->{session_id} = $_[SESSION]->ID(); 320 321 if ($self->{alias}) { 322 $kernel->alias_set($self->{alias}); 323 } 324 else { 325 $kernel->refcount_increment($self->{session_id}, __PACKAGE__); 326 } 327 328 $kernel->delay(_send_ping => $self->{time} || 300); 329 return; 330 } 331 332 sub _shutdown { 333 my ($kernel, $self) = @_[KERNEL, OBJECT]; 334 335 $self->_pluggable_destroy(); 336 $kernel->alarm_remove_all(); 337 $kernel->alias_remove($_) for $kernel->alias_list(); 338 $kernel->refcount_decrement($self->{session_id}, __PACKAGE__) if !$self->{alias}; 339 $kernel->refcount_decrement($_, __PACKAGE__) for keys %{ $self->{sessions} }; 340 341 return; 342 } 343 344 sub register { 345 my ($kernel, $sender, $self) = @_[KERNEL, SENDER, OBJECT]; 346 my $sender_id = $sender->ID(); 347 $self->{sessions}->{$sender_id}++; 348 349 if ($self->{sessions}->{$sender_id} == 1) { 350 $kernel->refcount_increment($sender_id, __PACKAGE__); 351 $kernel->yield(__send_event => 'simplepoco_registered', $sender_id); 352 } 353 354 return; 355 } 356 357 sub unregister { 358 my ($kernel, $sender, $self) = @_[KERNEL, SENDER, OBJECT]; 359 my $sender_id = $sender->ID(); 360 my $record = delete $self->{sessions}->{$sender_id}; 361 362 if ($record) { 363 $kernel->refcount_decrement($sender_id, __PACKAGE__); 364 $kernel->yield(__send_event => 'simplepoco_unregistered', $sender_id); 365 } 366 367 return; 368 } 369 370 sub __send_event { 371 my ($kernel, $self, $event, @args) = @_[KERNEL, OBJECT, ARG0..$#_]; 372 373 return 1 if $self->_pluggable_process(EXAMPLE => $event, \(@args)) == PLUGIN_EAT_ALL; 374 $kernel->post($_, $event, @args) for keys %{ $self->{sessions} }; 375 } 376 377 sub _send_ping { 378 my ($kernel, $self) = @_[KERNEL, OBJECT]; 379 380 $kernel->yield(__send_event => 'simplepoco_ping', 'Wake up sleepy'); 381 $kernel->delay(_send_ping => $self->{time} || 1); 382 return; 383 } 384 } 385 386 { 387 package SimplePoCo::Plugin; 388 use strict; 389 use warnings; 390 use POE::Component::Pluggable::Constants qw(:ALL); 391 392 sub new { 393 my $package = shift; 394 return bless { @_ }, $package; 395 } 396 397 sub plugin_register { 398 my ($self, $pluggable) = splice @_, 0, 2; 399 print "Plugin added\n"; 400 $pluggable->plugin_register($self, 'EXAMPLE', 'all'); 401 return 1; 402 } 403 404 sub plugin_unregister { 405 print "Plugin removed\n"; 406 return 1; 407 } 408 409 sub EXAMPLE_ping { 410 my ($self, $pluggable) = splice @_, 0, 2; 411 my $text = ${ $_[0] }; 412 print "Plugin got '$text'\n"; 413 return PLUGIN_EAT_NONE; 414 } 415 } 416 417 use strict; 418 use warnings; 419 use POE; 420 421 my $pluggable = SimplePoCo->spawn( 422 alias => 'pluggable', 423 time => 1, 424 ); 425 426 POE::Session->create( 427 package_states => [ 428 main => [qw(_start simplepoco_registered simplepoco_ping)], 429 ], 430 ); 431 432 $poe_kernel->run(); 433 434 sub _start { 435 my $kernel = $_[KERNEL]; 436 $kernel->post(pluggable => 'register'); 437 return; 438 } 439 440 sub simplepoco_registered { 441 print "Main program registered for events\n"; 442 my $plugin = SimplePoCo::Plugin->new(); 443 $pluggable->plugin_add('TestPlugin', $plugin); 444 return; 445 } 446 447 sub simplepoco_ping { 448 my ($heap, $text) = @_[HEAP, ARG0]; 449 print "Main program got '$text'\n"; 450 $heap->{got_ping}++; 451 $pluggable->shutdown() if $heap->{got_ping} == 3; 452 return; 453 } 454 455=head1 DESCRIPTION 456 457POE::Component::Pluggable is a base class for creating plugin enabled POE 458Components. It is a generic port of L<POE::Component::IRC|POE::Component::IRC>'s 459plugin system. 460 461If your component dispatches events to registered POE sessions, then 462POE::Component::Pluggable may be a good fit for you. 463 464Basic use would involve subclassing POE::Component::Pluggable, then 465overriding C<_pluggable_event()> and inserting C<_pluggable_process()> 466wherever you dispatch events from. 467 468Users of your component can then load plugins using the plugin methods 469provided to handle events generated by the component. 470 471You may also use plugin style handlers within your component as 472C<_pluggable_process()> will attempt to process any events with local method 473calls first. The return value of these handlers has the same significance as 474the return value of 'normal' plugin handlers. 475 476=head1 PRIVATE METHODS 477 478Subclassing POE::Component::Pluggable gives your object the following 'private' 479methods: 480 481=head2 C<_pluggable_init> 482 483This should be called on your object after initialisation, but before you want 484to start processing plugins. It accepts a number of argument/value pairs: 485 486 'types', an arrayref of the types of events that your poco will support, 487 OR a hashref with the event types as keys and their abbrevations 488 (used as plugin event method prefixes) as values. This argument is 489 mandatory. 490 491 'prefix', the prefix for your events (default: 'pluggable_'); 492 'reg_prefix', the prefix for the register()/unregister() plugin methods 493 (default: 'plugin_'); 494 'debug', a boolean, if true, will cause a warning to be printed every time a 495 plugin call fails. 496 497Notes: 'prefix' should probably end with a '_'. The types specify the prefixes 498for plugin handlers. You can specify as many different types as you require. 499 500=head2 C<_pluggable_destroy> 501 502This should be called from any shutdown handler that your poco has. The method 503unloads any loaded plugins. 504 505=head2 C<_pluggable_process> 506 507This should be called before events are dispatched to interested sessions. 508This gives pluggable a chance to discard events if requested to by a plugin. 509 510The first argument is a type, as specified to C<_pluggable_init()>. 511 512 sub _dispatch { 513 # stuff 514 515 return 1 if $self->_pluggable_process($type, $event, \(@args)) == PLUGIN_EAT_ALL; 516 517 # dispatch event to interested sessions. 518 } 519 520This example demonstrates event arguments being passed as scalar refs to the 521plugin system. This enables plugins to mangle the arguments if necessary. 522 523=head2 C<_pluggable_event> 524 525This method should be overridden in your class so that pipeline can dispatch 526events through your event dispatcher. Pipeline sends a prefixed 'plugin_add' 527and 'plugin_del' event whenever plugins are added or removed, respectively. 528A prefixed 'plugin_error' event will be sent if a plugin a) raises an 529exception, b) fails to return a true value from its register/unregister 530methods, or c) fails to return a valid EAT constant from a handler. 531 532 sub _pluggable_event { 533 my $self = shift; 534 $poe_kernel->post($self->{session_id}, '__send_event', @_); 535 } 536 537There is an example of this in the SYNOPSIS. 538 539=head1 PUBLIC METHODS 540 541Subclassing POE::Component::Pluggable gives your object the following public 542methods: 543 544=head2 C<pipeline> 545 546Returns the L<POE::Component::Pluggable::Pipeline|POE::Component::Pluggable::Pipeline> 547object. 548 549=head2 C<plugin_add> 550 551Accepts two arguments: 552 553 The alias for the plugin 554 The actual plugin object 555 556The alias is there for the user to refer to it, as it is possible to have 557multiple plugins of the same kind active in one POE::Component::Pluggable 558object. 559 560This method goes through the pipeline's C<push()> method, which will call 561C<$plugin->plugin_register($pluggable)>. 562 563Returns the number of plugins now in the pipeline if plugin was initialized, 564C<undef>/an empty list if not. 565 566=head2 C<plugin_del> 567 568Accepts one argument: 569 570 The alias for the plugin or the plugin object itself 571 572This method goes through the pipeline's C<remove()> method, which will call 573C<$plugin->plugin_unregister($pluggable)>. 574 575Returns the plugin object if the plugin was removed, C<undef>/an empty list 576if not. 577 578=head2 C<plugin_get> 579 580Accepts one argument: 581 582 The alias for the plugin 583 584This method goes through the pipeline's C<get()> method. 585 586Returns the plugin object if it was found, C<undef>/an empty list if not. 587 588=head2 C<plugin_list> 589 590Takes no arguments. 591 592Returns a hashref of plugin objects, keyed on alias, or an empty list if 593there are no plugins loaded. 594 595=head2 C<plugin_order> 596 597Takes no arguments. 598 599Returns an arrayref of plugin objects, in the order which they are 600encountered in the pipeline. 601 602=head2 C<plugin_register> 603 604Accepts the following arguments: 605 606 The plugin object 607 The type of the hook (the hook types are specified with _pluggable_init()'s 'types') 608 The event name[s] to watch 609 610The event names can be as many as possible, or an arrayref. They correspond 611to the prefixed events and naturally, arbitrary events too. 612 613You do not need to supply events with the prefix in front of them, just the 614names. 615 616It is possible to register for all events by specifying 'all' as an event. 617 618Returns 1 if everything checked out fine, C<undef>/an empty list if something 619is seriously wrong. 620 621=head2 C<plugin_unregister> 622 623Accepts the following arguments: 624 625 The plugin object 626 The type of the hook (the hook types are specified with _pluggable_init()'s 'types') 627 The event name[s] to unwatch 628 629The event names can be as many as possible, or an arrayref. They correspond 630to the prefixed events and naturally, arbitrary events too. 631 632You do not need to supply events with the prefix in front of them, just the 633names. 634 635It is possible to register for all events by specifying 'all' as an event. 636 637Returns 1 if all the event name[s] was unregistered, undef if some was not 638found. 639 640=head1 PLUGINS 641 642The basic anatomy of a pluggable plugin is: 643 644 # Import the constants, of course you could provide your own 645 # constants as long as they map correctly. 646 use POE::Component::Pluggable::Constants qw( :ALL ); 647 648 # Our constructor 649 sub new { 650 ... 651 } 652 653 # Required entry point for pluggable plugins 654 sub plugin_register { 655 my($self, $pluggable) = @_; 656 657 # Register events we are interested in 658 $pluggable->plugin_register($self, 'SERVER', qw(something whatever)); 659 660 # Return success 661 return 1; 662 } 663 664 # Required exit point for pluggable 665 sub plugin_unregister { 666 my($self, $pluggable) = @_; 667 668 # Pluggable will automatically unregister events for the plugin 669 670 # Do some cleanup... 671 672 # Return success 673 return 1; 674 } 675 676 sub _default { 677 my($self, $pluggable, $event) = splice @_, 0, 3; 678 679 print "Default called for $event\n"; 680 681 # Return an exit code 682 return PLUGIN_EAT_NONE; 683 } 684 685As shown in the example above, a plugin's C<_default> subroutine (if present) 686is called if the plugin receives an event for which it has no handler. 687 688The special exit code CONSTANTS are documented in 689L<POE::Component::Pluggable::Constants|POE::Component::Pluggable::Constants>. 690You could provide your own as long as the values match up, though. 691 692=head1 TODO 693 694Better documentation >:] 695 696=head1 KUDOS 697 698APOCAL for writing the original L<POE::Component::IRC|POE::Component::IRC> 699plugin system. 700 701japhy for writing L<POE::Component::IRC::Pipeline|POE::Component::IRC::Pipeline> 702which improved on it. 703 704All the happy chappies who have contributed to POE::Component::IRC over the 705years (yes, it has been years) refining and tweaking the plugin system. 706 707The initial idea was heavily borrowed from X-Chat, BIG thanks go out to the 708genius that came up with the EAT_* system :) 709 710=head1 SEE ALSO 711 712L<POE::Component::IRC|POE::Component::IRC> 713 714L<POE::Component::Pluggable::Pipeline|POE::Component::Pluggable::Pipeline> 715 716Both L<POE::Component::Client::NNTP|POE::Component::Client::NNTP> and 717L<POE::Component::Server::NNTP|POE::Component::Server::NNTP> use this module 718as a base, examination of their source may yield further understanding. 719 720=head1 AUTHORS 721 722=over 4 723 724=item * 725 726Chris Williams <chris@bingosnet.co.uk> 727 728=item * 729 730Apocalypse <perl@0ne.us> 731 732=item * 733 734Hinrik Örn Sigurðsson 735 736=item * 737 738Jeff Pinyan 739 740=back 741 742=head1 COPYRIGHT AND LICENSE 743 744This software is copyright (c) 2017 by Chris Williams. 745 746This is free software; you can redistribute it and/or modify it under 747the same terms as the Perl 5 programming language system itself. 748 749=cut 750