Merge branch 'fork'

t/Asset/AssetClipboard.t

@@ -20,6 +20,7 @@ use WebGUI::Session;
 use WebGUI::Utility;
 use WebGUI::Asset;
 use WebGUI::VersionTag;
+use Test::MockObject;
 
 use Test::More; # increment this value for each test you create
 plan tests => 29;
@@ -148,12 +149,20 @@ sub copied {
     return undef;
 }
 
-my @methods = qw(Single Children Descendants);
+my $process = Test::MockObject->new->mock(update => sub {});
+my @methods = (
+    # single duplicate doesn't fork, so we can just test the www method to
+    # make sure it gets it right
+    sub { shift->www_copy },
+    sub { shift->duplicateBranch(1, 'clipboard') },
+    sub { shift->duplicateBranch(0, 'clipboard') },
+);
+my @prefixes = qw(single children descendants);
 for my $i (0..2) {
-    my $meth = "_wwwCopy$methods[$i]";
+    my $meth = $methods[$i];
     $root->$meth();
     my $clip = copied();
-    is_tree_of_folders($clip, $i+1, $meth);
+    is_tree_of_folders($clip, $i+1, @prefixes[$i]);
     $clip->purge;
 }
 

t/Fork.t

@@ -0,0 +1,106 @@
+# vim:syntax=perl
+#-------------------------------------------------------------------
+# 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
+#------------------------------------------------------------------
+
+# WebGUI::Fork tests
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+use lib "$FindBin::Bin/../lib";
+
+use Test::More;
+use Test::Deep;
+use Data::Dumper;
+use JSON;
+
+use WebGUI::Test;
+use WebGUI::Session;
+use WebGUI::Fork;
+
+my $class     = 'WebGUI::Fork';
+my $testClass = 'WebGUI::Test::Fork';
+my $pipe      = $class->init();
+my $session   = WebGUI::Test->session;
+
+# test simplest (non-forking) case
+
+my $process = $class->create($session);
+my $request = $process->request( $testClass, 'simple', ['data'] );
+
+cmp_bag(
+    [ keys %$request ],
+    [qw(webguiRoot configFile sessionId id module subname data)],
+    'request hash has the right keys'
+);
+
+my $now = time;
+
+$class->runRequest($request);
+ok $process->isFinished, 'finished';
+my $error = $process->getError;
+ok( !$error, 'no errors' ) or diag "  Expected nothing, got: $error\n";
+$process->setWait(0);
+is $process->getStatus, 'data', 'proper status';
+my $started = $process->startTime;
+ok( ( $started >= $now ), 'sane startTime' );
+ok( ( $process->endTime >= $started ), 'sane endTime' );
+
+$process->delete;
+
+note "Testing error case\n";
+$process = $class->create($session);
+$request = $process->request( $testClass, 'error', ['error'] );
+$class->runRequest($request);
+ok $process->isFinished, 'finished';
+is $process->getError, "error\n", 'has error code';
+$process->setWait(0);
+my $status = $process->getStatus;
+ok( !$status, 'no discernable status' ) or diag $status;
+ok( ( $process->endTime >= $started ), 'sane endTime' );
+
+my $forkCount   = 0;
+my $forkAndExec = $class->can('forkAndExec');
+my $replace     = sub {
+    my $self = shift;
+    $forkCount++;
+    $self->$forkAndExec(@_);
+};
+
+{
+    no strict 'refs';
+    no warnings 'redefine';
+    *{ $class . '::forkAndExec' } = $replace;
+}
+
+sub backgroundTest {
+    note "$_[0]\n";
+    $process = $class->start( $session, $testClass, 'complex', ['data'] );
+    my $sleeping;
+    while ( !$process->isFinished && $sleeping++ < 10 ) {
+        sleep 1;
+    }
+    ok $process->isFinished, 'finished';
+    is $process->getStatus, 'baz', 'correct status'
+        or diag $process->getError . "\n";
+
+    $process->delete;
+}
+backgroundTest('talk to background');
+is $forkCount, 0, 'we did not fork';
+close $pipe;
+backgroundTest('On-demand fork');
+is $forkCount, 1, 'we did fork';
+
+done_testing;
+
+#vim:ft=perl

t/lib/WebGUI/Test/Fork.pm

@@ -0,0 +1,20 @@
+package WebGUI::Test::Fork;
+
+sub simple {
+    my ( $self, $arr ) = @_;
+    $self->update( $arr->[0] );
+}
+
+sub error {
+    my ( $self, $arr ) = @_;
+    die "$arr->[0]\n";
+}
+
+sub complex {
+    my $self = shift;
+    $self->update( sub {'foo'} );
+    $self->update( sub {'bar'} );
+    $self->update( sub {'baz'} );
+}
+
+1;