WebGUI::Event

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