diff --git a/docs/changelog/7.x.x.txt b/docs/changelog/7.x.x.txt
index 0744c59af..1d33f344f 100644
--- a/docs/changelog/7.x.x.txt
+++ b/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
diff --git a/lib/WebGUI/AssetClipboard.pm b/lib/WebGUI/AssetClipboard.pm
index 194a37808..e8a693187 100644
--- a/lib/WebGUI/AssetClipboard.pm
+++ b/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;
- return $self->session->privilege->insufficient
- unless $self->canEdit;
+ my $self = shift;
+ my $session = $self->session;
+ return $session->privilege->insufficient unless $self->canEdit;
-
- # with: 'children' || 'descendants' || ''
- my $with = $self->session->form->get('with') || '';
- my $newAsset;
- if ($with) {
- my $childrenOnly = $with eq 'children';
- $newAsset = $self->duplicateBranch($childrenOnly);
+ my $with = $session->form->get('with');
+ if ($with eq 'children') {
+ $self->_wwwCopyChildren;
+ }
+ elsif ($with eq 'descendants') {
+ $self->_wwwCopyDescendants;
}
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, {
- allowComments => 1,
- returnUrl => $self->getUrl,
- }) eq 'redirect') {
- return undef;
- };
- return $self->session->asset($self->getContainer)->www_view;
+ my $result = WebGUI::VersionTag->autoCommitWorkingIfEnabled(
+ $session, {
+ allowComments => 1,
+ returnUrl => $self->getUrl,
+ }
+ );
+ 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;
}
#-------------------------------------------------------------------
diff --git a/lib/WebGUI/ProgressBar.pm b/lib/WebGUI/ProgressBar.pm
index 5be25932a..d098d9deb 100644
--- a/lib/WebGUI/ProgressBar.pm
+++ b/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 = '
+';
+
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 = sprintf(<{_counter}, $message);
-
-EOJS
+ my $text = $prefix . sprintf($format, $counter, $message) . $suffix;
+
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;
diff --git a/lib/WebGUI/i18n/English/Asset.pm b/lib/WebGUI/i18n/English/Asset.pm
index c159759b6..184bfaa04 100644
--- a/lib/WebGUI/i18n/English/Asset.pm
+++ b/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,
diff --git a/t/Asset/AssetClipboard.t b/t/Asset/AssetClipboard.t
index 7b061377a..69c3752d5 100644
--- a/t/Asset/AssetClipboard.t
+++ b/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;
+}
diff --git a/t/ProgressBar.t b/t/ProgressBar.t
new file mode 100644
index 000000000..f4e582b79
--- /dev/null
+++ b/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