test cleanups
This commit is contained in:
Graham Knop
parent
79a544d4ae
commit
328f3dfcec
8 changed files with 590 additions and 455 deletions
|
|
@ -59,23 +59,22 @@ my $collab = $node->addChild({className => 'WebGUI::Asset::Wobject::Collaboratio
|
|||
my $postingUser = WebGUI::User->new($session, 'new');
|
||||
my $otherUser = WebGUI::User->new($session, 'new');
|
||||
my $groupIdEditUser = WebGUI::User->new($session, 'new');
|
||||
my $groupToEditPost = WebGUI::Group->new($session, $collab->get('groupToEditPost'));
|
||||
my $groupIdEditGroup = WebGUI::Group->new($session, $collab->get('groupIdEdit'));
|
||||
my $groupToEditPostId = $collab->get('groupToEditPost');
|
||||
my $groupIdEdit = $collab->get('groupIdEdit');
|
||||
WebGUI::Test->usersToDelete($postingUser, $otherUser, $groupIdEditUser);
|
||||
$postingUser->username('userForPosting');
|
||||
$otherUser->username('otherUser');
|
||||
WebGUI::Test->groupsToDelete($groupToEditPost, $groupIdEditGroup);
|
||||
|
||||
# Add the posting user to the group allowd to post.
|
||||
$postingUser->addToGroups([$collab->get('postGroupId')]);
|
||||
|
||||
# Add $otherUser to $groupToEditPost so that they can edit the posts after the
|
||||
# timeout has expired.
|
||||
$otherUser->addToGroups([$groupToEditPost->getId]);
|
||||
$otherUser->addToGroups([$groupToEditPostId]);
|
||||
|
||||
# Similarly, add $groupIdEditUser to $groupIdEditGroup so that they, too, can
|
||||
# edit posts after the timeout has expired.
|
||||
$groupIdEditUser->addToGroups([$groupIdEditGroup->getId]);
|
||||
$groupIdEditUser->addToGroups([$groupIdEdit]);
|
||||
|
||||
# We need to become $postingUser to ensure that the canEdit tests below use
|
||||
# $postingUser's credentials rather than the default user assigned to the
|
||||
|
|
|
|||
|
|
@ -34,6 +34,7 @@ WebGUI::Test->usersToDelete($user{'2'});
|
|||
$user{"2"}->addToGroups( ['2'] ); # Registered user
|
||||
|
||||
my $versionTag = WebGUI::VersionTag->getWorking( $session );
|
||||
WebGUI::Test->tagsToRollback($versionTag);
|
||||
$versionTag->set( { name => "Collaboration Test" } );
|
||||
|
||||
my @addArgs = ( undef, undef, { skipAutoCommitWorkflows => 1, skipNotification => 1 } );
|
||||
|
|
@ -120,10 +121,5 @@ $maker->prepare( {
|
|||
} )->run;
|
||||
$thread->unlock;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Cleanup
|
||||
END {
|
||||
my $subscriptionGroup = WebGUI::Group->new($session, $thread->get('subscriptionGroupId'));
|
||||
WebGUI::Test->groupsToDelete($subscriptionGroup);
|
||||
$versionTag->rollback;
|
||||
}
|
||||
WebGUI::Test->addToCleanup('WebGUI::Group' => $thread->get('subscriptionGroupId'));
|
||||
|
||||
|
|
|
|||
|
|
@ -35,6 +35,7 @@ $user{"2"}->addToGroups( ['2'] ); # Registered user
|
|||
|
||||
my $versionTag = WebGUI::VersionTag->getWorking( $session );
|
||||
$versionTag->set( { name => "Collaboration Test" } );
|
||||
WebGUI::Test->tagsToRollback($versionTag);
|
||||
|
||||
my @addArgs = ( undef, undef, { skipAutoCommitWorkflows => 1, skipNotification => 1 } );
|
||||
|
||||
|
|
@ -93,8 +94,5 @@ $maker->prepare( {
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
# Cleanup
|
||||
END {
|
||||
my $subscriptionGroup = WebGUI::Group->new($session, $thread->get('subscriptionGroupId'));
|
||||
WebGUI::Test->groupsToDelete($subscriptionGroup);
|
||||
$versionTag->rollback;
|
||||
}
|
||||
WebGUI::Test->addToCleanup('WebGUI::Group' => $thread->get('subscriptionGroupId'));
|
||||
|
||||
|
|
|
|||
|
|
@ -93,7 +93,7 @@ is ($dt->getTimeZone(), 'America/Chicago', 'getTimeZone: fetching cached version
|
|||
my $buster = WebGUI::User->new($session, "new");
|
||||
$buster->profileField('timeZone', 'Amerigo/Vespucci');
|
||||
$session->user({user => $buster});
|
||||
WebGUI::Test->usersToDelete($buster);
|
||||
my $user_guard = cleanupGuard $buster;
|
||||
is ($dt->getTimeZone(), 'America/Chicago', 'getTimeZone: time zones not in the approved list get reset to the default');
|
||||
|
||||
my $dude = WebGUI::User->new($session, "new");
|
||||
|
|
|
|||
|
|
@ -1,19 +1,5 @@
|
|||
package WebGUI::PseudoRequest;
|
||||
|
||||
use strict;
|
||||
|
||||
use Test::MockObject;
|
||||
|
||||
Test::MockObject->fake_module(
|
||||
'Apache2::Cookie',
|
||||
new => sub {
|
||||
my $class = shift;
|
||||
my $self = Test::MockObject->new;
|
||||
$self->set_isa($class);
|
||||
$self->set_true(qw(expires domain bake));
|
||||
}
|
||||
);
|
||||
|
||||
=head1 LEGAL
|
||||
|
||||
-------------------------------------------------------------------
|
||||
|
|
@ -26,6 +12,33 @@ Test::MockObject->fake_module(
|
|||
http://www.plainblack.com info@plainblack.com
|
||||
-------------------------------------------------------------------
|
||||
|
||||
=cut
|
||||
|
||||
use strict;
|
||||
|
||||
use Test::MockObject;
|
||||
|
||||
BEGIN {
|
||||
Test::MockObject->fake_module(
|
||||
'Apache2::Cookie',
|
||||
new => sub {
|
||||
my $class = shift;
|
||||
my $self = Test::MockObject->new;
|
||||
$self->set_isa($class);
|
||||
$self->set_true(qw(expires domain bake));
|
||||
},
|
||||
);
|
||||
|
||||
Test::MockObject->fake_module('APR::Request::Apache2',
|
||||
handle => sub {
|
||||
return $_[1];
|
||||
},
|
||||
);
|
||||
}
|
||||
|
||||
use WebGUI::PseudoRequest::Headers;
|
||||
use WebGUI::PseudoRequest::Upload;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::PseudoRequest
|
||||
|
|
@ -40,169 +53,6 @@ Why in the world would you want to do this? Well, when doing API testing someti
|
|||
you run across things that require a request object, but you don't really want to
|
||||
fire up Apache in order to do it. This will let you bypass that.
|
||||
|
||||
=cut
|
||||
|
||||
package WebGUI::PseudoRequest::Headers;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::PseudoRequest::Headers
|
||||
|
||||
=head2 new
|
||||
|
||||
Construct a new PseudoRequest::Headers object. This is just for holding headers.
|
||||
It doesn't do any magic.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $this = shift;
|
||||
my $class = ref($this) || $this;
|
||||
my $self = { headers => {} };
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 set( $key, $value )
|
||||
|
||||
Set a key, value pair in the header object.
|
||||
|
||||
=cut
|
||||
|
||||
sub set {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
my $value = shift;
|
||||
$self->{headers}->{$key} = $value;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 fetch
|
||||
|
||||
Returns the entire internal hashref of headers.
|
||||
|
||||
=cut
|
||||
|
||||
sub fetch {
|
||||
my $self = shift;
|
||||
return $self->{headers};
|
||||
}
|
||||
|
||||
package WebGUI::PseudoRequest::Upload;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::PseudoRequest::Upload
|
||||
|
||||
=head2 new ( [$file] )
|
||||
|
||||
Construct a new PseudoRequest::Upload object. This is just for holding headers.
|
||||
It doesn't do any magic.
|
||||
|
||||
=head3 $file
|
||||
|
||||
The complete path to a file. If this is sent to new, it will go ahead and open
|
||||
a filehandle to that file for you, saving you the need to call the fh, filename
|
||||
and filesize methods.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $this = shift;
|
||||
my $class = ref($this) || $this;
|
||||
my $self = {
|
||||
fh => undef,
|
||||
size => 0,
|
||||
filename => '',
|
||||
output => '',
|
||||
};
|
||||
my $file = shift;
|
||||
if ($file and -e $file) {
|
||||
$self->{filename} = $file;
|
||||
$self->{size} = (stat $file)[7];
|
||||
open my $fh, '<' . $file or
|
||||
die "Unable to open $file for reading and creating a filehandle: $!\n";
|
||||
$self->{fh} = $fh;
|
||||
}
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 fh ( [$value] )
|
||||
|
||||
Getter and setter for fh. If $value is passed in, it will set the internal filehandle in
|
||||
the object to that. Returns the filehandle stored in the object.
|
||||
|
||||
=cut
|
||||
|
||||
sub fh {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
if (defined $value) {
|
||||
$self->{fh} = $value;
|
||||
}
|
||||
return $self->{fh};
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 filaname ( [$value] )
|
||||
|
||||
Getter and setter for filename. If $value is passed in, it will set the filename in
|
||||
the object to that. Returns the filename in the object.
|
||||
|
||||
=cut
|
||||
|
||||
sub filename {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
if (defined $value) {
|
||||
$self->{filename} = $value;
|
||||
}
|
||||
return $self->{filename};
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 size ( [$value] )
|
||||
|
||||
Getter and setter for size. If $value is passed in, it will set the internal size in
|
||||
the object to that. Returns the size stored in the object.
|
||||
|
||||
=cut
|
||||
|
||||
sub size {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
if (defined $value) {
|
||||
$self->{size} = $value;
|
||||
}
|
||||
return $self->{size};
|
||||
}
|
||||
|
||||
sub link {
|
||||
my $self = shift;
|
||||
my $dest = shift;
|
||||
return File::Copy::copy($self->filename, $dest);
|
||||
}
|
||||
|
||||
package WebGUI::PseudoRequest;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::PseudoRequest
|
||||
|
||||
=head2 new
|
||||
|
||||
Construct a new PseudoRequest object. Creates a new Headers object as well and places
|
||||
|
|
@ -568,4 +418,24 @@ sub user {
|
|||
return $self->{user};
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 jar ( $value )
|
||||
|
||||
Getter and setter for cookie jar. If $value is passed in, it will
|
||||
set the cookie jar of the object to that. Returns the cookie jar
|
||||
hash.
|
||||
|
||||
=cut
|
||||
|
||||
sub jar {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
if (defined $value) {
|
||||
$self->{jar} = $value;
|
||||
}
|
||||
return $self->{jar};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
|
|
|||
67
t/lib/WebGUI/PseudoRequest/Headers.pm
Normal file
67
t/lib/WebGUI/PseudoRequest/Headers.pm
Normal file
|
|
@ -0,0 +1,67 @@
|
|||
package WebGUI::PseudoRequest::Headers;
|
||||
|
||||
=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;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::PseudoRequest::Headers
|
||||
|
||||
=head2 new
|
||||
|
||||
Construct a new PseudoRequest::Headers object. This is just for holding headers.
|
||||
It doesn't do any magic.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $this = shift;
|
||||
my $class = ref($this) || $this;
|
||||
my $self = { headers => {} };
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 set( $key, $value )
|
||||
|
||||
Set a key, value pair in the header object.
|
||||
|
||||
=cut
|
||||
|
||||
sub set {
|
||||
my $self = shift;
|
||||
my $key = shift;
|
||||
my $value = shift;
|
||||
$self->{headers}->{$key} = $value;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 fetch
|
||||
|
||||
Returns the entire internal hashref of headers.
|
||||
|
||||
=cut
|
||||
|
||||
sub fetch {
|
||||
my $self = shift;
|
||||
return $self->{headers};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
119
t/lib/WebGUI/PseudoRequest/Upload.pm
Normal file
119
t/lib/WebGUI/PseudoRequest/Upload.pm
Normal file
|
|
@ -0,0 +1,119 @@
|
|||
package WebGUI::PseudoRequest::Upload;
|
||||
|
||||
=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 File::Copy ();
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Package WebGUI::PseudoRequest::Upload
|
||||
|
||||
=head2 new ( [$file] )
|
||||
|
||||
Construct a new PseudoRequest::Upload object. This is just for holding headers.
|
||||
It doesn't do any magic.
|
||||
|
||||
=head3 $file
|
||||
|
||||
The complete path to a file. If this is sent to new, it will go ahead and open
|
||||
a filehandle to that file for you, saving you the need to call the fh, filename
|
||||
and filesize methods.
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $this = shift;
|
||||
my $class = ref($this) || $this;
|
||||
my $self = {
|
||||
fh => undef,
|
||||
size => 0,
|
||||
filename => '',
|
||||
output => '',
|
||||
};
|
||||
my $file = shift;
|
||||
if ($file and -e $file) {
|
||||
$self->{filename} = $file;
|
||||
$self->{size} = (stat $file)[7];
|
||||
open my $fh, '<' . $file or
|
||||
die "Unable to open $file for reading and creating a filehandle: $!\n";
|
||||
$self->{fh} = $fh;
|
||||
}
|
||||
bless $self, $class;
|
||||
return $self;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 fh ( [$value] )
|
||||
|
||||
Getter and setter for fh. If $value is passed in, it will set the internal filehandle in
|
||||
the object to that. Returns the filehandle stored in the object.
|
||||
|
||||
=cut
|
||||
|
||||
sub fh {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
if (defined $value) {
|
||||
$self->{fh} = $value;
|
||||
}
|
||||
return $self->{fh};
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 filaname ( [$value] )
|
||||
|
||||
Getter and setter for filename. If $value is passed in, it will set the filename in
|
||||
the object to that. Returns the filename in the object.
|
||||
|
||||
=cut
|
||||
|
||||
sub filename {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
if (defined $value) {
|
||||
$self->{filename} = $value;
|
||||
}
|
||||
return $self->{filename};
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 size ( [$value] )
|
||||
|
||||
Getter and setter for size. If $value is passed in, it will set the internal size in
|
||||
the object to that. Returns the size stored in the object.
|
||||
|
||||
=cut
|
||||
|
||||
sub size {
|
||||
my $self = shift;
|
||||
my $value = shift;
|
||||
if (defined $value) {
|
||||
$self->{size} = $value;
|
||||
}
|
||||
return $self->{size};
|
||||
}
|
||||
|
||||
sub link {
|
||||
my $self = shift;
|
||||
my $dest = shift;
|
||||
return File::Copy::copy($self->filename, $dest);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
|
@ -22,142 +22,89 @@ Utility module for making testing in WebGUI easier.
|
|||
|
||||
=cut
|
||||
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use Clone qw/clone/;
|
||||
use Test::MockObject;
|
||||
use base qw(Test::Builder::Module);
|
||||
|
||||
our ( $SESSION, $WEBGUI_ROOT, $CONFIG_FILE, $WEBGUI_LIB, $WEBGUI_TEST_COLLATERAL );
|
||||
BEGIN {
|
||||
# http://thread.gmane.org/gmane.comp.apache.apreq/3378
|
||||
# http://article.gmane.org/gmane.comp.apache.apreq/3388
|
||||
if ( $^O eq 'darwin' && $Config::Config{osvers} lt '8.0.0' ) {
|
||||
unshift @INC, sub {
|
||||
return undef unless $_[1] =~ m/^Apache2|APR/;
|
||||
my $buffer = '1';
|
||||
open my $fh, '<', \$buffer;
|
||||
return $fh;
|
||||
};
|
||||
|
||||
use Config qw[];
|
||||
use IO::Handle qw[];
|
||||
use File::Spec qw[];
|
||||
use IO::Select qw[];
|
||||
use Cwd qw[];
|
||||
use Test::MockObject::Extends;
|
||||
use WebGUI::PseudoRequest;
|
||||
use Scalar::Util qw( blessed );
|
||||
use List::MoreUtils qw/ any /;
|
||||
use Carp qw[ carp croak ];
|
||||
use JSON qw( from_json to_json );
|
||||
|
||||
##Hack to get ALL test output onto STDOUT.
|
||||
use Test::Builder;
|
||||
sub import {
|
||||
no warnings;
|
||||
*Test::Builder::failure_output = sub { return \*STDOUT };
|
||||
no warnings 'redefine';
|
||||
*Apache2::Const::OK = sub () { 0 };
|
||||
*Apache2::Const::DECLINED = sub () { -1 };
|
||||
*Apache2::Const::NOT_FOUND = sub () { 404 };
|
||||
}
|
||||
}
|
||||
|
||||
our $logger_warns;
|
||||
our $logger_debug;
|
||||
our $logger_info;
|
||||
our $logger_error;
|
||||
use Test::MockObject;
|
||||
use Test::MockObject::Extends;
|
||||
use Clone qw(clone);
|
||||
use Config ();
|
||||
use IO::Handle ();
|
||||
use File::Spec ();
|
||||
use IO::Select ();
|
||||
use Cwd ();
|
||||
use Scalar::Util qw( blessed );
|
||||
use List::MoreUtils qw( any );
|
||||
use Carp qw( carp croak );
|
||||
use JSON qw( from_json to_json );
|
||||
use Scope::Guard;
|
||||
|
||||
use WebGUI::PseudoRequest;
|
||||
use WebGUI::Session;
|
||||
|
||||
our @EXPORT = qw(cleanupGuard);
|
||||
our @EXPORT_OK = qw(session config);
|
||||
|
||||
my $CLASS = __PACKAGE__;
|
||||
|
||||
my %originalConfig;
|
||||
my $originalSetting;
|
||||
|
||||
my @assetsToPurge;
|
||||
my @groupsToDelete;
|
||||
my @usersToDelete;
|
||||
my @sessionsToDelete;
|
||||
my @storagesToDelete;
|
||||
my @tagsToRollback;
|
||||
my @workflowsToDelete;
|
||||
my @guarded;
|
||||
|
||||
my $smtpdPid;
|
||||
my $smtpdStream;
|
||||
my $smtpdSelect;
|
||||
|
||||
my $mocker;
|
||||
$CLASS->init;
|
||||
|
||||
BEGIN {
|
||||
our $SESSION = WebGUI::Test->newSession(1);
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
my $originalSetting = clone $SESSION->setting->get;
|
||||
|
||||
=head2 sessionsToDelete ( $session, [$session, ...] )
|
||||
sub init {
|
||||
our $CONFIG_FILE = $ENV{ WEBGUI_CONFIG };
|
||||
|
||||
Push a list of session objects onto the stack of groups to be automatically deleted
|
||||
at the end of the test. Note, this will be the last group of objects to be
|
||||
cleaned up.
|
||||
die "Enviroment variable WEBGUI_CONFIG must be set to the full path to a WebGUI config file.\n"
|
||||
unless $CONFIG_FILE;
|
||||
die "WEBGUI_CONFIG path '$CONFIG_FILE' does not exist.\n"
|
||||
unless -e $CONFIG_FILE;
|
||||
die "WEBGUI_CONFIG path '$CONFIG_FILE' is not a file.\n"
|
||||
unless -f _;
|
||||
die "WEBGUI_CONFIG path '$CONFIG_FILE' is not readable by effective uid '$>'.\n"
|
||||
unless -r _;
|
||||
|
||||
This is a class method.
|
||||
$CONFIG_FILE = File::Spec->rel2abs($CONFIG_FILE);
|
||||
(my $volume, our $WEBGUI_ROOT, $CONFIG_FILE) = File::Spec->splitpath($CONFIG_FILE);
|
||||
$WEBGUI_ROOT = Cwd::realpath(File::Spec->catpath($volume,
|
||||
File::Spec->catdir($WEBGUI_ROOT, File::Spec->updir), ''));
|
||||
|
||||
=cut
|
||||
our $WEBGUI_TEST_COLLATERAL = File::Spec->catdir($WEBGUI_ROOT, 't', 'supporting_collateral');
|
||||
|
||||
sub sessionsToDelete {
|
||||
my $class = shift;
|
||||
push @sessionsToDelete, @_;
|
||||
}
|
||||
our $WEBGUI_LIB = File::Spec->catdir( $WEBGUI_ROOT, 'lib' );
|
||||
|
||||
|
||||
sub newSession {
|
||||
my $pseudoRequest = WebGUI::PseudoRequest->new;
|
||||
my $session = WebGUI::Session->open( $WEBGUI_ROOT, $CONFIG_FILE );
|
||||
$session->{_request} = $pseudoRequest;
|
||||
WebGUI::Test->sessionsToDelete($session);
|
||||
return $session;
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
|
||||
$mocker = Test::MockObject->fake_module(
|
||||
'APR::Request::Apache2',
|
||||
handle => sub { return bless {}, 'APR::Request::Apache2'; },
|
||||
jar => sub { return { }; },
|
||||
);
|
||||
|
||||
STDERR->autoflush(1);
|
||||
|
||||
$CONFIG_FILE = $ENV{ WEBGUI_CONFIG };
|
||||
|
||||
unless ( defined $CONFIG_FILE ) {
|
||||
warn qq/Enviroment variable WEBGUI_CONFIG must be set to the full path to a WebGUI config file.\n/;
|
||||
exit(1);
|
||||
}
|
||||
|
||||
unless ( $CONFIG_FILE ) {
|
||||
warn qq/Enviroment variable WEBGUI_CONFIG must not be empty. It must be set to the full path of a WebGUI config file.\n/;
|
||||
exit(1);
|
||||
}
|
||||
|
||||
unless ( -e $CONFIG_FILE ) {
|
||||
warn qq/WEBGUI_CONFIG path '$CONFIG_FILE' does not exist.\n/;
|
||||
exit(1);
|
||||
}
|
||||
|
||||
unless ( -f _ ) {
|
||||
warn qq/WEBGUI_CONFIG path '$CONFIG_FILE' is not a file.\n/;
|
||||
exit(1);
|
||||
}
|
||||
|
||||
unless ( -r _ ) {
|
||||
warn qq/WEBGUI_CONFIG path '$CONFIG_FILE' is not readable by effective uid '$>'.\n/;
|
||||
exit(1);
|
||||
}
|
||||
|
||||
$WEBGUI_ROOT = $CONFIG_FILE;
|
||||
|
||||
# convert to absolute path
|
||||
unless ( File::Spec->file_name_is_absolute($WEBGUI_ROOT) ) {
|
||||
$WEBGUI_ROOT = File::Spec->rel2abs($WEBGUI_ROOT);
|
||||
}
|
||||
|
||||
$CONFIG_FILE = ( File::Spec->splitpath( $WEBGUI_ROOT ) )[2];
|
||||
$WEBGUI_ROOT = substr( $WEBGUI_ROOT, 0, index( $WEBGUI_ROOT, File::Spec->catdir( 'etc', $CONFIG_FILE ) ) );
|
||||
$WEBGUI_ROOT = File::Spec->canonpath($WEBGUI_ROOT);
|
||||
$WEBGUI_ROOT = Cwd::realpath($WEBGUI_ROOT);
|
||||
$WEBGUI_TEST_COLLATERAL = File::Spec->catdir($WEBGUI_ROOT, 't', 'supporting_collateral');
|
||||
|
||||
my ($volume,$directories) = File::Spec->splitpath( $WEBGUI_ROOT, 'no_file' );
|
||||
$WEBGUI_LIB ||= File::Spec->catpath( $volume, $directories, 'lib' );
|
||||
|
||||
push (@INC,$WEBGUI_LIB);
|
||||
push @INC, $WEBGUI_LIB;
|
||||
|
||||
##Handle custom loaded library paths
|
||||
my $customPreload = File::Spec->catdir( $WEBGUI_ROOT, 'sbin', 'preload.custom');
|
||||
my $customPreload = File::Spec->catfile( $WEBGUI_ROOT, 'sbin', 'preload.custom');
|
||||
if (-e $customPreload) {
|
||||
open my $PRELOAD, '<', $customPreload or
|
||||
croak "Unload to open $customPreload: $!\n";
|
||||
|
|
@ -170,92 +117,11 @@ BEGIN {
|
|||
}
|
||||
close $PRELOAD;
|
||||
}
|
||||
|
||||
# http://thread.gmane.org/gmane.comp.apache.apreq/3378
|
||||
# http://article.gmane.org/gmane.comp.apache.apreq/3388
|
||||
if ( $^O eq 'darwin' && $Config::Config{osvers} lt '8.0.0' ) {
|
||||
unshift @INC, sub {
|
||||
return undef unless $_[1] =~ m/^Apache2|APR/;
|
||||
my $buffer = '1';
|
||||
open my $fh, '<', \$buffer;
|
||||
return $fh;
|
||||
};
|
||||
|
||||
no warnings 'redefine';
|
||||
*Apache2::Const::OK = sub { 0 };
|
||||
*Apache2::Const::DECLINED = sub { -1 };
|
||||
*Apache2::Const::NOT_FOUND = sub { 404 };
|
||||
}
|
||||
|
||||
unless ( eval { require WebGUI::Session; } ) {
|
||||
warn qq/Failed to require package 'WebGUI::Session'. Reason: '$@'.\n/;
|
||||
exit(1);
|
||||
}
|
||||
|
||||
|
||||
$SESSION = WebGUI::Test->newSession;
|
||||
|
||||
$originalSetting = clone $SESSION->setting->get;
|
||||
}
|
||||
|
||||
END {
|
||||
my $Test = Test::Builder->new;
|
||||
GROUP: foreach my $group (@groupsToDelete) {
|
||||
my $groupId = $group->getId;
|
||||
next GROUP if WebGUI::Group->vitalGroup($groupId);
|
||||
my $newGroup = WebGUI::Group->new($SESSION, $groupId);
|
||||
$newGroup->delete if $newGroup;
|
||||
}
|
||||
USER: foreach my $user (@usersToDelete) {
|
||||
my $userId = $user->userId;
|
||||
next USER if any { $userId eq $_ } (1,3);
|
||||
my $newUser = WebGUI::User->new($SESSION, $userId);
|
||||
$newUser->delete if $newUser;
|
||||
}
|
||||
STORAGE: foreach my $stor (@storagesToDelete) {
|
||||
if ($SESSION->id->valid($stor)) {
|
||||
my $storage = WebGUI::Storage->get($SESSION, $stor);
|
||||
$storage->delete if $storage;
|
||||
}
|
||||
else {
|
||||
$stor->delete;
|
||||
}
|
||||
}
|
||||
ASSET: foreach my $asset (@assetsToPurge) {
|
||||
$asset->purge;
|
||||
}
|
||||
TAG: foreach my $tag (@tagsToRollback) {
|
||||
$tag->rollback;
|
||||
}
|
||||
WORKFLOW: foreach my $workflow (@workflowsToDelete) {
|
||||
my $workflowId = $workflow->getId;
|
||||
next WORKFLOW if any { $workflowId eq $_ } qw/
|
||||
AuthLDAPworkflow000001
|
||||
csworkflow000000000001
|
||||
DPWwf20061030000000002
|
||||
PassiveAnalytics000001
|
||||
pbworkflow000000000001
|
||||
pbworkflow000000000002
|
||||
pbworkflow000000000003
|
||||
pbworkflow000000000004
|
||||
pbworkflow000000000005
|
||||
pbworkflow000000000006
|
||||
pbworkflow000000000007
|
||||
send_webgui_statistics
|
||||
/;
|
||||
my $Test = $CLASS->builder;
|
||||
|
||||
$workflow->delete;
|
||||
}
|
||||
if ($ENV{WEBGUI_TEST_DEBUG}) {
|
||||
$Test->diag('Sessions : '.$SESSION->db->quickScalar('select count(*) from userSession'));
|
||||
$Test->diag('Scratch : '.$SESSION->db->quickScalar('select count(*) from userSessionScratch'));
|
||||
$Test->diag('Users : '.$SESSION->db->quickScalar('select count(*) from users'));
|
||||
$Test->diag('Groups : '.$SESSION->db->quickScalar('select count(*) from groups'));
|
||||
$Test->diag('mailQ : '.$SESSION->db->quickScalar('select count(*) from mailQueue'));
|
||||
$Test->diag('Tags : '.$SESSION->db->quickScalar('select count(*) from assetVersionTag'));
|
||||
$Test->diag('Assets : '.$SESSION->db->quickScalar('select count(*) from assetData'));
|
||||
$Test->diag('Workflows: '.$SESSION->db->quickScalar('select count(*) from Workflow'));
|
||||
}
|
||||
while (my ($key, $value) = each %originalConfig) {
|
||||
if (defined $value) {
|
||||
$SESSION->config->set($key, $value);
|
||||
|
|
@ -267,11 +133,26 @@ END {
|
|||
while (my ($param, $value) = each %{ $originalSetting }) {
|
||||
$SESSION->setting->set($param, $value);
|
||||
}
|
||||
SESSION: foreach my $session (@sessionsToDelete) {
|
||||
$session->var->end;
|
||||
$session->close;
|
||||
|
||||
# remove guards in reverse order they were added, triggering all of the
|
||||
# requested cleanup operations
|
||||
pop @guarded
|
||||
while @guarded;
|
||||
|
||||
if ($ENV{WEBGUI_TEST_DEBUG}) {
|
||||
$Test->diag('Sessions : '.$SESSION->db->quickScalar('select count(*) from userSession'));
|
||||
$Test->diag('Scratch : '.$SESSION->db->quickScalar('select count(*) from userSessionScratch'));
|
||||
$Test->diag('Users : '.$SESSION->db->quickScalar('select count(*) from users'));
|
||||
$Test->diag('Groups : '.$SESSION->db->quickScalar('select count(*) from groups'));
|
||||
$Test->diag('mailQ : '.$SESSION->db->quickScalar('select count(*) from mailQueue'));
|
||||
$Test->diag('Tags : '.$SESSION->db->quickScalar('select count(*) from assetVersionTag'));
|
||||
$Test->diag('Assets : '.$SESSION->db->quickScalar('select count(*) from assetData'));
|
||||
$Test->diag('Workflows: '.$SESSION->db->quickScalar('select count(*) from Workflow'));
|
||||
}
|
||||
|
||||
$SESSION->var->end;
|
||||
$SESSION->close;
|
||||
|
||||
# Close SMTPD
|
||||
if ($smtpdPid) {
|
||||
kill INT => $smtpdPid;
|
||||
|
|
@ -283,12 +164,30 @@ END {
|
|||
}
|
||||
}
|
||||
|
||||
=head2 newSession ( )
|
||||
=head2 newSession ( $noCleanup )
|
||||
|
||||
Builds a WebGUI session object for testing.
|
||||
|
||||
=head3 $noCleanup
|
||||
|
||||
If true, the session won't be registered for automatic deletion.
|
||||
|
||||
=cut
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
sub newSession {
|
||||
my $noCleanup = shift;
|
||||
my $pseudoRequest = WebGUI::PseudoRequest->new;
|
||||
my $session = WebGUI::Session->open( $CLASS->root, $CLASS->file );
|
||||
$session->{_request} = $pseudoRequest;
|
||||
if ( ! $noCleanup ) {
|
||||
WebGUI::Test->sessionsToDelete($session);
|
||||
}
|
||||
return $session;
|
||||
}
|
||||
|
||||
|
||||
=head2 mockAssetId ( $assetId, $object )
|
||||
|
||||
Causes WebGUI::Asset->new* initializers to return the specified
|
||||
|
|
@ -396,10 +295,10 @@ sub interceptLogging {
|
|||
my $logger = $SESSION->log->getLogger;
|
||||
$logger = Test::MockObject::Extends->new( $logger );
|
||||
|
||||
$logger->mock( 'warn', sub { $WebGUI::Test::logger_warns = $_[1]} );
|
||||
$logger->mock( 'debug', sub { $WebGUI::Test::logger_debug = $_[1]} );
|
||||
$logger->mock( 'info', sub { $WebGUI::Test::logger_info = $_[1]} );
|
||||
$logger->mock( 'error', sub { $WebGUI::Test::logger_error = $_[1]} );
|
||||
$logger->mock( 'warn', sub { our $logger_warns = $_[1]} );
|
||||
$logger->mock( 'debug', sub { our $logger_debug = $_[1]} );
|
||||
$logger->mock( 'info', sub { our $logger_info = $_[1]} );
|
||||
$logger->mock( 'error', sub { our $logger_error = $_[1]} );
|
||||
$logger->mock( 'isDebug', sub { return 1 } );
|
||||
$logger->mock( 'is_debug', sub { return 1 } );
|
||||
}
|
||||
|
|
@ -426,7 +325,7 @@ Returns the name of the WebGUI config file used for this test.
|
|||
=cut
|
||||
|
||||
sub file {
|
||||
return $CONFIG_FILE;
|
||||
return our $CONFIG_FILE;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -449,7 +348,6 @@ below.
|
|||
|
||||
sub getPage {
|
||||
my $class = shift;
|
||||
my $session = $SESSION; # The session object
|
||||
my $actor = shift; # The actor to work on
|
||||
my $page = shift; # The page subroutine
|
||||
my $optionsRef = shift; # A hashref of options
|
||||
|
|
@ -458,14 +356,7 @@ sub getPage {
|
|||
# userId => A user ID to set, "user" takes
|
||||
# precedence
|
||||
|
||||
#!!! GETTING COOKIES WITH WebGUI::PseudoRequest DOESNT WORK, SO WE USE
|
||||
# THIS AS A WORKAROUND
|
||||
$session->http->{_http}->{noHeader} = 1;
|
||||
|
||||
# Open a buffer as a filehandle
|
||||
my $buffer = "";
|
||||
open my $output, ">", \$buffer or die "Couldn't open memory buffer as filehandle: $@";
|
||||
$session->output->setHandle($output);
|
||||
my $session = $SESSION;
|
||||
|
||||
# Set the appropriate user
|
||||
my $oldUser = $session->user;
|
||||
|
|
@ -495,24 +386,18 @@ sub getPage {
|
|||
# Try using it as a subroutine
|
||||
no strict 'refs';
|
||||
$returnedContent = $actor->(@{$optionsRef->{args}});
|
||||
use strict 'refs';
|
||||
}
|
||||
|
||||
if ($returnedContent && $returnedContent ne "chunked") {
|
||||
print $output $returnedContent;
|
||||
$session->output->print($returnedContent);
|
||||
}
|
||||
|
||||
close $output;
|
||||
|
||||
# Restore the former user and request
|
||||
$session->user({ user => $oldUser });
|
||||
$session->{_request} = $oldRequest;
|
||||
|
||||
#!!! RESTORE THE WORKAROUND
|
||||
delete $session->http->{_http}->{noHeader};
|
||||
|
||||
# Return the page's output
|
||||
return $buffer;
|
||||
my $return = $request->get_output;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -529,7 +414,7 @@ Optionally adds a filename to the end.
|
|||
sub getTestCollateralPath {
|
||||
my $class = shift;
|
||||
my $filename = shift;
|
||||
return File::Spec->catfile($WEBGUI_TEST_COLLATERAL,$filename);
|
||||
return File::Spec->catfile(our $WEBGUI_TEST_COLLATERAL, $filename);
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -541,7 +426,7 @@ Returns the full path to the WebGUI lib directory, usually /data/WebGUI/lib.
|
|||
=cut
|
||||
|
||||
sub lib {
|
||||
return $WEBGUI_LIB;
|
||||
return our $WEBGUI_LIB;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -553,7 +438,7 @@ Returns the full path to the WebGUI root directory, usually /data/WebGUI.
|
|||
=cut
|
||||
|
||||
sub root {
|
||||
return $WEBGUI_ROOT;
|
||||
return our $WEBGUI_ROOT;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -643,39 +528,6 @@ sub originalConfig {
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 assetsToPurge ( $asset, [$asset ] )
|
||||
|
||||
Push a list of Asset objects onto the stack of assets to be automatically purged
|
||||
at the end of the test. This will also clean-up all version tags associated
|
||||
with the Asset.
|
||||
|
||||
This is a class method.
|
||||
|
||||
=cut
|
||||
|
||||
sub assetsToPurge {
|
||||
my $class = shift;
|
||||
push @assetsToPurge, @_;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 groupsToDelete ( $group, [$group ] )
|
||||
|
||||
Push a list of group objects onto the stack of groups to be automatically deleted
|
||||
at the end of the test.
|
||||
|
||||
This is a class method.
|
||||
|
||||
=cut
|
||||
|
||||
sub groupsToDelete {
|
||||
my $class = shift;
|
||||
push @groupsToDelete, @_;
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 getMail ( )
|
||||
|
||||
Read a sent mail from the prepared mail server (L<prepareMailServer>)
|
||||
|
|
@ -729,6 +581,56 @@ sub getMailFromQueue {
|
|||
|
||||
return $class->getMail;
|
||||
}
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 sessionsToDelete ( $session, [$session, ...] )
|
||||
|
||||
Push a list of session objects onto the stack of groups to be automatically deleted
|
||||
at the end of the test. Note, this will be the last group of objects to be
|
||||
cleaned up.
|
||||
|
||||
This is a class method.
|
||||
|
||||
=cut
|
||||
|
||||
sub sessionsToDelete {
|
||||
my $class = shift;
|
||||
push @guarded, cleanupGuard(@_);
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 assetsToPurge ( $asset, [$asset ] )
|
||||
|
||||
Push a list of Asset objects onto the stack of assets to be automatically purged
|
||||
at the end of the test. This will also clean-up all version tags associated
|
||||
with the Asset.
|
||||
|
||||
This is a class method.
|
||||
|
||||
=cut
|
||||
|
||||
sub assetsToPurge {
|
||||
my $class = shift;
|
||||
push @guarded, cleanupGuard(@_);
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 groupsToDelete ( $group, [$group ] )
|
||||
|
||||
Push a list of group objects onto the stack of groups to be automatically deleted
|
||||
at the end of the test.
|
||||
|
||||
This is a class method.
|
||||
|
||||
=cut
|
||||
|
||||
sub groupsToDelete {
|
||||
my $class = shift;
|
||||
push @guarded, cleanupGuard(@_);
|
||||
}
|
||||
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -743,7 +645,9 @@ This is a class method.
|
|||
|
||||
sub storagesToDelete {
|
||||
my $class = shift;
|
||||
push @storagesToDelete, @_;
|
||||
push @guarded, cleanupGuard(map {
|
||||
ref $_ ? $_ : ('WebGUI::Storage' => $_)
|
||||
} @_);
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -758,7 +662,7 @@ This is a class method.
|
|||
|
||||
sub tagsToRollback {
|
||||
my $class = shift;
|
||||
push @tagsToRollback, @_;
|
||||
push @guarded, cleanupGuard(@_);
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -774,7 +678,7 @@ This is a class method.
|
|||
|
||||
sub usersToDelete {
|
||||
my $class = shift;
|
||||
push @usersToDelete, @_;
|
||||
push @guarded, cleanupGuard(@_);
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -790,7 +694,189 @@ This is a class method.
|
|||
|
||||
sub workflowsToDelete {
|
||||
my $class = shift;
|
||||
push @workflowsToDelete, @_;
|
||||
push @guarded, cleanupGuard(@_);
|
||||
}
|
||||
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 cleanupGuard ( $object, $class => $ident )
|
||||
|
||||
Pass in a list of objects or pairs of classes and identifiers, and
|
||||
it will return a guard object for cleaning them up. When the guard
|
||||
object goes out of scope, it will automatically clean up all of the
|
||||
passed in objects. Objects will be destroyed in the order they
|
||||
were passed in. Currently able to destroy:
|
||||
|
||||
WebGUI::Asset
|
||||
WebGUI::Group
|
||||
WebGUI::Session
|
||||
WebGUI::Storage
|
||||
WebGUI::User
|
||||
WebGUI::VersionTag
|
||||
WebGUI::Workflow
|
||||
|
||||
Example call:
|
||||
|
||||
my $guard = cleanupGuard(
|
||||
$user,
|
||||
$workflow,
|
||||
'WebGUI::Group' => $groupId,
|
||||
$asset,
|
||||
);
|
||||
|
||||
=cut
|
||||
|
||||
{
|
||||
my %initialize = (
|
||||
'' => sub {
|
||||
my ($class, $ident) = @_;
|
||||
return $class->new($SESSION, $ident);
|
||||
},
|
||||
'WebGUI::Storage' => sub {
|
||||
my ($class, $ident) = @_;
|
||||
return WebGUI::Storage->get($SESSION, $ident);
|
||||
},
|
||||
);
|
||||
|
||||
my %clone = (
|
||||
'WebGUI::User' => sub {
|
||||
WebGUI::User->new($SESSION, shift->getId);
|
||||
},
|
||||
'WebGUI::Group' => sub {
|
||||
WebGUI::Group->new($SESSION, shift->getId);
|
||||
},
|
||||
);
|
||||
|
||||
my %check = (
|
||||
'WebGUI::User' => sub {
|
||||
my $user = shift;
|
||||
my $userId = $user->userId;
|
||||
die "Refusing to clean up vital user @{[ $user->username ]}!\n"
|
||||
if any { $userId eq $_ } (1, 3);
|
||||
},
|
||||
'WebGUI::Group' => sub {
|
||||
my $group = shift;
|
||||
die "Refusing to clean up vital group @{[ $group->name ]}!\n"
|
||||
if $group->vitalGroup;
|
||||
},
|
||||
'WebGUI::Workflow' => sub {
|
||||
my $workflow = shift;
|
||||
my $workflowId = $workflow->getId;
|
||||
die "Refusing to clean up vital workflow @{[ $workflow->get('title') ]}!\n"
|
||||
if any { $workflowId eq $_ } qw{
|
||||
AuthLDAPworkflow000001
|
||||
csworkflow000000000001
|
||||
DPWwf20061030000000002
|
||||
PassiveAnalytics000001
|
||||
pbworkflow000000000001
|
||||
pbworkflow000000000002
|
||||
pbworkflow000000000003
|
||||
pbworkflow000000000004
|
||||
pbworkflow000000000005
|
||||
pbworkflow000000000006
|
||||
pbworkflow000000000007
|
||||
send_webgui_statistics
|
||||
};
|
||||
},
|
||||
);
|
||||
|
||||
my %cleanup = (
|
||||
'WebGUI::User' => 'delete',
|
||||
'WebGUI::Group' => 'delete',
|
||||
'WebGUI::Storage' => 'delete',
|
||||
'WebGUI::Asset' => 'purge',
|
||||
'WebGUI::VersionTag' => 'rollback',
|
||||
'WebGUI::Workflow' => 'delete',
|
||||
'WebGUI::Session' => sub {
|
||||
my $session = shift;
|
||||
$session->var->end;
|
||||
$session->close;
|
||||
},
|
||||
);
|
||||
|
||||
sub cleanupGuard {
|
||||
shift
|
||||
if ref $_[0] && $_[0]->isa($CLASS);
|
||||
my @cleanups;
|
||||
while (@_) {
|
||||
my $class = shift;
|
||||
my $construct;
|
||||
if ( ref $class ) {
|
||||
my $object = $class;
|
||||
my $cloneSub = $CLASS->_findByIsa($class, \%clone);
|
||||
$construct = $cloneSub ? sub { $object->$cloneSub } : sub { $object };
|
||||
$class = ref $class;
|
||||
}
|
||||
else {
|
||||
my $id = shift;
|
||||
my $initSub = $CLASS->_findByIsa($class, \%initialize)
|
||||
|| croak "Can't find initializer for $class\n";
|
||||
$construct = sub { $initSub->($class, $id) };
|
||||
}
|
||||
if (my $check = $CLASS->_findByIsa($class, \%check)) {
|
||||
local $@;
|
||||
if ( ! eval { $construct->()->$check; 1 } ) {
|
||||
if ($@) {
|
||||
carp $@;
|
||||
}
|
||||
else {
|
||||
carp "Refusing to clean up vital $class!\n";
|
||||
}
|
||||
next;
|
||||
}
|
||||
}
|
||||
my $destroy = $CLASS->_findByIsa($class, \%cleanup)
|
||||
|| croak "Can't find destructor for $class";
|
||||
push @cleanups, $construct, $destroy;
|
||||
}
|
||||
return Scope::Guard->new(sub {
|
||||
local $@;
|
||||
while ( 1 ) {
|
||||
my ($construct, $destroy) = (shift @cleanups, shift @cleanups);
|
||||
last
|
||||
if ! $construct;
|
||||
if ( my $object = eval { $construct->() } ) {
|
||||
eval { $object->$destroy };
|
||||
}
|
||||
if (ref $@ && $@->isa('WebGUI::Error::ObjectNotFound')) {
|
||||
# ignore objects that don't exist
|
||||
}
|
||||
elsif ($@) {
|
||||
warn $@;
|
||||
}
|
||||
}
|
||||
return;
|
||||
});
|
||||
}
|
||||
}
|
||||
|
||||
sub _findByIsa {
|
||||
my $self = shift;
|
||||
my $toFind = shift;
|
||||
my $hash = shift;
|
||||
for my $key ( sort { length $b <=> length $a} keys %$hash ) {
|
||||
if ($toFind->isa($key)) {
|
||||
return $hash->{$key};
|
||||
}
|
||||
}
|
||||
return $hash->{''};
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
||||
=head2 addToCleanup ( $object, $class => $ident )
|
||||
|
||||
Takes the same parameters as cleanupGuard, but cleans the objects
|
||||
up at the end of the test instead of returning a guard object.
|
||||
|
||||
This is a class method.
|
||||
|
||||
=cut
|
||||
|
||||
sub addToCleanup {
|
||||
my $class = shift;
|
||||
push @guarded, cleanupGuard(@_);
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue