ProgressBar::run and now Asset->www_copy has a bar

docs/changelog/7.x.x.txt

@@ -1,4 +1,5 @@
 7.9.5
+ - Asset->www_copy now has a progress bar
  - fixed #11556: New cart doesn't work with other forms on the same page
  - fixed #11557: Shop credit deduction calculated incorrectly
  - fixed #11561: PayDriver_Cash - password help

lib/WebGUI/AssetClipboard.pm

@@ -229,36 +229,98 @@ sub paste {
 
 =head2 www_copy ( )
 
-Duplicates self, cuts duplicate, returns self->getContainer->www_view if canEdit. Otherwise returns an AdminConsole rendered as insufficient privilege.
+Duplicates self, cuts duplicate, returns self->getContainer->www_view if
+canEdit. Otherwise returns an AdminConsole rendered as insufficient privilege.
+If with children/descendants is selected, a progress bar will be rendered.
 
 =cut
 
 sub www_copy {
-    my $self = shift;
+    my $self    = shift;
-    return $self->session->privilege->insufficient
+    my $session = $self->session;
-        unless $self->canEdit;
+    return $session->privilege->insufficient unless $self->canEdit;
 
-
+    my $with = $session->form->get('with');
-    # with: 'children' || 'descendants' || ''
+    if ($with eq 'children') {
-    my $with = $self->session->form->get('with') || '';
+        $self->_wwwCopyChildren;
-    my $newAsset;
+    }
-    if ($with) {
+    elsif ($with eq 'descendants') {
-        my $childrenOnly = $with eq 'children';
+        $self->_wwwCopyDescendants;
-        $newAsset = $self->duplicateBranch($childrenOnly);
     }
     else {
-        $newAsset = $self->duplicate({skipAutoCommitWorkflows => 1});
+        $self->_wwwCopySingle;
     }
-    my $i18n = WebGUI::International->new($self->session, 'Asset');
+}
-    $newAsset->update({ title=>sprintf("%s (%s)",$self->getTitle,$i18n->get('copy'))});
+
+#-------------------------------------------------------------------
+sub _wwwCopyChildren { shift->_wwwCopyProgress(1) }
+
+#-------------------------------------------------------------------
+sub _wwwCopyDescendants { shift->_wwwCopyProgress(0) }
+
+#-------------------------------------------------------------------
+sub _wwwCopyFinish {
+    my ($self, $newAsset) = @_;
+    my $session = $self->session;
+    my $i18n    = WebGUI::International->new($session, 'Asset');
+    my $title   = sprintf("%s (%s)", $self->getTitle, $i18n->get('copy'));
+    $newAsset->update({ title => $title });
     $newAsset->cut;
-    if (WebGUI::VersionTag->autoCommitWorkingIfEnabled($self->session, {
+    my $result = WebGUI::VersionTag->autoCommitWorkingIfEnabled(
-        allowComments   => 1,
+        $session, {
-        returnUrl       => $self->getUrl,
+            allowComments => 1,
-    }) eq 'redirect') {
+            returnUrl     => $self->getUrl,
-        return undef;
+        }
-    };
+    );
-    return $self->session->asset($self->getContainer)->www_view;
+    my $redirect = $result eq 'redirect';
+    $session->asset($self->getContainer) unless $redirect;
+    return $redirect;
+}
+
+#-------------------------------------------------------------------
+sub _wwwCopyProgress {
+    my ($self, $childrenOnly) = @_;
+    my $session = $self->session;
+    my $i18n    = WebGUI::International->new($session, 'Asset');
+
+    # This could potentially time out, so we'll render a progress bar.
+    my $pb = WebGUI::ProgressBar->new($session);
+    my @stack;
+
+    return $pb->run(
+        title => $i18n->get('Copy Assets'),
+        icon  => $session->url->extras('adminConsole/assets.gif'),
+        code  => sub {
+            my $bar = shift;
+            my $newAsset = $self->duplicateBranch($childrenOnly);
+            $bar->update($i18n->get('cut'));
+            my $redirect = $self->_wwwCopyFinish($newAsset);
+            return $redirect ? $self->getUrl : $self->getContainer->getUrl;
+        },
+        wrap  => {
+            'WebGUI::Asset::duplicateBranch' => sub {
+                my ($bar, $original, $asset, @args) = @_;
+                push(@stack, $asset->getTitle);
+                my $ret = $asset->$original(@args);
+                pop(@stack);
+                return $ret;
+            },
+            'WebGUI::Asset::duplicate' => sub {
+                my ($bar, $original, $asset, @args) = @_;
+                my $name = join '/', @stack, $asset->getTitle;
+                $bar->update($name);
+                return $asset->$original(@args);
+            },
+        }
+    );
+}
+
+#-------------------------------------------------------------------
+sub _wwwCopySingle {
+    my $self = shift;
+    my $newAsset = $self->duplicate({skipAutoCommitWorkflows => 1});
+    my $redirect = $self->_wwwCopyFinish($newAsset);
+    return $redirect ? undef : $self->getContainer->www_view;
 }
 
 #-------------------------------------------------------------------

lib/WebGUI/ProgressBar.pm

@@ -145,20 +145,27 @@ A message to be displayed in the status bar.
 
 =cut
 
+{
+
+# Keep the sprintf string short and don't recompute buffer breaker every time
+# update is called
+my $prefix = '<script type="text/javascript">
+/* ' . 'BUFFER BREAKER ' x 1000 . ' */
+updateWgProgressBar(';
+my $format = q"'%dpx', '%s'";
+my $suffix = '); 
+</script>
+';
+
 sub update {
 	my $self    = shift;
 	my $message = shift;
     $message    =~ s/'/\\'/g; ##Encode single quotes for JSON;
     $self->session->log->preventDebugOutput;
-    $self->{_counter} += 1;
+    my $counter = $self->{_counter} += 1;
     
-    my $modproxy_buffer_breaker = 'BUFFER BREAKER ' x 1000;
+    my $text = $prefix . sprintf($format, $counter, $message) . $suffix;
-    my $text = sprintf(<<EOJS, $self->{_counter}, $message);
+
-<script type="text/javascript">
-/* $modproxy_buffer_breaker */
-updateWgProgressBar('%dpx', '%s'); 
-</script>
-EOJS
     local $| = 1; # Tell modperl not to buffer the output
     $self->session->output->print($text, 1); #skipMacros
     if ($self->{_counter} > 600) {
@@ -167,5 +174,92 @@ EOJS
     return '';
 }
 
-1;
+}
 
+#-------------------------------------------------------------------
+
+=head2 run ( options )
+
+starts and finishes a progress bar, running some code in the middle.  It
+returns 'chunked' for convenience - if you don't use the return value, you
+should return 'chunked' yourself.
+
+The following keyword arguments are accepted (either as a bare hash or a
+hashref).
+
+=head3 code
+
+A coderef to run in between starting and stopping the progress bar.  It is
+passed the progress bar instance as its first and only argument.  It should
+return the url to redirect to with finish(), or a false value.
+
+=head3 arg
+
+An argument (just one) to be passed to code when it is called.
+
+=head3 title
+
+See start().
+
+=head3 icon
+
+See start().
+
+=head3 wrap
+
+A hashref of subroutine names to code references.  While code is being called,
+these subroutines will be wrapped with the provided code references, which
+will be passed the progress bar instance, the original code reference, and any
+arguments it would have received, similiar to a Moose 'around' method, e.g.
+
+    wrap => {
+        'WebGUI::Asset::update' => sub {
+            my $bar      = shift;
+            my $original = shift;
+            $bar->update('some message');
+            $original->(@_);
+        }
+    }
+
+=cut
+
+sub run {
+    my $self = shift;
+    my $args = $_[0];
+    $args = { @_ } unless ref $args eq 'HASH';
+
+    my %original;
+    my $wrap = $args->{wrap};
+
+    $self->start($args->{title}, $args->{icon});
+
+    my $url = eval {
+        for my $name (keys %$wrap) {
+            my $original = $original{$name} = do { no strict 'refs'; \&$name };
+            my $wrapper  = $wrap->{$name};
+            no strict 'refs';
+            *$name = sub {
+                unshift(@_, $self, $original);
+                goto &$wrapper;
+            };
+        }
+
+        $args->{code}->($self, $args->{arg});
+    };
+    my $e = $@;
+
+    # Always, always restore coderefs
+    for my $name (keys %original) {
+        my $c  = $original{$name};
+        if (ref $c eq 'CODE') {
+            no strict 'refs';
+            *$name = $c;
+        }
+    }
+
+    die $e if $e;
+
+    return $self->finish($url || $self->session->url->page);
+}
+
+1;

lib/WebGUI/i18n/English/Asset.pm

@@ -320,6 +320,11 @@ our $I18N = {
 		context => q|To remove an item from the clipboard, and put it on the current page.|
 	},
 
+    'Copy Assets' => {
+        message => q|Copy Assets|,
+        lastUpdated => 1273518396,
+    },
+
 	'Paste Assets' => {
 		message => q|Paste Assets|,
 		lastUpdated => 1245342798,

t/Asset/AssetClipboard.t

@@ -22,7 +22,7 @@ use WebGUI::Asset;
 use WebGUI::VersionTag;
 
 use Test::More; # increment this value for each test you create
-plan tests => 12;
+plan tests => 27;
 
 my $session = WebGUI::Test->session;
 $session->user({userId => 3});
@@ -100,3 +100,59 @@ is($topFolder->cloneFromDb->get('state'), 'clipboard', '... state set to trash i
 is($folder1a->cloneFromDb->get('state'),  'clipboard-limbo', '... state set to clipboard-limbo on child #1');
 is($folder1b->cloneFromDb->get('state'),  'clipboard-limbo', '... state set to clipboard-limbo on child #2');
 is($folder1a2->cloneFromDb->get('state'), 'clipboard-limbo', '... state set to clipboard-limbo on grandchild #1-1');
+
+sub is_tree_of_folders {
+    my ($asset, $depth, $pfx) = @_;
+    my $recursive; $recursive = sub {
+        my ($asset, $depth) = @_;
+        my $pfx = "    $pfx $depth";
+        return 0 unless isa_ok($asset, 'WebGUI::Asset::Wobject::Folder',
+            "$pfx: this object");
+
+        my $children = $asset->getLineage(
+            ['children'], {
+                statesToInclude => ['clipboard', 'clipboard-limbo' ],
+                returnObjects   => 1,
+            }
+        );
+
+        return $depth < 2
+            ? is(@$children, 0, "$pfx: leaf childless")
+            : is(@$children, 1, "$pfx: has child")
+              && $recursive->($children->[0], $depth - 1);
+    };
+
+    my $pass = $recursive->($asset, $depth);
+    undef $recursive;
+    my $message = "$pfx is tree of folders";
+    return $pass ? pass $message : fail $message;
+}
+
+# test www_copy
+my $tag = WebGUI::VersionTag->create($session);
+$tag->setWorking;
+WebGUI::Test->tagsToRollback($tag);
+
+my $tempspace  = WebGUI::Asset->getTempspace($session);
+my $folder     = {className => 'WebGUI::Asset::Wobject::Folder'};
+my $root       = $tempspace->addChild($folder);
+my $child      = $root->addChild($folder);
+my $grandchild = $child->addChild($folder);
+
+sub copied {
+    for my $a (@{$tempspace->getAssetsInClipboard}) {
+        if ($a->getParent->getId eq $tempspace->getId) {
+            return $a;
+        }
+    }
+    return undef;
+}
+
+my @methods = qw(Single Children Descendants);
+for my $i (0..2) {
+    my $meth = "_wwwCopy$methods[$i]";
+    $root->$meth();
+    my $clip = copied();
+    is_tree_of_folders($clip, $i+1, $meth);
+    $clip->purge;
+}

t/ProgressBar.t

@@ -0,0 +1,145 @@
+#-------------------------------------------------------------------
+# 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
+#------------------------------------------------------------------
+
+{
+    package WebGUI::Test::ProgressBar;
+    use warnings;
+    use strict;
+
+    sub new { bless {}, shift }
+
+    sub foo { $_[0]->{foo} = $_[1] }
+
+    sub bar { $_[0]->{bar} = $_[1] }
+}
+
+use strict;
+use warnings;
+
+use FindBin;
+use lib "$FindBin::Bin/lib";
+
+use Test::More;
+use Test::MockObject::Extends;
+use WebGUI::Test;
+use WebGUI::Session;
+
+my $session = WebGUI::Test->session;
+
+# Test the run method of ProgessBar -- it does some symbol table
+# manipulation...
+
+my $TestTitle = 'test title';
+my $TestIcon  = '/test/icon';
+my $TestUrl   = 'http://test.com/url';
+
+my ($started, $finished);
+my @updates = qw(one two not used);
+
+sub mockbar {
+    Test::MockObject::Extends->new(WebGUI::ProgressBar->new($session));
+}
+
+my $pb = mockbar
+    ->mock(start => sub {
+        my ($self, $title, $icon) = @_;
+        is $title, $TestTitle, 'title';
+        is $icon,  $TestIcon, 'icon';
+        ok !$started, q"hadn't started yet";
+        $started = 1;
+    })
+    ->mock(update => sub {
+        my ($self, $message) = @_;
+        my $expected = shift(@updates);
+        is $message, $expected, 'message';
+    })
+    ->mock(finish => sub {
+        my ($self, $url) = @_;
+        is $url, $TestUrl, 'url';
+        ok !$finished, q"hadn't finished yet";
+        $finished = 1;
+        return 'chunked';
+    });
+
+my $object = WebGUI::Test::ProgressBar->new;
+ok !$object->{foo}, 'no foo';
+ok !$object->{bar}, 'no bar';
+
+sub wrapper {
+    my ($bar, $original, $obj, $val) = @_;
+    $bar->update($val);
+    $obj->$original($val);
+}
+
+is $pb->run(
+    arg   => 'argument',
+    title => $TestTitle,
+    icon  => $TestIcon,
+    code  => sub {
+        my ($bar, $arg) = @_;
+        isa_ok $bar, 'WebGUI::ProgressBar', 'code invocant';
+        is $arg, 'argument', 'code argument';
+        ok $started, 'started';
+        ok !$finished, 'not finished yet';
+        is $object->foo('one'), 'one', 'wrapped return';
+        is $object->bar('two'), 'two', 'wrapped return (again)';
+        return $TestUrl;
+    },
+    wrap  => {
+        'WebGUI::Test::ProgressBar::foo' => \&wrapper,
+        'WebGUI::Test::ProgressBar::bar' => \&wrapper,
+    }
+), 'chunked', 'run return value';
+
+ok $finished, 'finished now';
+is $object->{foo}, 'one', 'foo original called';
+is $object->{bar}, 'two', 'bar original called';
+$object->foo('foo'); 
+is $object->{foo}, 'foo', 'foo still works';
+$object->bar('bar');
+is $object->{bar}, 'bar', 'bar still works';
+is @updates, 2, 'no shifting from updates after run';
+
+delete @{$object}{qw(foo bar)};
+
+my $updated;
+# make sure that the symbol table machinations work even when something dies
+$pb = mockbar->mock(start => sub {})
+    ->mock(finish => sub {})
+    ->mock(update => sub { $updated = 1 });
+
+eval {
+    $pb->run(
+        code => sub {
+            $object->foo('foo');
+            $object->bar('bar');
+        },
+        wrap => {
+            'WebGUI::Test::ProgressBar::foo' => \&wrapper,
+            'WebGUI::Test::ProgressBar::bar' => sub { die "blar!\n" }
+        }
+    );
+};
+my $e = $@;
+
+is $e, "blar!\n", 'exception propogated';
+is $object->{foo}, 'foo', 'foo after die';
+ok !$object->{bar}, 'bar did not get set';
+$object->bar('bar');
+is $object->{bar}, 'bar', 'but it works now';
+
+ok $updated, 'update called for foo';
+$updated = 0;
+$object->foo('ignored');
+ok !$updated, 'update not called for foo';
+
+done_testing;
+
+#vim:ft=perl