diff --git a/t/Asset/Post.t b/t/Asset/Post.t index 0d5535dbe..81fa89265 100644 --- a/t/Asset/Post.t +++ b/t/Asset/Post.t @@ -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 diff --git a/t/Asset/Post/Thread/permission.t b/t/Asset/Post/Thread/permission.t index a3ec3311e..240c58b65 100644 --- a/t/Asset/Post/Thread/permission.t +++ b/t/Asset/Post/Thread/permission.t @@ -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')); + diff --git a/t/Asset/Post/permission.t b/t/Asset/Post/permission.t index 1f9611e11..dcd0fd63b 100644 --- a/t/Asset/Post/permission.t +++ b/t/Asset/Post/permission.t @@ -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')); + diff --git a/t/Session/DateTime.t b/t/Session/DateTime.t index 4306aa6b5..84476bd02 100644 --- a/t/Session/DateTime.t +++ b/t/Session/DateTime.t @@ -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"); diff --git a/t/lib/WebGUI/PseudoRequest.pm b/t/lib/WebGUI/PseudoRequest.pm index f489ebd8d..c1f293c70 100644 --- a/t/lib/WebGUI/PseudoRequest.pm +++ b/t/lib/WebGUI/PseudoRequest.pm @@ -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; + diff --git a/t/lib/WebGUI/PseudoRequest/Headers.pm b/t/lib/WebGUI/PseudoRequest/Headers.pm new file mode 100644 index 000000000..f6a68db92 --- /dev/null +++ b/t/lib/WebGUI/PseudoRequest/Headers.pm @@ -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; + diff --git a/t/lib/WebGUI/PseudoRequest/Upload.pm b/t/lib/WebGUI/PseudoRequest/Upload.pm new file mode 100644 index 000000000..7a01d7f0b --- /dev/null +++ b/t/lib/WebGUI/PseudoRequest/Upload.pm @@ -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; + diff --git a/t/lib/WebGUI/Test.pm b/t/lib/WebGUI/Test.pm index edf3aea52..4a61f8199 100644 --- a/t/lib/WebGUI/Test.pm +++ b/t/lib/WebGUI/Test.pm @@ -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) @@ -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(@_); } #----------------------------------------------------------------------------