From 181f21a0b7abd2dd0a3be6f22a681cff8664212e Mon Sep 17 00:00:00 2001 From: Paul Driver Date: Fri, 27 May 2011 08:38:19 -0500 Subject: [PATCH] WebGUI::Event --- docs/changelog/7.x.x.txt | 1 + lib/WebGUI/Asset/File.pm | 3 +- lib/WebGUI/AssetExportHtml.pm | 2 + lib/WebGUI/Event.pm | 148 ++++++++++++++++++++++++++++++++++ lib/WebGUI/Storage.pm | 26 +++++- t/Asset/AssetExportHtml.t | 54 +++++++------ t/Event.t | 70 ++++++++++++++++ t/Storage.t | 38 ++++++--- t/lib/WebGUI/Test/Event.pm | 78 ++++++++++++++++++ 9 files changed, 383 insertions(+), 37 deletions(-) create mode 100644 lib/WebGUI/Event.pm create mode 100644 t/Event.t create mode 100644 t/lib/WebGUI/Test/Event.pm diff --git a/docs/changelog/7.x.x.txt b/docs/changelog/7.x.x.txt index 849e51d87..8c4443cc1 100644 --- a/docs/changelog/7.x.x.txt +++ b/docs/changelog/7.x.x.txt @@ -1,4 +1,5 @@ 7.10.18 + - Added the WebGUI::Event API - fixed #12141: Macro_RenderThingData (bad tags) nothing to translate - fixed #12142: Copy fails on imported threads - canView will now be checked before calling ANY www_ method on account diff --git a/lib/WebGUI/Asset/File.pm b/lib/WebGUI/Asset/File.pm index dc087e234..85d0451a0 100644 --- a/lib/WebGUI/Asset/File.pm +++ b/lib/WebGUI/Asset/File.pm @@ -21,7 +21,7 @@ use WebGUI::Cache; use WebGUI::Storage; use WebGUI::SQL; use WebGUI::Utility; - +use WebGUI::Event; =head1 NAME @@ -228,6 +228,7 @@ sub exportWriteFile { WebGUI::Error->throw(error => "can't copy " . $self->getStorageLocation->getPath($self->get('filename')) . ' to ' . $dest->absolute->stringify . ": $!"); } + fire $self->session, 'asset::export' => $dest; } #------------------------------------------------------------------- diff --git a/lib/WebGUI/AssetExportHtml.pm b/lib/WebGUI/AssetExportHtml.pm index 555788518..6e25e3bc1 100644 --- a/lib/WebGUI/AssetExportHtml.pm +++ b/lib/WebGUI/AssetExportHtml.pm @@ -25,6 +25,7 @@ use WebGUI::Session; use URI::URL; use Scope::Guard qw(guard); use WebGUI::ProgressTree; +use WebGUI::Event; =head1 NAME @@ -964,6 +965,7 @@ sub exportWriteFile { $self->session->output->print($contents); } $fh->close; + fire $self->session, 'asset::export' => $dest; } #------------------------------------------------------------------- diff --git a/lib/WebGUI/Event.pm b/lib/WebGUI/Event.pm new file mode 100644 index 000000000..8a2f27ed4 --- /dev/null +++ b/lib/WebGUI/Event.pm @@ -0,0 +1,148 @@ +package WebGUI::Event; + +=head1 LEGAL + + ------------------------------------------------------------------- + WebGUI is Copyright 2001-2009 Plain Black Corporation. + ------------------------------------------------------------------- + Please read the legal notices (docs/legal.txt) and the license + (docs/license.txt) that came with this distribution before using + this software. + ------------------------------------------------------------------- + http://www.plainblack.com info@plainblack.com + ------------------------------------------------------------------- + +=cut + +use strict; +use warnings; + +use Exporter qw(import); +use WebGUI::Pluggable; +use Try::Tiny; + +our @EXPORT = qw(fire); + +=head1 NAME + +WebGUI::Event + +=head1 DESCRIPTION + +Run custom code when things happen in WebGUI. + +=head1 SUBSCRIBERS + +If you're trying to handle an event, this is you. + +=head2 CONFIG FILE + +The C hash in the config file maps names to lists of event handlers. +They will be run in the order they are defined. Instead of a list, you can +just specify one handler, and it will be treated as a list of one element. +The handlers are subroutines and must be able to be found by +WebGUI::Pluggable::run. + + #... + "events" : { + "asset::export" : "My::Events::onExport", + "storage::addFile" : "My::Events::onFile" + }, + #... + +=head2 PERL CODE + +Your code will be called with the arguments that are passed to +WebGUI::Event::Fire by the publisher. + + package My::Events; + + sub onExport { + my ($session, $name, $asset, $path) = @_; + #... + } + + sub onFile { + my ($session, $name, $storage, $filename) = @_; + #... + } + +=head1 PUBLISHERS + +If you want to let people hook some behavior in the code you're writing, this +is you. + + package WebGUI::Something; + + use WebGUI::Event; + + sub someThing { + #... + fire $session, 'something::happened', $with, $some, $arguments; + #... + } + +=head1 SUBROUTINES + +These subroutines are available from this package: + +=cut + +#------------------------------------------------------------------- + +=head2 fire($session, $name, ...) + +Exported by default. Calls all the subroutines defined in C<$session>'s config +file for C<$name> in order with these same arguments. + +=cut + +our %cache; + +sub fire { + my ($session, $name) = splice @_, 0, 2; + my $config = $session->config; + my $path = $config->getFilePath; + unless (exists $cache{$path}{$name}) { + my $events = $config->get('events') or return; + my $names = $events->{$name} or return; + $names = [ $names ] unless ref $names eq 'ARRAY'; + $cache{$path}{$name} = [ + grep { $_ } map { + if ($_) { + my ($package, $subname) = /^(.*)::([^:]+)$/; + try { + WebGUI::Pluggable::load($package); + $package->can($subname); + } + catch { + $session->log->error( + "Couldn't load event handler for $name: $_" + ); + undef; + }; + } + } @$names + ]; + } + $_->($session, $name, @_) for @{ $cache{$path}{$name} }; +} + +=head1 RATIONALE + +=head2 Why can't I register listeners at runtime? or... + +=head2 Why is there no subscribe method? or... + +=head2 Why is this in the config file instead of somewhere else? + +WebGUI::Events are conceptually per-site things. The code to be called is +static and hopefully controlled someone by with access to the config file. + +That being said, you could certainly build something more dynamic on top of +this system. Writing an event handler that publishes messages to a broker +service like DBus or RabbitMQ is entirely possible. + +=cut + +1; diff --git a/lib/WebGUI/Storage.pm b/lib/WebGUI/Storage.pm index 4c66933c3..8dee8b736 100644 --- a/lib/WebGUI/Storage.pm +++ b/lib/WebGUI/Storage.pm @@ -26,6 +26,7 @@ use Image::Magick; use Path::Class::Dir; use Storable (); use WebGUI::Utility qw(isIn); +use WebGUI::Event; use JSON (); @@ -111,6 +112,19 @@ sub _addError { #------------------------------------------------------------------- +=head2 _addFile ( $filename ) + +Emits the storage::addFile event for this storage/filename. + +=cut + +sub _addFile { + my ($self, $filename) = @_; + fire $self->session, 'storage::addFile', $self, $filename; +} + +#------------------------------------------------------------------- + =head2 _cdnAdd ( ) Adds to CDN queue, for any of the add* methods. @@ -338,6 +352,7 @@ sub addFileFromFilesystem { close $dest; close $source; $self->_cdnAdd; + $self->_addFile($filename); return $filename; } @@ -392,6 +407,7 @@ sub addFileFromFormPost { $attachmentCount++; if ($upload->link($filePath)) { $self->_changeOwner($filePath); + $self->_addFile($filename); $self->session->errorHandler->info("Got ".$upload->filename); } else { @@ -428,6 +444,7 @@ sub addFileFromHashref { Storable::nstore($hashref, $self->getPath($filename)) or $self->_addError("Couldn't create file ".$self->getPath($filename)." because ".$!); $self->_changeOwner($self->getPath($filename)); + $self->_addFile($filename); $filename and $self->_cdnAdd; return $filename; } @@ -457,6 +474,7 @@ sub addFileFromScalar { print $FILE $content; close($FILE); $self->_changeOwner($self->getPath($filename)); + $self->_addFile($filename); $self->_cdnAdd; } else { @@ -588,7 +606,12 @@ sub copy { else { open my $source, '<:raw', $origFile or next FILE; open my $dest, '>:raw', $copyFile or next FILE; - File::Copy::copy($source, $dest) or $self->_addError("Couldn't copy file ".$origFile." to ".$copyFile." because ".$!); + if (File::Copy::copy($source, $dest)) { + $newStorage->_addFile($file); + } + else { + $self->_addError("Couldn't copy file $origFile to $copyFile because $!"); + } close $dest; close $source; } @@ -621,6 +644,7 @@ sub copyFile { File::Copy::copy( $self->getPath($filename), $self->getPath($newFilename) ) || croak "Couldn't copy '$filename' to '$newFilename': $!"; $self->_changeOwner($self->getPath($filename)); + $self->_addFile($filename); $self->_cdnAdd; return undef; diff --git a/t/Asset/AssetExportHtml.t b/t/Asset/AssetExportHtml.t index 9a795e6b1..75cce1115 100644 --- a/t/Asset/AssetExportHtml.t +++ b/t/Asset/AssetExportHtml.t @@ -23,6 +23,7 @@ use WebGUI::PseudoRequest; use WebGUI::Session; use WebGUI::Asset; use WebGUI::Exception; +use WebGUI::Test::Event; use Cwd; use Exception::Class; @@ -40,10 +41,26 @@ my $session = WebGUI::Test->session; # Tests WebGUI::Test->originalConfig('exportPath'); +my @events; my $testRan = 1; -plan tests => 128; # Increment this number for each test you create +plan tests => 124; # Increment this number for each test you create + +sub export_ok { + my ($asset, $message) = @_; + subtest $message => sub { + plan tests => 3; + my $e; + my @events = trap { + eval { $asset->exportWriteFile() }; + $e = $@; + } $asset->session, 'asset::export'; + ok !$e, 'ran without exception'; + is scalar @events, 1, 'event fired once'; + is $events[0][2], $asset->exportGetUrlAsPath->absolute; + }; +} #---------------------------------------------------------------------------- # exportCheckPath() @@ -378,11 +395,7 @@ my $content; my $guid = $session->id->generate; my $guidPath = Path::Class::Dir->new($config->get('uploadsPath'), 'temp', $guid); $config->set('exportPath', $guidPath->absolute->stringify); -eval { $parent->exportWriteFile() }; -is($@, '', "exportWriteFile works when creating exportPath"); - -# ensure that the file was actually written -ok(-e $parent->exportGetUrlAsPath->absolute->stringify, "exportWriteFile actually writes the file when creating exportPath"); +export_ok $parent, 'exportWriteFile works when creating exportPath'; # now make sure that it contains the correct content eval { $content = WebGUI::Test->getPage($parent, 'exportHtml_view', { user => WebGUI::User->new($session, 1) } ) }; @@ -430,11 +443,7 @@ chmod 0755, $guidPath->stringify; $unwritablePath->remove; $session->http->setNoHeader(1); -eval { $firstChild->exportWriteFile() }; -is($@, '', "exportWriteFile works for first_child"); - -# ensure that the file was actually written -ok(-e $firstChild->exportGetUrlAsPath->absolute->stringify, "exportWriteFile actually writes the first_child file"); +export_ok $firstChild, 'exportWriteFile works for first_child'; # verify it has the correct contents eval { $content = WebGUI::Test->getPage($firstChild, 'exportHtml_view') }; @@ -446,11 +455,7 @@ $guidPath->rmtree; $session->http->setNoHeader(1); $session->user( { userId => 1 } ); -eval { $grandChild->exportWriteFile() }; -is($@, '', "exportWriteFile works for grandchild"); - -# ensure that the file was written -ok(-e $grandChild->exportGetUrlAsPath->absolute->stringify, "exportWriteFile actually writes the grandchild file"); +export_ok $grandChild, 'exportWriteFile works for grandchild'; # finally, check its contents $session->style->sent(0); @@ -461,17 +466,12 @@ is(scalar $grandChild->exportGetUrlAsPath->absolute->slurp, $content, "exportWri $guidPath->rmtree; $asset = WebGUI::Asset->new($session, 'ExportTest000000000001'); $session->http->setNoHeader(1); -eval { $asset->exportWriteFile() }; -is($@, '', 'exportWriteFile for perl file works'); -ok(-e $asset->exportGetUrlAsPath->absolute->stringify, "exportWriteFile actually writes the perl file"); +export_ok $asset, 'exportWriteFile for perl file works'; $guidPath->rmtree; $asset = WebGUI::Asset->new($session, 'ExportTest000000000002'); -eval { $asset->exportWriteFile() }; -is($@, '', 'exportWriteFile for plain file works'); - -ok(-e $asset->exportGetUrlAsPath->absolute->stringify, "exportWriteFile actuall writes the plain file"); +export_ok $asset, 'exportWriteFile for plain file works'; $guidPath->rmtree; @@ -482,8 +482,11 @@ $guidPath->rmtree; # permissions on something. $parent->update( { groupIdView => 3 } ); # admins $session->http->setNoHeader(1); -eval { $parent->exportWriteFile() }; -$e = Exception::Class->caught(); +@events = trap { + eval { $parent->exportWriteFile() }; + $e = Exception::Class->caught(); +} $session, 'asset::export'; + isa_ok($e, 'WebGUI::Error', "exportWriteFile throws when user can't view asset"); cmp_deeply( $e, @@ -497,6 +500,7 @@ cmp_deeply( # no directory or file written ok(!-e $parent->exportGetUrlAsPath->absolute->stringify, "exportWriteFile doesn't write file when user can't view asset"); ok(!-e $parent->exportGetUrlAsPath->absolute->parent, "exportWriteFile doesn't write directory when user can't view asset"); +is scalar @events, 0, 'event not fired'; # undo our viewing changes $parent->update( { groupIdView => 7 } ); # everyone diff --git a/t/Event.t b/t/Event.t new file mode 100644 index 000000000..2164cdab4 --- /dev/null +++ b/t/Event.t @@ -0,0 +1,70 @@ +#------------------------------------------------------------------- +# WebGUI is Copyright 2001-2009 Plain Black Corporation. +#------------------------------------------------------------------- +# Please read the legal notices (docs/legal.txt) and the license +# (docs/license.txt) that came with this distribution before using +# this software. +#------------------------------------------------------------------ +# http://www.plainblack.com info@plainblack.com +#------------------------------------------------------------------ + +use strict; +use warnings; + +use FindBin; +use Test::More tests => 12; + +use lib "$FindBin::Bin/lib"; +use WebGUI::Test; +use WebGUI::Session; +use WebGUI::Event; + +my $session = WebGUI::Test->session; +WebGUI::Test->originalConfig('events'); +my $config = $session->config; +$config->set('events/foo', [ + 'My::Events::onFoo', + 'My::Events::onFoo2' +]); +$config->set('events/bar', 'My::Events::onBar'); + +my ($foo, $foo2, $bar) = @_; + +sub My::Events::onFoo { + my ($session, $name, $one, $two, $three) = @_; + isa_ok $session, 'WebGUI::Session', 'onFoo: session'; + is $name, 'foo', "onFoo: $name"; + $foo = $one; +} + +sub My::Events::onFoo2 { + my ($session, $name, $one, $two, $three) = @_; + isa_ok $session, 'WebGUI::Session', 'onFoo2: session'; + is $name, 'foo', "onFoo2: $name"; + $foo2 = $two; +} + +sub My::Events::onBar { + my ($session, $name, $one, $two, $three) = @_; + isa_ok $session, 'WebGUI::Session', 'onBar: session'; + is $name, 'bar', "onBar: $name"; + $bar = $three; +} + +# Tell require that My::Events is already loaded. +$INC{'My/Events.pm'} = __FILE__; + +fire $session, 'foo', qw(first second third); + +is $foo, 'first', 'foo called'; +is $foo2, 'second', 'foo2 called'; +ok !defined $bar, 'bar not called'; +undef $foo; +undef $foo2; + +fire $session, 'bar', qw(first second third); +ok !defined $foo, 'foo not called'; +ok !defined $foo2, 'foo2 not called'; +is $bar, 'third', 'onBar called'; + +#vim:ft=perl diff --git a/t/Storage.t b/t/Storage.t index f20e77229..01456a0a9 100644 --- a/t/Storage.t +++ b/t/Storage.t @@ -13,6 +13,7 @@ use strict; use lib "$FindBin::Bin/lib"; use WebGUI::Test; +use WebGUI::Test::Event; use WebGUI::Session; use WebGUI::Storage; @@ -31,7 +32,7 @@ my $cwd = Cwd::cwd(); my ($extensionTests, $fileIconTests, $block_extension_tests) = setupDataDrivenTests($session); -plan tests => 157 +plan tests => 164 + scalar @{ $extensionTests } + scalar @{ $fileIconTests } + scalar @{ $block_extension_tests } @@ -199,7 +200,16 @@ Hi, I'm a file. I have two lines. EOCON -my $filename = $storage1->addFileFromScalar('content', $content); +sub fired_ok(&@) { + my ($block, @expected) = @_; + my @events = trap { $block->() } $session, 'storage::addFile'; + my @got = map { $_->[3] } @events; + cmp_bag \@got, \@expected, 'events fired for ' . join ', ', @expected; +} + +my $filename; fired_ok { + $filename = $storage1->addFileFromScalar('content', $content) +} 'content'; is ($filename, 'content', 'processed filename returned by addFileFromScalar'); @@ -239,10 +249,10 @@ foreach my $extTest (@{ $extensionTests }) { my $fileStore = WebGUI::Storage->create($session); WebGUI::Test->addToCleanup($fileStore); cmp_bag($fileStore->getFiles(1), ['.'], 'Starting with an empty storage object, no files in here except for . '); -$fileStore->addFileFromScalar('.dotfile', 'dot file'); +fired_ok { $fileStore->addFileFromScalar('.dotfile', 'dot file') } '.dotfile'; cmp_bag($fileStore->getFiles(), [ ], 'getFiles() by default does not return dot files'); cmp_bag($fileStore->getFiles(1), ['.', '.dotfile'], 'getFiles(1) returns all files, including dot files'); -$fileStore->addFileFromScalar('dot.file', 'dot.file'); +fired_ok { $fileStore->addFileFromScalar('dot.file', 'dot.file') } 'dot.file'; cmp_bag($fileStore->getFiles(), ['dot.file'], 'getFiles() returns normal files'); cmp_bag($fileStore->getFiles(1), ['.', '.dotfile', 'dot.file'], 'getFiles(1) returns all files, including dot files'); @@ -263,7 +273,9 @@ is($obj->stringify, $storage1->getPath, '... Path::Class::Dir object has correct #################################################### my $storageHash = {'blah'=>"blah",'foo'=>"foo"}; -$storage1->addFileFromHashref("testfile-hash.file", $storageHash); +fired_ok { + $storage1->addFileFromHashref("testfile-hash.file", $storageHash); +} 'testfile-hash.file'; ok (-e $storage1->getPath("testfile-hash.file"), 'addFileFromHashRef creates file'); #################################################### @@ -301,9 +313,11 @@ ok (!(-e $storage1->getPath("testfile-hash.file")), "rename file original file i # #################################################### -$storage1->addFileFromFilesystem( - WebGUI::Test->getTestCollateralPath('littleTextFile'), -); +fired_ok { + $storage1->addFileFromFilesystem( + WebGUI::Test->getTestCollateralPath('littleTextFile'), + ); +} 'littleTextFile'; ok( grep(/littleTextFile/, @{ $storage1->getFiles }), @@ -337,7 +351,9 @@ cmp_bag($s3copy->getFiles(), [ @filesToCopy ], 'copy: passing explicit variable my $deepDeepDir = $deepDir->subdir('deep'); my $errorStr; my @foo = $deepDeepDir->mkpath({ error => \$errorStr } ); - $deepStorage->addFileFromScalar('deep/file', 'deep file'); + fired_ok { + $deepStorage->addFileFromScalar('deep/file', 'deep file') + } 'deep/file'; cmp_bag( $deepStorage->getFiles('all'), [ '.', 'deep', 'deep/file' ], @@ -507,7 +523,9 @@ $session->request->uploadFiles( 'oneFile', [ WebGUI::Test->getTestCollateralPath('littleTextFile') ], ); -is($formStore->addFileFromFormPost('oneFile'), 'littleTextFile', '... returns the name of the uploaded file'); +fired_ok { + is($formStore->addFileFromFormPost('oneFile'), 'littleTextFile', '... returns the name of the uploaded file') +} 'littleTextFile'; cmp_bag($formStore->getFiles, [ qw/littleTextFile/ ], '... adds the file to the storage location'); $session->request->uploadFiles( diff --git a/t/lib/WebGUI/Test/Event.pm b/t/lib/WebGUI/Test/Event.pm new file mode 100644 index 000000000..709de221b --- /dev/null +++ b/t/lib/WebGUI/Test/Event.pm @@ -0,0 +1,78 @@ +package WebGUI::Test::Event; + +use List::Util qw(first); +use Exporter qw(import); + +our @EXPORT = qw(trap); + +=head1 LEGAL + + ------------------------------------------------------------------- + WebGUI is Copyright 2001-2009 Plain Black Corporation. + ------------------------------------------------------------------- + Please read the legal notices (docs/legal.txt) and the license + (docs/license.txt) that came with this distribution before using + this software. + ------------------------------------------------------------------- + http://www.plainblack.com info@plainblack.com + ------------------------------------------------------------------- + +=cut + +use strict; +use warnings; + +=head1 SYNOPSIS + +Temporarily handle WebGUI::Events. + +=head1 METHODS + +These methods are available from this class: + +=cut + +our $session; +our @names; +our @trap; + +my $handlerName = __PACKAGE__ . '::handler'; + +sub handler { + my ($s, $n) = @_; + return unless first { $_ eq $n } @names; + push @trap, \@_; +}; + +#------------------------------------------------------------------- + +=head2 trap ($code, $session, @names) + +Traps the events named by @names and returns them as a list of arrayrefs in +the order they occured. The arrayrefs are all arguments passed to the event +handler. + +=cut + +sub trap(&$@) { + my $block = shift; + local ($session, @names) = @_; + local @trap; + + my $config = $session->config; + my $events = $config->get('events'); + local %WebGUI::Event::cache; + for my $name (@names) { + $config->set("events/$name", $handlerName); + } + eval { $block->() }; + my $err = $@; + if ($events) { + $config->set(events => $events); + } + else { + $config->delete('events'); + } + die $err if $err; + return @trap; +}