use strict; use Test::More tests => 5; # Record the subroutines we've seen in a session my @Event_History; sub main::record_event { my ($hook_name) = @_; my $sub = (caller 1)[3]; push @Event_History, "$hook_name/$sub"; } BEGIN { use_ok('CGI::Application') }; ###################################### { package CGI::Application::Plugin::Foo; use vars qw/@EXPORT @ISA/; @ISA = ('Exporter'); @EXPORT = qw( foo_custom foo_init1 foo_init2 foo_prerun foo_postrun foo_teardown ); sub import { my $caller = caller; $caller->new_hook('foo_hook'); # Foo's hooks are added by reference. They cannot be overridden by the # application $caller->add_callback('foo_hook', \&foo_custom); $caller->add_callback('init', \&foo_init1); $caller->add_callback('init', \&foo_init2); $caller->add_callback('prerun', \&foo_prerun); $caller->add_callback('postrun', \&foo_postrun); $caller->add_callback('teardown', \&foo_teardown); goto &Exporter::import; } sub foo_custom { main::record_event('foo_hook') } sub foo_init1 { main::record_event('init') } sub foo_init2 { main::record_event('init') } sub foo_prerun { main::record_event('prerun') } sub foo_postrun { main::record_event('postrun') } sub foo_teardown { my $self = shift; main::record_event('teardown'); $self->call_hook('foo_hook'); } } ###################################### { package CGI::Application::Plugin::Bar; use vars qw/@EXPORT @ISA/; @ISA = ('Exporter'); @EXPORT = qw( bar_custom bar_init1 bar_init2 bar_prerun bar_postrun bar_teardown ); sub import { my $caller = caller; $caller->new_hook('bar_hook'); $caller->add_callback('bar_hook', 'bar_custom'); $caller->add_callback('init', 'bar_init1'); $caller->add_callback('init', 'bar_init2'); $caller->add_callback('prerun', 'bar_prerun'); $caller->add_callback('postrun', 'bar_postrun'); $caller->add_callback('teardown', 'bar_teardown'); goto &Exporter::import; } sub bar_custom { main::record_event('bar_hook') } sub bar_init1 { my $self = shift; main::record_event('init'); $self->call_hook('bar_hook'); } sub bar_init2 { main::record_event('init') } sub bar_prerun { main::record_event('prerun') } sub bar_postrun { main::record_event('postrun') } sub bar_teardown { main::record_event('teardown') } } ###################################### { package CGI::Application::Plugin::Baz; use vars qw/@EXPORT @ISA/; @ISA = ('Exporter'); @EXPORT = qw( baz_custom baz_init1 baz_init2 baz_prerun baz_postrun baz_teardown ); sub import { my $caller = caller; $caller->new_hook('baz_hook'); $caller->add_callback('baz_hook', 'baz_custom'); $caller->add_callback('init', 'baz_init1'); $caller->add_callback('init', 'baz_init2'); $caller->add_callback('prerun', 'baz_prerun'); $caller->add_callback('postrun', 'baz_postrun'); $caller->add_callback('teardown', 'baz_teardown'); goto &Exporter::import; } sub baz_custom { main::record_event('baz_hook') } sub baz_init1 { main::record_event('init') } sub baz_init2 { main::record_event('init') } sub baz_prerun { my $self = shift; main::record_event('prerun'); $self->call_hook('baz_hook'); } sub baz_postrun { main::record_event('postrun') } sub baz_teardown { main::record_event('teardown') } } ###################################### { package CGI::Application::Plugin::Bam; use vars qw/@EXPORT @ISA/; @ISA = ('Exporter'); @EXPORT = qw( bam_custom bam_init1 bam_init2 bam_prerun bam_postrun bam_teardown ); sub import { my $caller = caller; $caller->new_hook('bam_hook'); $caller->add_callback('bam_hook', 'bam_custom'); $caller->add_callback('init', 'bam_init1'); $caller->add_callback('init', 'bam_init2'); $caller->add_callback('prerun', 'bam_prerun'); $caller->add_callback('postrun', 'bam_postrun'); $caller->add_callback('teardown', 'bam_teardown'); goto &Exporter::import; } sub bam_custom { main::record_event('bam_hook') } sub bam_init1 { main::record_event('init') } sub bam_init2 { main::record_event('init') } sub bam_prerun { main::record_event('prerun') } sub bam_postrun { my $self = shift; main::record_event('postrun'); $self->call_hook('bam_hook'); } sub bam_teardown { main::record_event('teardown') } } ###################################### { package My::Framework; use vars qw/@ISA/; @ISA = ('CGI::Application'); sub cgiapp_init { main::record_event('init') } sub cgiapp_prerun { main::record_event('prerun') } sub cgiapp_postrun { main::record_event('postrun') } sub teardown { main::record_event('teardown') } } ###################################### { package My::Project; use vars qw/@ISA/; @ISA = ('My::Framework'); import CGI::Application::Plugin::Foo; # install another init callback for all users of My::Project My::Project->add_callback('init', 'my_project_init'); # install an impolite callback that will get run by all CGI::Application apps # regardless of whether or not they use My::Project CGI::Application->add_callback('init', \&my_project_global_init); sub my_project_init { main::record_event('init') } sub my_project_global_init { main::record_event('init') } } ###################################### { package Other::Project; use vars qw/@ISA/; @ISA = ('My::Framework'); import CGI::Application::Plugin::Baz; import CGI::Application::Plugin::Bam; # install another init callback for all users of Other::Project Other::Project->add_callback('init', 'other_project_init'); # install an impolite callback that will get run by all CGI::Application apps # regardless of whether or not they use My::Project CGI::Application->add_callback('init', \&other_project_global_init); sub other_project_init { main::record_event('init') } sub other_project_global_init { main::record_event('init') } } ###################################### { package My::App; use vars qw/@ISA/; @ISA = ('My::Project'); import CGI::Application::Plugin::Bar; sub setup { my $self = shift; $self->header_type('none'); $self->run_modes(['begin']); $self->start_mode('begin'); } sub cgiapp_init { my $self = shift; main::record_event('init'); __PACKAGE__->add_callback('prerun', 'my_app_class_prerun'); __PACKAGE__->add_callback('teardown', 'my_app_teardown'); $self->add_callback('teardown', 'my_app_teardown'); } sub cgiapp_prerun { main::record_event('prerun') } sub my_app_class_prerun { main::record_event('prerun') } sub my_app_obj_prerun { main::record_event('prerun') } sub my_app_teardown { main::record_event('teardown') } sub cgiapp_postrun { main::record_event('postrun') } sub teardown { main::record_event('teardown') } sub begin { main::record_event('runmode'); return ''; } } ###################################### { package Other::App; use vars qw/@ISA/; @ISA = 'Other::Project'; import CGI::Application::Plugin::Bam; sub setup { my $self = shift; $self->header_type('none'); $self->run_modes(['begin']); $self->start_mode('begin'); } sub cgiapp_init { my $self = shift; $self->add_callback('postrun', 'other_app_postrun'); main::record_event('init') } sub cgiapp_prerun { main::record_event('prerun') } sub cgiapp_postrun { main::record_event('postrun') } sub other_app_postrun { main::record_event('postrun') } sub teardown { main::record_event('teardown') } sub begin { main::record_event('runmode'); return ''; } } { package Unrelated::App; use vars qw/@ISA/; @ISA = ('CGI::Application'); sub setup { my $self = shift; $self->header_type('none'); $self->run_modes(['begin']); $self->start_mode('begin'); } sub cgiapp_init { main::record_event('init') } sub cgiapp_prerun { main::record_event('prerun') } sub cgiapp_postrun { main::record_event('postrun') } sub teardown { main::record_event('teardown') } sub begin { main::record_event('runmode'); return ''; } } @Event_History = (); my $app = My::App->new; $app->add_callback('prerun', 'my_app_obj_prerun'); $app->run; my @expected_events = ( # init 'init/CGI::Application::Plugin::Bar::bar_init1', # CAP::Bar 'bar_hook/CGI::Application::Plugin::Bar::bar_custom', 'init/CGI::Application::Plugin::Bar::bar_init2', 'init/CGI::Application::Plugin::Foo::foo_init1', # CAP::Foo 'init/CGI::Application::Plugin::Foo::foo_init2', 'init/My::Project::my_project_init', # My::Project 'init/My::App::cgiapp_init', # My::App (but installed via CGI::Application) 'init/My::Project::my_project_global_init', # My::Project (rudely) registered a callback in the # CGI::Application class 'init/Other::Project::other_project_global_init', # Other::Project (rudely) registered a callback in the # CGI::Application class, which forces us to run it # prerun 'prerun/My::App::my_app_obj_prerun', # My::App (installed in object) 'prerun/CGI::Application::Plugin::Bar::bar_prerun', # CAP::Foo 'prerun/My::App::my_app_class_prerun', # My::App (but installed at runtime) 'prerun/CGI::Application::Plugin::Foo::foo_prerun', # CAP::Bar 'prerun/My::App::cgiapp_prerun', # My::App (but installed via CGI::Application) # Run mode 'runmode/My::App::begin', # My::App # postrun 'postrun/CGI::Application::Plugin::Bar::bar_postrun', # CAP::Bar 'postrun/CGI::Application::Plugin::Foo::foo_postrun', # CAP::Foo 'postrun/My::App::cgiapp_postrun', # My::App (but installed via CGI::Application) # teardown 'teardown/My::App::my_app_teardown', # My::App (but installed in object) 'teardown/CGI::Application::Plugin::Bar::bar_teardown', # CAP::Bar 'teardown/CGI::Application::Plugin::Foo::foo_teardown', # CAP::Foo 'foo_hook/CGI::Application::Plugin::Foo::foo_custom', # CAP::Foo 'teardown/My::App::teardown', # My::App (but installed via CGI::Application) ); is_deeply(\@Event_History, \@expected_events, 'My::App - callbacks executed correctly (first run)') or do { use Data::Dumper; print STDERR "Actual Event History: \n"; print STDERR Dumper \@Event_History; }; # Second run of My::App : the callback registered directly in self are # no longer installed @Event_History = (); My::App->new->run; @expected_events = ( # init 'init/CGI::Application::Plugin::Bar::bar_init1', # CAP::Bar 'bar_hook/CGI::Application::Plugin::Bar::bar_custom', 'init/CGI::Application::Plugin::Bar::bar_init2', 'init/CGI::Application::Plugin::Foo::foo_init1', # CAP::Foo 'init/CGI::Application::Plugin::Foo::foo_init2', 'init/My::Project::my_project_init', # My::Project 'init/My::App::cgiapp_init', # My::App (but installed via CGI::Application) 'init/My::Project::my_project_global_init', # My::Project (rudely) registered a callback in the # CGI::Application class 'init/Other::Project::other_project_global_init', # Other::Project (rudely) registered a callback in the # CGI::Application class, which forces us to run it # prerun 'prerun/CGI::Application::Plugin::Bar::bar_prerun', # CAP::Foo 'prerun/My::App::my_app_class_prerun', # My::App (but installed at runtime) 'prerun/CGI::Application::Plugin::Foo::foo_prerun', # CAP::Bar 'prerun/My::App::cgiapp_prerun', # My::App (but installed via CGI::Application) # Run mode 'runmode/My::App::begin', # My::App # postrun 'postrun/CGI::Application::Plugin::Bar::bar_postrun', # CAP::Bar 'postrun/CGI::Application::Plugin::Foo::foo_postrun', # CAP::Foo 'postrun/My::App::cgiapp_postrun', # My::App (but installed via CGI::Application) # teardown 'teardown/My::App::my_app_teardown', # My::App (but installed in object) 'teardown/CGI::Application::Plugin::Bar::bar_teardown', # CAP::Bar 'teardown/CGI::Application::Plugin::Foo::foo_teardown', # CAP::Foo 'foo_hook/CGI::Application::Plugin::Foo::foo_custom', # CAP::Foo 'teardown/My::App::teardown', # My::App (but installed via CGI::Application) ); is_deeply(\@Event_History, \@expected_events, 'My::App - callbacks executed correctly (second run)') or do { use Data::Dumper; print STDERR "Actual Event History: \n"; print STDERR Dumper \@Event_History; }; @Event_History = (); Other::App->new->run; @expected_events = ( # init 'init/CGI::Application::Plugin::Bam::bam_init1', # CAP::Bam 'init/CGI::Application::Plugin::Bam::bam_init2', 'init/CGI::Application::Plugin::Baz::baz_init1', # CAP::Baz 'init/CGI::Application::Plugin::Baz::baz_init2', 'init/Other::Project::other_project_init', # Other::Project 'init/Other::App::cgiapp_init', # Other::App (but installed via CGI::Application) 'init/My::Project::my_project_global_init', # My::Project (rudely) registered a callback in the # CGI::Application class, which forces us to run it 'init/Other::Project::other_project_global_init', # Other::Project (rudely) registered a callback in the # CGI::Application class # prerun 'prerun/CGI::Application::Plugin::Bam::bam_prerun', # CAP::Baz 'prerun/CGI::Application::Plugin::Baz::baz_prerun', # CAP::Bam 'baz_hook/CGI::Application::Plugin::Baz::baz_custom', # CAP::Bam 'prerun/Other::App::cgiapp_prerun', # Other::App (but installed via CGI::Application) # Run mode 'runmode/Other::App::begin', # Other::App # postrun 'postrun/Other::App::other_app_postrun', # Other::App (but installed in object) 'postrun/CGI::Application::Plugin::Bam::bam_postrun', # CAP::Bam 'bam_hook/CGI::Application::Plugin::Bam::bam_custom', # CAP::Bam 'postrun/CGI::Application::Plugin::Baz::baz_postrun', # CAP::Baz 'postrun/Other::App::cgiapp_postrun', # Other::App (but installed via CGI::Application) # teardown 'teardown/CGI::Application::Plugin::Bam::bam_teardown', # CAP::Bam 'teardown/CGI::Application::Plugin::Baz::baz_teardown', # CAP::Baz 'teardown/Other::App::teardown', # Other::App (but installed via CGI::Application) ); is_deeply(\@Event_History, \@expected_events, 'Other::App - callbacks executed correctly') or do { use Data::Dumper; print STDERR "Actual Event History: \n"; print STDERR Dumper \@Event_History; }; @Event_History = (); Unrelated::App->new->run; @expected_events = ( # init 'init/Unrelated::App::cgiapp_init', # Unrelated::App (but installed via CGI::Application) 'init/My::Project::my_project_global_init', # My::Project (rudely) registered a callback in the # CGI::Application class, which forces us to run it 'init/Other::Project::other_project_global_init', # Unrelated::Project (rudely) registered a callback in the # CGI::Application class, which forces us to run it # prerun 'prerun/Unrelated::App::cgiapp_prerun', # Unrelated::App (but installed via CGI::Application) # Run mode 'runmode/Unrelated::App::begin', # Unrelated::App # postrun 'postrun/Unrelated::App::cgiapp_postrun', # Unrelated::App (but installed via CGI::Application) # teardown 'teardown/Unrelated::App::teardown', # Unrelated::App (but installed via CGI::Application) ); is_deeply(\@Event_History, \@expected_events, 'Unrelated::App - callbacks executed correctly') or do { use Data::Dumper; print STDERR "Actual Event History: \n"; print STDERR Dumper \@Event_History; };