WebGUI::Event

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

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;
 }
 
 #-------------------------------------------------------------------

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;
 }
 
 #-------------------------------------------------------------------

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<events> 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;

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;

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

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

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(

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;
+}