oqapi/webgui
2
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Merge commit '17ce3572bf' into WebGUI8. All tests passing.

Browse source
This commit is contained in:
Colin Kuskie 2010-06-30 18:43:27 -07:00
commit 5e502fee53
117 changed files with 2012 additions and 1027 deletions
Download patch file Download diff file Expand all files Collapse all files

23
docs/changelog/7.x.x.txt
View file

@ -1,3 +1,26 @@
7.9.7
- added #11571: Allow return from photo edit view to gallery edit view
- fixed: Reject form submissions without image selected for upload in edit view of Photo asset
- fixed #11596: Calendar: all day events leaking
- fixed #11604: scheduled workflows getting deleted
- fixed #11613: Thingy: If next action after add is to add more things, previous data remains
- added API method commitAsUser allowing developers to commit version tags as other users
- fixed: The template form plugin would return an empty string when getValueAsHtml was called. ( Martin Kamerbeek / Oqapi )
- fixed #11611: Thingy: The add field pop up box has multiple "Text" field types
- fixed #11610: Bad hover help for CS sortBy field
- fixed #11605: UserList refers to non-existent "publicEmail" user profiling field
- fixed #11595: Orphaned data in inbox_messageState
- fixed AddressBook feedback for missing fields.
- fixed #11606: Syndicated Content feed returns a relative link
- fixed #11614: Forums: Sort Fields
- fixed #11616: No access to /root
- fixed #11619: Trash Expired Events not trashing events
- fixed #11623: Navigation CSS-id
- fixed #11629: WebGUI Collateral Manager = Error
- fixed #11622: Archived CSS entries displayable.
- fixed #11560: Email footer hidden from Outlook users
- fixed #11643: Account/Contributions: does not show archived content
7.9.6
- new checkbox in the asset manager for clearing the package flag on import
- fixed #11597: manageTrash and newlines

14
docs/create.sql
View file

File diff suppressed because one or more lines are too long

6
docs/gotcha.txt
View file

@ -17,6 +17,12 @@ save you many hours of grief.
- Moose
- CHI
7.9.7
--------------------------------------------------------------------
* Due to a bug introduced in 7.9.3, Scheduler tasks may have been deleted
from your site. The 7.9.7 upgrade will restore all default tasks, and tasks
for handling email from Collaboration Systems, but you should check any Scheduler
tasks that you have created.
7.9.6
--------------------------------------------------------------------

18
docs/previousVersion.sql
View file

File diff suppressed because one or more lines are too long

BIN
docs/upgrades/packages-7.9.7/root_import_gallery-templates_admin.css.wgpkg Normal file
View file

Binary file not shown.

BIN
docs/upgrades/packages-7.9.7/root_import_gallery-templates_default-gallery-edit-album.wgpkg Normal file
View file

Binary file not shown.

241
docs/upgrades/upgrade_7.9.6-7.9.7.pl Normal file
View file

@ -0,0 +1,241 @@
#!/usr/bin/env perl
#-------------------------------------------------------------------
# WebGUI is Copyright 2001-2009 Plain Black Corporation.
#-------------------------------------------------------------------
# Please read the legal notices (docs/legal.txt) and the license
# (docs/license.txt) that came with this distribution before using
# this software.
#-------------------------------------------------------------------
# http://www.plainblack.com info@plainblack.com
#-------------------------------------------------------------------
our ($webguiRoot);
BEGIN {
$webguiRoot = "../..";
unshift (@INC, $webguiRoot."/lib");
}
use strict;
use Getopt::Long;
use WebGUI::Session;
use WebGUI::Storage;
use WebGUI::Asset;
use WebGUI::Asset::Wobject::Collaboration;
use WebGUI::Exception;
use WebGUI::Workflow::Cron;
use WebGUI::Utility qw/isIn/;
my $toVersion = '7.9.7';
my $quiet; # this line required
my $session = start(); # this line required
# upgrade functions go here
restoreDefaultCronJobs($session);
restoreCsCronJobs($session);
cleanup_inbox_messageStateTable($session);
finish($session); # this line required
#----------------------------------------------------------------------------
# Describe what our function does
#sub exampleFunction {
# my $session = shift;
# print "\tWe're doing some stuff here that you should know about... " unless $quiet;
# # and here's our code
# print "DONE!\n" unless $quiet;
#}
#----------------------------------------------------------------------------
# Describe what our function does
sub cleanup_inbox_messageStateTable {
my $session = shift;
print "\tDelete dead entries from the inbox_MessageState table. This may take a long time... " unless $quiet;
# and here's our code
my $source = $session->db->read("select messageId from inbox_messageState s where not exists(select messageId from inbox where messageId = s.messageId)");
my $cleaner = $session->db->prepare("delete from inbox_messageState where messageId=?");
while (my ($messageId) = $source->array) {
$cleaner->execute([$messageId]);
}
$source->finish;
$cleaner->finish;
print "DONE!\n" unless $quiet;
}
#----------------------------------------------------------------------------
# Describe what our function does
sub restoreDefaultCronJobs {
my $session = shift;
# and here's our code
print "\tRestore missing default cron jobs that may have been deleted... " unless $quiet;
my $tasks = WebGUI::Workflow::Cron->getAllTasks($session);
my @taskIds = map { $_->getId } @{ $tasks };
if (! isIn('pbcron0000000000000001', @taskIds)) {
print "\n\t\tRestoring Daily Maintenance Task... " unless $quiet;
WebGUI::Workflow::Cron->create($session, {
title => "Daily Maintenance", dayOfMonth => '*',
enabled => 1, monthOfYear => '*',
runOnce => 0, dayOfWeek => '*',
minuteOfHour => 30, workflowId => 'pbworkflow000000000001',
hourOfDay => 23, priority => 3,
},
'pbcron0000000000000001');
}
if (! isIn('pbcron0000000000000002', @taskIds)) {
print "\n\t\tRestoring Weekly Maintenance Task... " unless $quiet;
WebGUI::Workflow::Cron->create($session, {
title => "Weekly Maintenance", dayOfMonth => '*',
enabled => 1, monthOfYear => '*',
runOnce => 0, dayOfWeek => '0',
minuteOfHour => 30, workflowId => 'pbworkflow000000000002',
hourOfDay => 1, priority => 3,
},
'pbcron0000000000000002');
}
if (! isIn('pbcron0000000000000003', @taskIds)) {
print "\n\t\tRestoring Hourly Maintenance Task... " unless $quiet;
WebGUI::Workflow::Cron->create($session, {
title => "Hourly Maintenance", dayOfMonth => '*',
enabled => 1, monthOfYear => '*',
runOnce => 0, dayOfWeek => '*',
minuteOfHour => 15, workflowId => 'pbworkflow000000000004',
hourOfDay => '*', priority => 3,
},
'pbcron0000000000000003');
}
if (! isIn('pbcron0000000000000004', @taskIds)) {
print "\n\t\tRestoring Email Delivery Task... " unless $quiet;
WebGUI::Workflow::Cron->create($session, {
title => "Send Queued Email Messages Every 5 Minutes",
dayOfMonth => '*',
enabled => 1, monthOfYear => '*',
runOnce => 0, dayOfWeek => '*',
minuteOfHour => '*/5', workflowId => 'pbworkflow000000000007',
hourOfDay => '*', priority => 3,
},
'pbcron0000000000000004');
}
print "DONE!\n" unless $quiet;
}
#----------------------------------------------------------------------------
# Describe what our function does
sub restoreCsCronJobs {
my $session = shift;
print "\tRestore missing Collaboration System cron jobs that may have been deleted... " unless $quiet;
my $i18n = WebGUI::International->new($session, "Asset_Collaboration");
my $getCs = WebGUI::Asset::Wobject::Collaboration->getIsa($session);
CS: while (1) {
my $cs = eval { $getCs->(); };
if (my $e = Exception::Class->caught()) {
$session->log->error($@);
next CS;
}
last CS unless $cs;
##Do something useful with $product
my $cron = undef;
if ($cs->get("getMailCronId")) {
$cron = WebGUI::Workflow::Cron->new($session, $cs->get("getMailCronId"));
}
next CS if $cron;
$cron = WebGUI::Workflow::Cron->create($session, {
title => $cs->getTitle." ".$i18n->get("mail"),
minuteOfHour => "*/".($cs->get("getMailInterval")/60),
className => (ref $cs),
methodName => "new",
parameters => $cs->getId,
workflowId => "csworkflow000000000001"
});
$cs->update({getMailCronId=>$cron->getId});
if ($cs->get("getMail")) {
$cron->set({enabled=>1,title=>$cs->getTitle." ".$i18n->get("mail"), minuteOfHour=>"*/".($cs->get("getMailInterval")/60)});
} else {
$cron->set({enabled=>0,title=>$cs->getTitle." ".$i18n->get("mail"), minuteOfHour=>"*/".($cs->get("getMailInterval")/60)});
}
}
print "DONE!\n" unless $quiet;
}
# -------------- DO NOT EDIT BELOW THIS LINE --------------------------------
#----------------------------------------------------------------------------
# Add a package to the import node
sub addPackage {
my $session = shift;
my $file = shift;
print "\tUpgrading package $file\n" unless $quiet;
# Make a storage location for the package
my $storage = WebGUI::Storage->createTemp( $session );
$storage->addFileFromFilesystem( $file );
# Import the package into the import node
my $package = eval {
my $node = WebGUI::Asset->getImportNode($session);
$node->importPackage( $storage, {
overwriteLatest => 1,
clearPackageFlag => 1,
setDefaultTemplate => 1,
} );
};
if ($package eq 'corrupt') {
die "Corrupt package found in $file. Stopping upgrade.\n";
}
if ($@ || !defined $package) {
die "Error during package import on $file: $@\nStopping upgrade\n.";
}
return;
}
#-------------------------------------------------
sub start {
my $configFile;
$|=1; #disable output buffering
GetOptions(
'configFile=s'=>\$configFile,
'quiet'=>\$quiet
);
my $session = WebGUI::Session->open($webguiRoot,$configFile);
$session->user({userId=>3});
my $versionTag = WebGUI::VersionTag->getWorking($session);
$versionTag->set({name=>"Upgrade to ".$toVersion});
return $session;
}
#-------------------------------------------------
sub finish {
my $session = shift;
updateTemplates($session);
my $versionTag = WebGUI::VersionTag->getWorking($session);
$versionTag->commit;
$session->db->write("insert into webguiVersion values (".$session->db->quote($toVersion).",'upgrade',".time().")");
$session->close();
}
#-------------------------------------------------
sub updateTemplates {
my $session = shift;
return undef unless (-d "packages-".$toVersion);
print "\tUpdating packages.\n" unless ($quiet);
opendir(DIR,"packages-".$toVersion);
my @files = readdir(DIR);
closedir(DIR);
my $newFolder = undef;
foreach my $file (@files) {
next unless ($file =~ /\.wgpkg$/);
# Fix the filename to include a path
$file = "packages-" . $toVersion . "/" . $file;
addPackage( $session, $file );
}
}
#vim:ft=perl

11
lib/WebGUI/Account/Contributions.pm
View file

@ -180,8 +180,9 @@ sub www_view {
'WebGUI::Asset::WikiPage',
'WebGUI::Asset::Post::Thread',
],
whereClause => "asset.createdBy = '$userId' or assetData.ownerUserId = '$userId'",
orderByClause => "$sortBy $sortDir"
statusToInclude => [ qw/approved archived/ ],
whereClause => "asset.createdBy = '$userId' or assetData.ownerUserId = '$userId'",
orderByClause => "$sortBy $sortDir"
}
);
@ -204,12 +205,6 @@ sub www_view {
}
my $props = $asset->get;
$props->{url} = $asset->getUrl;
if (ref $asset eq "WebGUI::Asset::Post") {
$asset = $asset->getThread;
$props = $asset->get;
$props->{className} = "WebGUI::Asset::Post";
}
push(@contribs,$props);
}
my $contribsCount = $p->getRowCount;

4
lib/WebGUI/Asset.pm
View file

@ -2781,6 +2781,10 @@ sub www_editSave {
$session->asset($object->getParent);
return $session->asset->www_view;
}
elsif ($proceed eq "editParent") {
$session->asset($object->getParent);
return $session->asset->www_edit;
}
elsif ($proceed eq "goBackToPage" && $session->form->process('returnUrl')) {
$session->http->setRedirect($session->form->process("returnUrl"));
return undef;

31
lib/WebGUI/Asset/File/GalleryFile/Photo.pm
View file

@ -108,8 +108,7 @@ override applyConstraints => sub {
$storage->resize( $file, undef, undef, $gallery->imageDensity );
$storage->adjustMaxImageSize($file, $maxImageSize);
$self->generateThumbnail;
$self->setSize;
$self->generateThumbnail;
$self->updateExifDataFromFile;
super();
};
@ -229,10 +228,11 @@ sub getEditFormUploadControl {
}
# Control to upload a new file
$html .= WebGUI::Form::file( $session, {
name => 'newFile',
label => $i18n->get('new file'),
hoverHelp => $i18n->get('new file description'),
$html .= WebGUI::Form::image( $session, {
name => 'newFile',
label => $i18n->get('new file'),
hoverHelp => $i18n->get('new file description'),
forceImageOnly => 1,
});
return $html;
@ -378,11 +378,19 @@ contained in.
sub makeResolutions {
my $self = shift;
my $resolutions = shift;
my $session = $self->session;
my $error;
croak "Photo->makeResolutions: resolutions must be an array reference"
if $resolutions && ref $resolutions ne "ARRAY";
# # Return immediately if no image is available
# if ( $self->get("filename") eq '' )
# {
# $session->log->error("makeResolutions skipped since no image available");
# return;
# }
# Get default if necessary
$resolutions ||= $self->getGallery->getImageResolutions;
@ -413,13 +421,20 @@ Make the default title into the file name minus the extention.
override processPropertiesFromFormPost => sub {
my $self = shift;
my $i18n = WebGUI::International->new( $self->session,'Asset_Photo' );
my $form = $self->session->form;
my $errors = super() || [];
# Make sure there is an image file attached to this asset.
if ( !$self->get('filename') ) {
push @{ $errors }, $i18n->get('error no image');
}
# Return if errors
return $errors if @$errors;
### Passes all checks
# If no title was given, make it the file name
if ( !$form->get('title') ) {
my $title = $self->filename;
@ -586,6 +601,7 @@ sub www_edit {
$var->{ form_start }
= WebGUI::Form::formHeader( $session, {
action => $self->getParent->getUrl('func=editSave;assetId=new;class='.__PACKAGE__),
extras => 'name="photoAdd"',
})
. WebGUI::Form::hidden( $session, {
name => 'ownerUserId',
@ -597,6 +613,7 @@ sub www_edit {
$var->{ form_start }
= WebGUI::Form::formHeader( $session, {
action => $self->getUrl('func=editSave'),
extras => 'name="photoEdit"',
})
. WebGUI::Form::hidden( $session, {
name => 'ownerUserId',
@ -607,7 +624,7 @@ sub www_edit {
$var->{ form_start }
.= WebGUI::Form::hidden( $session, {
name => "proceed",
value => "showConfirmation",
value => $form->get('proceed') || "showConfirmation",
});
$var->{ form_end } = WebGUI::Form::formFooter( $session );

11
lib/WebGUI/Asset/Post.pm
View file

@ -119,8 +119,8 @@ sub _fixReplyCount {
isa => 'WebGUI::Asset::Post',
orderByClause => 'assetData.revisionDate desc',
} )->[0];
if (my $lastPost = WebGUI::Asset->newById( $self->session, $lastPostId ) ) {
my $lastPost = eval { WebGUI::Asset->newById( $self->session, $lastPostId ); };
if ( ! Exception::Class->caught() ) {
$asset->incrementReplies( $lastPost->revisionDate, $lastPost->getId );
}
else {
@ -292,23 +292,30 @@ the parent thread.
=cut
override cut => sub {
warn "post's cut";
my $self = shift;
# Fetch the Thread and CS before cutting the asset.
my $thread = $self->getThread;
warn "got thread";
my $cs = $thread->getParent;
warn "got cs";
# Cut the asset
my $result = super();
warn "called super";
# If a post is being cut update the thread reply count first
if ($thread->getId ne $self->getId) {
warn "calling _fixReplyCount on thread";
$self->_fixReplyCount( $thread );
}
# Update the CS reply count. This step is also necessary when a Post is cut since the Thread's incrementReplies
# also calls the CS's incrementReplies, possibly with the wrong last post Id.
warn "calling _fixReplyCount on cs";
$self->_fixReplyCount( $cs );
warn "all should be well...?";
return $result;
};

8
lib/WebGUI/Asset/Story.pm
View file

@ -501,12 +501,14 @@ property of the Asset.
=cut
sub getRssData {
my $self = shift;
my $self = shift;
my $session = $self->session;
my $url = $session->url->getSiteURL.$self->getUrl;
my $data = {
title => $self->headline || $self->getTitle,
description => $self->story,
'link' => $self->getUrl,
guid => $self->getUrl,
'link' => $url,
guid => $url,
author => $self->byline,
date => $self->lastModified,
pubDate => $self->session->datetime->epochToMail($self->creationDate),

4
lib/WebGUI/Asset/Wobject/Calendar.pm
View file

@ -769,7 +769,7 @@ sub getEventsIn {
&& Event.endTime IS NULL
&&
!(
Event.startDate > '$endDate'
Event.startDate > SUBDATE('$endDate', INTERVAL 1 DAY)
|| Event.endDate < '$startDate'
)
)
@ -794,7 +794,7 @@ sub getEventsIn {
my $orderby = join ',', @order_priority;
my $events
= $self->getLineage(["descendants"], {
= $self->getLineage(["children"], {
returnObjects => 1,
includeOnlyClasses => ['WebGUI::Asset::Event'],
joinClass => 'WebGUI::Asset::Event',

2
lib/WebGUI/Asset/Wobject/Collaboration.pm
View file

@ -1176,7 +1176,7 @@ sub getThreadsPaginator {
$sortBy =~ s/^\w+\.//;
# Sort by the thread rating instead of the post rating. other places don't care about threads.
$sortBy = $sortBy eq 'rating' ? 'threadRating' : $sortBy;
if (! WebGUI::Utility::isIn($sortBy, qw/userDefined1 userDefined2 userDefined3 userDefined4 userDefined5 title lineage revisionDate creationDate karmaRank threadRating/)) {
if (! WebGUI::Utility::isIn($sortBy, qw/userDefined1 userDefined2 userDefined3 userDefined4 userDefined5 title lineage revisionDate creationDate karmaRank threadRating views replies lastPostDate/)) {
$sortBy = 'revisionDate';
}
if ($sortBy eq 'assetId' || $sortBy eq 'revisionDate') {

16
lib/WebGUI/Asset/Wobject/Navigation.pm
View file

@ -409,17 +409,23 @@ sub view {
my %rules;
$rules{endingLineageLength} = $start->getLineageLength+$self->descendantEndPoint;
$rules{assetToPedigree} = $current if (isIn("pedigree",@includedRelationships));
$rules{ancestorLimit} = $self->ancestorEndPoint;
$rules{orderByClause} = 'rpad(asset.lineage, 255, 9) desc' if ($self->reversePageLoop);
my $assets = $start->getLineage(\@includedRelationships,\%rules);
my $currentLineage = $current->lineage;
my $assetIter = $start->getLineageIterator(\@includedRelationships,\%rules);
my $currentLineage = $current->lineage;
my $lineageToSkip = "noskip";
my $absoluteDepthOfLastPage;
my $absoluteDepthOfFirstPage; # Will set on first iteration of loop, below
my %lastChildren;
my $previousPageData = undef;
my $eh = $self->session->errorHandler;
while ( my $asset = $assets->() ) {
while ( 1 ) {
my $asset;
eval { $asset = $assetIter->() };
if ( my $x = WebGUI::Error->caught('WebGUI::Error::ObjectNotFound') ) {
$self->session->log->error($x->full_message);
next;
}
last unless $asset;
# skip pages we shouldn't see
my $pageLineage = $asset->lineage;
next if ($pageLineage =~ m/^$lineageToSkip/);

25
lib/WebGUI/Asset/Wobject/Thingy.pm
View file

@ -2408,6 +2408,8 @@ sub editThingData {
my $thingId = shift || $session->form->process('thingId');
my $thingDataId = shift || $session->form->process('thingDataId') || "new";
my $thingProperties = shift || $self->getThing($thingId);
my $errors = shift;
my $resetForm = shift;
my $i18n = WebGUI::International->new($self->session, "Asset_Thingy");
my $canEditThingData = $self->canEditThingData($thingId, $thingDataId, $thingProperties);
@ -2417,7 +2419,7 @@ sub editThingData {
my (%thingData, $fields,@field_loop,$fieldValue, $privilegedGroup);
my $var = $self->get;
my $url = $self->getUrl;
my $errors = shift;
$var->{error_loop} = $errors if ($errors);
$var->{canEditThings} = $self->canEdit;
@ -2465,14 +2467,17 @@ sub editThingData {
,[$self->getId,$thingId]);
while (my %field = $fields->hash) {
my $fieldName = 'field_'.$field{fieldId};
if ($session->form->process("func") eq "editThingDataSave"){
$fieldValue = $session->form->process($fieldName,$field{fieldType},$field{defaultValue});
$fieldValue = undef;
unless ($resetForm) {
if ($session->form->process("func") eq "editThingDataSave"){
$fieldValue = $session->form->process($fieldName,$field{fieldType},$field{defaultValue});
}
else{
$fieldValue = $thingData{"field_".$field{fieldId}};
}
}
else{
$fieldValue = $thingData{"field_".$field{fieldId}};
}
$field{value} = $fieldValue || $field{defaultValue};
my $formElement .= $self->getFormElement(\%field);
$field{value} = $fieldValue || $field{defaultValue};
my $formElement .= $self->getFormPlugin(\%field,($resetForm eq ""))->toHtml;
my $hidden = ($field{status} eq "hidden" && !$self->session->var->isAdminOn);
my $value = $field{value};
@ -2546,7 +2551,7 @@ sub www_editThingDataSave {
return $self->www_viewThingData($thingId,$newThingDataId);
}
elsif ($thingProperties->{afterSave} eq "addThing") {
return $self->www_editThingData($thingId,"new");
return $self->www_editThingData($thingId,"new",undef,undef,"resetForm");
}
elsif ($thingProperties->{afterSave} =~ m/^searchOther_/x){
$otherThingId = $thingProperties->{afterSave};
@ -2556,7 +2561,7 @@ sub www_editThingDataSave {
elsif ($thingProperties->{afterSave} =~ m/^addOther_/x){
$otherThingId = $thingProperties->{afterSave};
$otherThingId =~ s/^addOther_//x;
return $self->www_editThingData($otherThingId,"new");
return $self->www_editThingData($otherThingId,"new",undef,undef,"resetForm");
}
# if afterSave is thingy default or in any other case return www_view()
else {

5
lib/WebGUI/Asset/Wobject/UserList.pm
View file

@ -353,7 +353,7 @@ sub view {
my $url = $self->session->url;
my $i18n = WebGUI::International->new($self->session, "Asset_UserList");
my (%var, @users, @profileField_loop, @profileFields);
my ($defaultPublicProfile, $defaultPublicEmail, $user, $sth, $sql, $profileField);
my ($user, $sth, $sql, $profileField);
my $currentUrlWithoutSort = $self->getUrl();
foreach ($form->param) {
@ -505,9 +505,6 @@ sub view {
$sortBy = join '.', map { $self->session->db->quoteIdentifier($_) } split /\./, $sortBy;
$sql .= " order by ".$sortBy." ".$sortOrder;
($defaultPublicProfile) = $self->session->db->quickArray("SELECT dataDefault FROM userProfileField WHERE fieldName='publicProfile'");
($defaultPublicEmail) = $self->session->db->quickArray("SELECT dataDefault FROM userProfileField WHERE fieldName='publicEmail'");
my $paginatePage = $form->param('pn') || 1;
my $currentUrl = $self->getUrl();
foreach ($form->param) {

15
lib/WebGUI/AssetLineage.pm
View file

@ -468,14 +468,10 @@ sub getLineage {
my $sql = $self->getLineageSql($relatives, $rules);
unless ($sql) {
return [];
}
my @lineage;
my %relativeCache;
my $sth = $session->db->read($sql);
ASSET: while (my ($id, $class, $parentId, $version) = $sth->array) {
my @lineage;
my %relativeCache;
my $sth = $self->session->db->read($sql);
while (my ($id, $class, $parentId, $version) = $sth->array) {
# create whatever type of object was requested
my $asset;
if ($rules->{returnObjects}) {
@ -740,7 +736,8 @@ sub getLineageSql {
}
## finish up our where clause
if (!scalar(@whereModifiers)) {
return "";
#Return valid SQL that will never select an asset.
return q|select * from asset where assetId="###---###"|;
}
$where .= ' and ('.join(" or ",@whereModifiers).')';
if (exists $rules->{whereClause} && $rules->{whereClause}) {

2
lib/WebGUI/Form/HTMLArea.pm
View file

@ -297,7 +297,7 @@ JS
$output .= '<div class="crumbTrail">'.join(" &gt; ", @crumb)."</div>\n<ul>";
my $useAssetUrls = $session->config->get("richEditorsUseAssetUrls");
my $children = $base->getLineage(["children"]);
my $children = $base->getLineageIterator(["children"]);
while ( my $child = $children->() ) {
next unless $child->canView;
$output .= '<li>';

99
lib/WebGUI/Form/Template.pm
View file

@ -78,23 +78,23 @@ If true, this will limit the list of template to only include templates that are
=cut
sub definition {
my $class = shift;
my $session = shift;
my $definition = shift || [];
my $i18n = WebGUI::International->new($session, 'Asset_Template');
push(@{$definition}, {
label=>{
defaultValue=>$i18n->get("assetName")
},
name=>{
defaultValue=>"templateId"
},
namespace=>{
defaultValue=>undef
},
onlyCommitted=>{
defaultValue=>''
},
my $class = shift;
my $session = shift;
my $definition = shift || [];
my $i18n = WebGUI::International->new($session, 'Asset_Template');
push(@{$definition}, {
label=>{
defaultValue=>$i18n->get("assetName")
},
name=>{
defaultValue=>"templateId"
},
namespace=>{
defaultValue=>undef
},
onlyCommitted=>{
defaultValue=>''
},
});
return $class->SUPER::definition($session, $definition);
}
@ -138,6 +138,54 @@ sub isDynamicCompatible {
#-------------------------------------------------------------------
=head2 getValueAsHtml ( )
Returns the tempalte name of the selected template.
=cut
sub getValueAsHtml {
my $self = shift;
$self->setOptions;
return $self->SUPER::getValueAsHtml;
}
#-------------------------------------------------------------------
=head2 setOptions
Fills the options of the select list with the appropriate templates.
=cut
sub setOptions {
my $self = shift;
my $session = $self->session;
my $userId = $session->user->userId;
my $onlyCommitted = $self->get( 'onlyCommitted' )
? q{assetData.status='approved'}
: $self->get( 'onlyCommitted' )
;
my $templateList = WebGUI::Asset::Template->getList( $session, $self->get( 'namespace' ), $onlyCommitted );
#Remove entries from template list that the user does not have permission to view.
for my $assetId ( keys %{$templateList} ) {
my $asset = eval { WebGUI::Asset->newById($session, $assetId); };
if (!Exception::Class->caught() && !$asset->canView($self->session->user->userId)) {
delete $templateList->{$assetId};
}
}
$self->set( 'options', $templateList );
return;
}
#-------------------------------------------------------------------
=head2 toHtml ( )
Renders a template picker control.
@ -145,18 +193,11 @@ Renders a template picker control.
=cut
sub toHtml {
my $self = shift;
my $onlyCommitted = $self->get('onlyCommitted') ? "assetData.status='approved'" : $self->get('onlyCommitted');
my $templateList = WebGUI::Asset::Template->getList($self->session, $self->get("namespace"), $onlyCommitted);
#Remove entries from template list that the user does not have permission to view.
for my $assetId ( keys %{$templateList} ) {
my $asset = WebGUI::Asset::Template->newById($self->session, $assetId);
if (!$asset->canView($self->session->user->userId)) {
delete $templateList->{$assetId};
}
}
$self->set("options", $templateList);
return $self->SUPER::toHtml();
my $self = shift;
$self->setOptions;
return $self->SUPER::toHtml();
}
#-------------------------------------------------------------------

25
lib/WebGUI/Form/ThingFieldsList.pm
View file

@ -36,6 +36,31 @@ The following methods are specifically available from this class. Check the supe
=cut
#-------------------------------------------------------------------
=head2 getName ( session )
Returns the human readable name of this control.
=cut
sub getName {
my ($self, $session) = @_;
return WebGUI::International->new($session, 'WebGUI')->get('user');
}
#-------------------------------------------------------------------
=head2 isDynamicCompatible ( )
Since this Form field requires a thingId to work it is not dynamic compatible.
=cut
sub isDynamicCompatible {
return 0;
}
#----------------------------------------------------------------------------
=head2 www_getThingFields ($session)

13
lib/WebGUI/Form/Username.pm
View file

@ -58,6 +58,19 @@ Defaults to the setting textBoxSize or 30 if that's not set. Specifies how big o
#-------------------------------------------------------------------
=head2 getName ( session )
Returns the human readable name of this control.
=cut
sub getName {
my ($self, $session) = @_;
return WebGUI::International->new($session, 'Form_Username')->get('username');
}
#-------------------------------------------------------------------
=head2 getValue ( [ value ] )
Retrieves a value from a form GET or POST and returns it. If the value comes back as undef, this method will return the defaultValue instead. Strip newlines/carriage returns from the value.

1
lib/WebGUI/Group.pm
View file

@ -283,6 +283,7 @@ sub clearCaches {
$stow->delete("groupObj");
$stow->delete("isInGroup");
$stow->delete("gotGroupsInGroup");
$stow->delete("gotGroupsForUser");
}
#-------------------------------------------------------------------

40
lib/WebGUI/Inbox.pm
View file

@ -119,6 +119,29 @@ sub canRead {
#-------------------------------------------------------------------
=head2 deleteMessagesForUser ( $user )
Deletes all messages for a user.
=head3 $user
A WebGUI::User object, representing the user who will have all their messages deleted.
=cut
sub deleteMessagesForUser {
my $self = shift;
my $user = shift;
my $messages = $self->getMessagesForUser($user, 1e10);
my $userId = $user->userId;
foreach my $message (@{ $messages }) {
$message->delete($userId);
}
}
#-------------------------------------------------------------------
=head2 getMessage ( messageId [, userId] )
Returns a WebGUI::Inbox::Message object.
@ -448,7 +471,7 @@ sub getMessageSql {
}
if($whereClause) {
$whereClause = qq{WHERE $whereClause};
$whereClause = qq{AND $whereClause};
}
if($limit) {
@ -473,14 +496,13 @@ SELECT
my $sql = qq{
SELECT
$select
FROM (
( SELECT messageId, subject, sentBy, dateStamp, status FROM inbox WHERE userId = '$userId' order by dateStamp desc limit $limitHalf)
UNION
( SELECT messageId, subject, sentBy, dateStamp, status FROM inbox WHERE groupId IN ( $userGroups ) order by dateStamp desc limit $limitHalf )
) AS ibox
JOIN inbox_messageState on inbox_messageState.messageId=ibox.messageId and inbox_messageState.userId='$userId' and inbox_messageState.deleted=0
LEFT JOIN users on users.userId=ibox.sentBy
LEFT JOIN userProfileData on userProfileData.userId=ibox.sentBy
FROM inbox_messageState
JOIN inbox ibox USING (messageId)
JOIN users on users.userId = ibox.sentBy
JOIN userProfileData on userProfileData.userId = ibox.sentBy
WHERE inbox_messageState.messageId = ibox.messageId
AND inbox_messageState.userId = '$userId'
AND inbox_messageState.deleted = 0
$whereClause
$sortBy
$limit

19
lib/WebGUI/Inbox/Message.pm
View file

@ -266,8 +266,7 @@ sub delete {
);
#Delete the message from the database if everyone who was sent the message has deleted it
unless ($isActive) {
$db->write("delete from inbox where messageId=?",[$messageId]);
$db->write("delete from inbox_messageState where messageId=?",[$messageId]);
$self->purge;
}
}
@ -437,6 +436,22 @@ sub new {
#-------------------------------------------------------------------
=head2 purge
Completely deletes a message from the inbox.
=cut
sub purge {
my $self = shift;
my $db = $self->session->db;
my $messageId = $self->getId;
$db->write("delete from inbox where messageId=?",[$messageId]);
$db->write("delete from inbox_messageState where messageId=?",[$messageId]);
}
#-------------------------------------------------------------------
=head2 session
Returns a reference to the current session.

59
lib/WebGUI/Mail/Send.pm
View file

@ -22,6 +22,7 @@ use Net::SMTP;
use WebGUI::Group;
use WebGUI::Macro;
use WebGUI::User;
use WebGUI::HTML;
use Encode qw(encode);
=head1 NAME
@ -84,15 +85,57 @@ sub addAttachment {
=head2 addFooter ( )
Adds the mail footer as set by the site admin to the end of this message.
Adds the mail footer as set by the site admin to the end of the first
part of this message. If the first part of the message has an HTML MIME-type,
then it will translate the footer to HTML.
If the message is empty, it will create a MIME entity part to hold it.
Macros in the footer will be evaluated.
=cut
sub addFooter {
my $self = shift;
return if $self->{_footerAdded};
my $text = "\n\n".$self->session->setting->get("mailFooter");
WebGUI::Macro::process($self->session, \$text);
$self->addText($text);
$self->{_footerAdded} = 1;
my @parts = $self->getMimeEntity->parts();
##No parts yet, add one with the footer content.
if (! $parts[0]) {
$self->addText($text);
return;
}
##Get the content of the first part, drop it from the set of parts
my $mime_body = $parts[0]->bodyhandle;
my $body_content = join '', $mime_body->as_lines;
my $mime_type;
if ($parts[0]->effective_type eq 'text/plain') {
$body_content .= $text;
my $new_part = MIME::Entity->build(
Charset => "UTF-8",
Encoding => "quoted-printable",
Type => 'text/plain',
Data => encode('utf8', $body_content),
);
shift @parts;
unshift @parts, $new_part;
$self->getMimeEntity->parts(\@parts);
}
elsif ($parts[0]->effective_type eq 'text/html') {
$text = WebGUI::HTML::format($text, 'mixed');
$body_content =~ s{(?=</body>)}{$text};
my $new_part = MIME::Entity->build(
Charset => "UTF-8",
Encoding => "quoted-printable",
Type => 'text/html',
Data => encode('utf8', $body_content),
);
shift @parts;
unshift @parts, $new_part;
$self->getMimeEntity->parts(\@parts);
}
}
#-------------------------------------------------------------------
@ -339,7 +382,13 @@ sub create {
delete $headers->{toGroup};
$message->attach(Data=>"This message was intended for ".$to." but was overridden in the config file.\n\n");
}
bless {_message=>$message, _session=>$session, _toGroup=>$headers->{toGroup}, _isInbox => $isInbox }, $class;
return bless {
_message => $message,
_session => $session,
_toGroup => $headers->{toGroup},
_isInbox => $isInbox,
_footerAdded => 0,
}, $class;
}
#-------------------------------------------------------------------
@ -462,6 +511,10 @@ sub send {
my $smtpServer = $session->setting->get("smtpServer");
my $status = 1;
if ($mail->parts <= 1) {
warn "making singlepart";
$mail->make_singlepart;
}
if ($mail->head->get("To")) {
if ($session->config->get("emailToLog")){
my $message = $mail->stringify;

1
lib/WebGUI/Operation/Cron.pm
View file

@ -308,7 +308,6 @@ sub www_runCronJob {
# Run the instance
my $error = $instance->start( 1 );
if ($error) {
$task->delete(1);
return "error";
}
$task->delete( 1 ) if ( $task->get("runOnce") );

55
lib/WebGUI/Session/Icon.pm
View file

@ -87,7 +87,8 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=cut
@ -113,7 +114,8 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=cut
@ -192,7 +194,8 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=cut
@ -218,7 +221,9 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=cut
@ -269,7 +274,9 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=cut
@ -295,7 +302,9 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=cut
@ -321,7 +330,9 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=cut
@ -347,7 +358,9 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=head3 disabled
@ -381,7 +394,9 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=cut
@ -407,7 +422,9 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=cut
@ -433,7 +450,9 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=cut
@ -459,7 +478,9 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=head3 disabled
@ -529,7 +550,9 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=cut
@ -555,7 +578,9 @@ Any URL parameters that need to be tacked on to the current URL to accomplish wh
=head3 pageURL
The URL to any page. Defaults to the current page.
The URL to any page. Defaults to the current page. If a URL is passed, the gateway URL from the site's config
file will be prepended to it.
=cut
@ -570,6 +595,4 @@ sub view {
}
1;

10
lib/WebGUI/Session/Id.pm
View file

@ -133,7 +133,7 @@ sub session {
=head2 toHex ( guid )
Returns the hex value of a guid
Returns the hex value of a guid. For all GUIDs generated by the generate method, the return value will be 32 characters long. For some manually created invalid GUIDs, it may be 33 characters long.
=head3 guid
@ -142,11 +142,13 @@ guid to convert to hex value.
=cut
sub toHex {
my $self = shift;
my $self = shift;
my $id = shift;
$id =~ tr{_-}{+/};
my $bin_id = decode_base64("$id==");
my $hex_id = sprintf('%*v02x', '', $bin_id);
$id .= 'AA';
my $bin_id = decode_base64($id);
my $hex_id = unpack("H*", $bin_id);
$hex_id =~ s/0{3,4}$//;
return $hex_id
}

15
lib/WebGUI/Shop/AddressBook.pm
View file

@ -684,7 +684,20 @@ sub www_editAddressSave {
my %addressData = $self->processAddressForm();
my @missingFields = $self->missingFields(\%addressData);
if (@missingFields) {
return $self->www_editAddress(pop @missingFields);
my $i18n = WebGUI::International->new($self->session, "Shop");
my $missingField = pop @missingFields;
my $label = $missingField eq 'label' ? $i18n->get('label')
: $missingField eq 'firstName' ? $i18n->get('firstName')
: $missingField eq 'lastName' ? $i18n->get('lastName')
: $missingField eq 'address1' ? $i18n->get('address')
: $missingField eq 'city' ? $i18n->get('city')
: $missingField eq 'state' ? $i18n->get('state')
: $missingField eq 'country' ? $i18n->get('country')
: $missingField eq 'phoneNumber' ? $i18n->get('phone number')
: '' ;
if ($label) {
return $self->www_editAddress(sprintf($i18n->get('is a required field'), $label));
}
}
if ($form->get('addressId') eq '') {
$self->addAddress(\%addressData);

4
lib/WebGUI/User.pm
View file

@ -405,8 +405,8 @@ sub delete {
$db->write("DELETE FROM userSession WHERE userId=?",[$userId]);
# remove inbox entries
$db->write("DELETE FROM inbox_messageState WHERE userId=?",[$userId]);
$db->write("DELETE FROM inbox WHERE userId=? AND (groupId IS NULL OR groupId='')",[$userId]);
my $inbox = WebGUI::Inbox->new($session);
$inbox->deleteMessagesForUser($self);
# Shop cleanups
my $sth = $session->db->prepare('select addressBookId from addressBook where userId=?');

58
lib/WebGUI/VersionTag.pm
View file

@ -186,6 +186,64 @@ sub commit {
return 2;
}
#-------------------------------------------------------------------
=head2 commitAsUser ( userId , options )
Commits the working tab. If userId is passed in, commit will be done as that user
=head3 userId
User to commit tag as
=head3 options
hash ref of options to pass in
=head4 comments
optional comments to set in the version tag
=head4 commitNow
optional boolean which, if set, will perform an immediate.
=cut
sub commitAsUser {
my $self = shift;
my $session = $self->session;
my $config = $session->config;
my $userId = shift;
my $options = shift;
my $commitNow = $options->{commitNow};
my $comments = $options->{comments};
return 0 unless (defined $userId);
#Open a new session
my $new_session = WebGUI::Session->open( $config->pathToFile );
#Set the userId in the new session
$new_session->user( { userId => $userId } );
#Clone the tag into a new version tag in the new session
my $new_tag = __PACKAGE__->new( $new_session, $self->getId );
if ( defined $new_tag ) {
$new_tag->set( { comments => $comments } );
if ($commitNow) {
$new_tag->commit;
}
else {
$new_tag->requestCommit;
}
}
#End the new session
$new_session->var->end;
$new_session->close;
return 1;
}
#-------------------------------------------------------------------

39
lib/WebGUI/Workflow/Activity/PurgeOldInboxMessages.pm
View file

@ -17,7 +17,7 @@ package WebGUI::Workflow::Activity::PurgeOldInboxMessages;
use strict;
use base 'WebGUI::Workflow::Activity';
use WebGUI::Asset;
use WebGUI::Inbox::Message;
=head1 NAME
@ -77,45 +77,32 @@ See WebGUI::Workflow::Activity::execute() for details.
=cut
sub execute {
my ($self, $nothing, $instance) = @_;
my ($self, undef, $instance) = @_;
my $session = $self->session;
my $log = $session->errorHandler;
# keep track of how much time it's taking
my $start = time;
my $limit = 2_500;
my $endTime = time() + $self->getTTL;;
my $sth
= $session->db->read(
"SELECT messageId FROM inbox WHERE completedOn IS NOT NULL AND dateStamp < ?",
[ $start - $self->get('purgeAfter') ],
);
while ( ( my $messageId ) = $sth->array ) {
$session->db->write(
"DELETE FROM inbox WHERE messageId = ?",
[ $messageId ],
[ time() - $self->get('purgeAfter') ],
);
MESSAGE: while ( ( my $messageId ) = $sth->array ) {
# give up if we're taking too long
if (time - $start > 120) {
if (time() > $endTime) {
$sth->finish;
return $self->WAITING(1);
}
}
my $message = WebGUI::Inbox::Message->new($session, $messageId);
next MESSAGE unless $message;
$message->purge;
}
# If there are more messages waiting to be purged, return WAITING
if ( $sth->rows >= $limit ) {
return $self->WAITING(1);
}
else {
return $self->COMPLETE;
}
$sth->finish;
return $self->COMPLETE;
}
1;

10
lib/WebGUI/Workflow/Activity/TrashExpiredEvents.pm
View file

@ -75,12 +75,14 @@ See WebGUI::Workflow::Activity::execute() for details.
=cut
sub execute {
my $self = shift;
my $sth = $self->session->db->read( "select assetId from Event where endDate < ?", [ time() - $self->get("trashAfter") ]);
my $self = shift;
my $session = $self->session;
my $finishTime = time() + $self->getTTL;
my $date = WebGUI::DateTime->new($session, time() - $self->get("trashAfter") );
my $sth = $session->db->read( "select Event.assetId, revisionDate from Event join assetData using (assetId, revisionDate) where endDate < ? and revisionDate = (select max(revisionDate) from assetData where assetData.assetId=Event.assetId);", [ $date->toDatabaseDate ]);
EVENT: while ( my ($id) = $sth->array ) {
my $asset = eval { WebGUI::Asset::Event->newById($self->session, $id); };
if (! Exception::Class->caught() && $asset->eventEndDate < time() - $self->trashAfter) {
my $asset = eval { WebGUI::Asset->newById($session, $id); };
if (! Exception::Class->caught()) {
$asset->trash;
}
last EVENT if time() > $finishTime;

6
lib/WebGUI/i18n/English/Asset_Collaboration.pm
View file

@ -1191,10 +1191,8 @@ submitted by a user.|,
},
'sort by description' => {
message => q|By default, all posts are displayed in a sorted order. Use this
field to choose by what property they are sorted. Multiple properties
may be selected.|,
lastUpdated => 1119070429,
message => q|By default, all posts are displayed in a sorted order. Use this field to choose by what property they are sorted.|,
lastUpdated => 1275922704,
},
'sort order description' => {

6
lib/WebGUI/i18n/English/Asset_Photo.pm
View file

@ -759,6 +759,12 @@ our $I18N = {
lastUpdated => 0,
context => q{Error when user is out of disk space.},
},
'error no image' => {
message => q{You need to select an image to upload.},
lastUpdated => 0,
context => q{Error when user tries to add photo without selecting image.},
},
'template comment add title' => {
message => q{Add comment},

11
lib/WebGUI/i18n/English/Form_ThingsFieldList.pm Normal file
View file

@ -0,0 +1,11 @@
package WebGUI::i18n::English::Form_ThingsFieldList;
use strict;
our $I18N = {
'Thingy Fields List' => {
message => q|Thingy Fields List|,
lastUpdated => 1217216725,
},
};
1;

5
lib/WebGUI/i18n/English/Form_Username.pm
View file

@ -6,6 +6,11 @@ our $I18N = {
message => q|Sorry, that account name is already in use by another member of this site.|,
lastUpdated => 1217216725
},
'username' => {
message => q|Username|,
lastUpdated => 1217216725,
context => q|Name of the form plugin|,
},
};
1;

341
t/AdSpace.t
View file

@ -35,200 +35,191 @@ $numTests += 2 * scalar keys %{ $newAdSpaceSettings };
plan tests => $numTests;
my $session = WebGUI::Test->session;
my ($adSpace, $alfred, $alfred2, $bruce, $catWoman, $villianClone, $defaultAdSpace );
my ($adSpace, $alfred, $alfred2, $bruce, $catWoman, );
my ($jokerAd, $penguinAd, $twoFaceAd);
$session->request->env->{REMOTE_ADDR} = '10.0.0.1';
$session->request->env->{HTTP_USER_AGENT} = 'Mozilla/5.0';
$session->request->env->{REMOTE_ADDR} = '10.0.0.1';
$session->request->env->{HTTP_USER_AGENT} = 'Mozilla/5.0';
$adSpace = WebGUI::AdSpace->create($session, {name=>"Alfred"});
$adSpace = WebGUI::AdSpace->create($session, {name=>"Alfred"});
isa_ok($adSpace, 'WebGUI::AdSpace');
isa_ok($adSpace, 'WebGUI::AdSpace');
WebGUI::Test->addToCleanup($adSpace);
my $data = $session->db->quickHashRef("select adSpaceId, name from adSpace where adSpaceId=?",[$adSpace->getId]);
my $data = $session->db->quickHashRef("select adSpaceId, name from adSpace where adSpaceId=?",[$adSpace->getId]);
ok(exists $data->{adSpaceId}, "create()");
is($data->{name}, $adSpace->get("name"), "get()");
is($data->{adSpaceId}, $adSpace->getId, "getId()");
ok(exists $data->{adSpaceId}, "create()");
is($data->{name}, $adSpace->get("name"), "get()");
is($data->{adSpaceId}, $adSpace->getId, "getId()");
$alfred = WebGUI::AdSpace->newByName($session, 'Alfred');
$alfred = WebGUI::AdSpace->newByName($session, 'Alfred');
WebGUI::Test->addToCleanup($alfred);
cmp_deeply($adSpace, $alfred, 'newByName returns identical object if name exists');
cmp_deeply($adSpace, $alfred, 'newByName returns identical object if name exists');
$bruce = WebGUI::AdSpace->newByName($session, 'Bruce');
is($bruce, undef, 'newByName returns undef if the name does not exist');
$bruce = WebGUI::AdSpace->newByName($session, 'Bruce');
is($bruce, undef, 'newByName returns undef if the name does not exist');
$bruce = WebGUI::AdSpace->new($session, $session->getId);
is($bruce, undef, 'new returns undef if the id does not exist');
$bruce = WebGUI::AdSpace->new($session, $session->getId);
is($bruce, undef, 'new returns undef if the id does not exist');
$alfred2 = WebGUI::AdSpace->create($session);
is($alfred2, undef, 'create returns undef unless you pass it a name');
$alfred2 = WebGUI::AdSpace->create($session);
is($alfred2, undef, 'create returns undef unless you pass it a name');
$alfred2 = WebGUI::AdSpace->create($session, {name => 'Alfred'});
is($alfred2, undef, 'create returns undef if the name already exists');
$alfred2 = WebGUI::AdSpace->create($session, {name => 'Alfred'});
is($alfred2, undef, 'create returns undef if the name already exists');
isa_ok($alfred->session, 'WebGUI::Session');
isa_ok($alfred->session, 'WebGUI::Session');
undef $alfred2;
undef $alfred2;
$alfred->set({title => "Alfred's Ad"});
is($alfred->get('title'), "Alfred's Ad", "get, set work on title");
$alfred->set({title => "Alfred's Ad"});
is($alfred->get('title'), "Alfred's Ad", "get, set work on title");
$bruce = WebGUI::AdSpace->create($session, {name => 'Bruce'});
$bruce->set({title => "Bruce's Ad"});
$bruce = WebGUI::AdSpace->create($session, {name => 'Bruce'});
$bruce->set({title => "Bruce's Ad"});
WebGUI::Test->addToCleanup($bruce);
$catWoman = WebGUI::AdSpace->create($session, {name => 'CatWoman'});
$catWoman->set({title => "CatWoman's Ad"});
$catWoman = WebGUI::AdSpace->create($session, {name => 'CatWoman'});
$catWoman->set({title => "CatWoman's Ad"});
WebGUI::Test->addToCleanup($catWoman);
my $adSpaces = WebGUI::AdSpace->getAdSpaces($session);
my $adSpaces = WebGUI::AdSpace->getAdSpaces($session);
cmp_deeply($adSpaces, [$alfred, $bruce, $catWoman], 'getAdSpaces returns all AdSpaces in alphabetical order by title');
cmp_deeply($adSpaces, [$alfred, $bruce, $catWoman], 'getAdSpaces returns all AdSpaces in alphabetical order by title');
$catWoman->set($newAdSpaceSettings);
foreach my $setting (keys %{ $newAdSpaceSettings } ) {
is($newAdSpaceSettings->{$setting}, $catWoman->get($setting),
sprintf "set and get for %s", $setting);
}
##Bare call to set doesn't change anything
$catWoman->set();
foreach my $setting (keys %{ $newAdSpaceSettings } ) {
is($newAdSpaceSettings->{$setting}, $catWoman->get($setting),
sprintf "empty call to set does not change %s", $setting);
}
$catWoman->set({title => '', name => '', description => '', });
is ($catWoman->get('title'), '', 'set can clear the title');
is ($catWoman->get('description'), '', 'set can clear the title');
is ($catWoman->get('name' ), $newAdSpaceSettings->{'name'}, 'set can not clear the name');
##Create a set of ads for general purpose testing
##The Joker and Penguin Ads go in the bruce adSpace
##The Two Face ad goes in the catWoman adSpace
$jokerAd = WebGUI::AdSpace::Ad->create($session, $bruce->getId,
{
title => 'Joker',
url => '/ha_ha',
type => 'rich',
richMedia => 'Joker',
priority => 2,
isActive => 1,
clicksBought => 0,
impressionsBought => 2,
}
);
$penguinAd = WebGUI::AdSpace::Ad->create($session, $bruce->getId,
{
title => 'Penguin',
url => '/fishy',
type => 'rich',
richMedia => 'Penguin',
priority => 1,
isActive => 1,
clicksBought => 4,
impressionsBought => 0,
}
);
$twoFaceAd = WebGUI::AdSpace::Ad->create($session, $catWoman->getId,
{
title => 'Two Face',
url => '/dent',
type => 'rich',
richMedia => 'Two Face',
priority => 500,
isActive => 1,
clicksBought => 0,
impressionsBought => 0,
}
);
##getAds
my @bruceAdTitles = map { $_->get('title') } @{ $bruce->getAds };
my @catWomanAdTitles = map { $_->get('title') } @{ $catWoman->getAds };
cmp_bag(\@bruceAdTitles, ['Joker', 'Penguin'], 'Got the set of Ads for bruce');
cmp_bag(\@catWomanAdTitles, ['Two Face'], 'Got the set of Ads for catWoman');
##countClicks
my $penguinUrl = WebGUI::AdSpace->countClick($session, $penguinAd->getId);
is($penguinUrl, $penguinAd->get('url'), 'clicking on the penguin ad returns the penguin url');
WebGUI::AdSpace->countClick($session, $penguinAd->getId);
WebGUI::AdSpace->countClick($session, $penguinAd->getId);
my $jokerUrl = WebGUI::AdSpace->countClick($session, $jokerAd->getId);
is($jokerUrl, $jokerAd->get('url'), 'clicking on the joker ad returns the joker url');
my $twoFaceUrl = WebGUI::AdSpace->countClick($session, $twoFaceAd->getId);
is($twoFaceUrl, $twoFaceAd->get('url'), 'clicking on the twoFace ad returns the twoFace url');
my ($penguinClicks) = $session->db->quickArray('select clicks from advertisement where adId=?',[$penguinAd->getId]);
is($penguinClicks, 3, 'counted penguin clicks correctly');
my ($jokerClicks) = $session->db->quickArray('select clicks from advertisement where adId=?',[$jokerAd->getId]);
is($jokerClicks, 1, 'counted joker clicks correctly');
my ($twoFaceClicks) = $session->db->quickArray('select clicks from advertisement where adId=?',[$twoFaceAd->getId]);
is($twoFaceClicks, 1, 'counted twoFace clicks correctly');
##displayImpression
my ($twoFaceImpressions, $twoFacePriority) =
$session->db->quickArray('select impressions,nextInPriority from advertisement where adId=?',[$twoFaceAd->getId]);
is($catWoman->displayImpression(1), $twoFaceAd->get('renderedAd'), 'displayImpression returns the ad');
cmp_bag(
[$twoFaceImpressions, $twoFacePriority],
[$session->db->quickArray('select impressions,nextInPriority from advertisement where adId=?',[$twoFaceAd->getId])],
'displayImpressions: impresssions and nextInPriority are not updated when dontCount=1',
);
$catWoman->displayImpression();
my $twoFaceTime = time();
is(
$session->db->quickArray('select impressions from advertisement where adId=?',[$twoFaceAd->getId]),
1, 'displayImpression added 1 impression'
);
my ($newTwoFacePriority) = $session->db->quickArray('select nextInPriority from advertisement where adId=?',[$twoFaceAd->getId]);
isnt($newTwoFacePriority, $twoFacePriority, 'displayImpression changed the nextInPriority');
cmp_ok(
abs($twoFaceTime + $twoFaceAd->get('priority') - $newTwoFacePriority),
'<=',
'2',
'displayImpression set the nextInPriority correctly'
);
my ($twoFaceIsActive) = $session->db->quickArray('select isActive from advertisement where adId=?',[$twoFaceAd->getId]);
is($twoFaceIsActive, 0, 'displayImpression deactivates an ad if enough impressions and clicks are bought');
$session->db->write('update advertisement set nextInPriority=UNIX_TIMESTAMP()+100000 where adId=?',[$jokerAd->getId]);
is($bruce->displayImpression(), $penguinAd->get('renderedAd'), 'displayImpression returns earliest by nextInPriority, penguin has 3 clicks');
WebGUI::AdSpace->countClick($session, $penguinAd->getId); ##4 clicks
is($bruce->displayImpression(), $penguinAd->get('renderedAd'), 'displayImpression returns still returns penguinAd, but deactivates it after 4 clicks');
my ($penguinActive) = $session->db->quickArray('select isActive from advertisement where adId=?',[$penguinAd->getId]);
is($penguinActive, 0, 'displayImpression deactiveated penguinAd');
is($bruce->displayImpression(), $jokerAd->get('renderedAd'), 'displayImpression now returns jokerAd');
my ($jokerActive) = $session->db->quickArray('select isActive from advertisement where adId=?',[$jokerAd->getId]);
is($jokerActive, 1, 'displayImpression did not deactiveate jokerAd after one impression');
$bruce->displayImpression();
($jokerActive) = $session->db->quickArray('select isActive from advertisement where adId=?',[$jokerAd->getId]);
is($jokerActive, 0, 'displayImpression deactivated jokerAd after two impressions');
END {
foreach my $ad_space ($adSpace, $bruce, $alfred, $alfred2, $catWoman, $defaultAdSpace ) {
if (defined $ad_space and ref $ad_space eq 'WebGUI::AdSpace') {
$ad_space->delete;
}
}
foreach my $advert ($jokerAd, $penguinAd, $villianClone, $twoFaceAd) {
if (defined $advert and ref $advert eq 'WebGUI::AdSpace::Ad') {
$advert->delete;
}
}
$catWoman->set($newAdSpaceSettings);
foreach my $setting (keys %{ $newAdSpaceSettings } ) {
is($newAdSpaceSettings->{$setting}, $catWoman->get($setting),
sprintf "set and get for %s", $setting);
}
##Bare call to set doesn't change anything
$catWoman->set();
foreach my $setting (keys %{ $newAdSpaceSettings } ) {
is($newAdSpaceSettings->{$setting}, $catWoman->get($setting),
sprintf "empty call to set does not change %s", $setting);
}
$catWoman->set({title => '', name => '', description => '', });
is ($catWoman->get('title'), '', 'set can clear the title');
is ($catWoman->get('description'), '', 'set can clear the title');
is ($catWoman->get('name' ), $newAdSpaceSettings->{'name'}, 'set can not clear the name');
##Create a set of ads for general purpose testing
##The Joker and Penguin Ads go in the bruce adSpace
##The Two Face ad goes in the catWoman adSpace
$jokerAd = WebGUI::AdSpace::Ad->create($session, $bruce->getId,
{
title => 'Joker',
url => '/ha_ha',
type => 'rich',
richMedia => 'Joker',
priority => 2,
isActive => 1,
clicksBought => 0,
impressionsBought => 2,
}
);
$penguinAd = WebGUI::AdSpace::Ad->create($session, $bruce->getId,
{
title => 'Penguin',
url => '/fishy',
type => 'rich',
richMedia => 'Penguin',
priority => 1,
isActive => 1,
clicksBought => 4,
impressionsBought => 0,
}
);
$twoFaceAd = WebGUI::AdSpace::Ad->create($session, $catWoman->getId,
{
title => 'Two Face',
url => '/dent',
type => 'rich',
richMedia => 'Two Face',
priority => 500,
isActive => 1,
clicksBought => 0,
impressionsBought => 0,
}
);
##getAds
my @bruceAdTitles = map { $_->get('title') } @{ $bruce->getAds };
my @catWomanAdTitles = map { $_->get('title') } @{ $catWoman->getAds };
cmp_bag(\@bruceAdTitles, ['Joker', 'Penguin'], 'Got the set of Ads for bruce');
cmp_bag(\@catWomanAdTitles, ['Two Face'], 'Got the set of Ads for catWoman');
##countClicks
my $penguinUrl = WebGUI::AdSpace->countClick($session, $penguinAd->getId);
is($penguinUrl, $penguinAd->get('url'), 'clicking on the penguin ad returns the penguin url');
WebGUI::AdSpace->countClick($session, $penguinAd->getId);
WebGUI::AdSpace->countClick($session, $penguinAd->getId);
my $jokerUrl = WebGUI::AdSpace->countClick($session, $jokerAd->getId);
is($jokerUrl, $jokerAd->get('url'), 'clicking on the joker ad returns the joker url');
my $twoFaceUrl = WebGUI::AdSpace->countClick($session, $twoFaceAd->getId);
is($twoFaceUrl, $twoFaceAd->get('url'), 'clicking on the twoFace ad returns the twoFace url');
my ($penguinClicks) = $session->db->quickArray('select clicks from advertisement where adId=?',[$penguinAd->getId]);
is($penguinClicks, 3, 'counted penguin clicks correctly');
my ($jokerClicks) = $session->db->quickArray('select clicks from advertisement where adId=?',[$jokerAd->getId]);
is($jokerClicks, 1, 'counted joker clicks correctly');
my ($twoFaceClicks) = $session->db->quickArray('select clicks from advertisement where adId=?',[$twoFaceAd->getId]);
is($twoFaceClicks, 1, 'counted twoFace clicks correctly');
##displayImpression
my ($twoFaceImpressions, $twoFacePriority) =
$session->db->quickArray('select impressions,nextInPriority from advertisement where adId=?',[$twoFaceAd->getId]);
is($catWoman->displayImpression(1), $twoFaceAd->get('renderedAd'), 'displayImpression returns the ad');
cmp_bag(
[$twoFaceImpressions, $twoFacePriority],
[$session->db->quickArray('select impressions,nextInPriority from advertisement where adId=?',[$twoFaceAd->getId])],
'displayImpressions: impresssions and nextInPriority are not updated when dontCount=1',
);
$catWoman->displayImpression();
my $twoFaceTime = time();
is(
$session->db->quickArray('select impressions from advertisement where adId=?',[$twoFaceAd->getId]),
1, 'displayImpression added 1 impression'
);
my ($newTwoFacePriority) = $session->db->quickArray('select nextInPriority from advertisement where adId=?',[$twoFaceAd->getId]);
isnt($newTwoFacePriority, $twoFacePriority, 'displayImpression changed the nextInPriority');
cmp_ok(
abs($twoFaceTime + $twoFaceAd->get('priority') - $newTwoFacePriority),
'<=',
'2',
'displayImpression set the nextInPriority correctly'
);
my ($twoFaceIsActive) = $session->db->quickArray('select isActive from advertisement where adId=?',[$twoFaceAd->getId]);
is($twoFaceIsActive, 0, 'displayImpression deactivates an ad if enough impressions and clicks are bought');
$session->db->write('update advertisement set nextInPriority=UNIX_TIMESTAMP()+100000 where adId=?',[$jokerAd->getId]);
is($bruce->displayImpression(), $penguinAd->get('renderedAd'), 'displayImpression returns earliest by nextInPriority, penguin has 3 clicks');
WebGUI::AdSpace->countClick($session, $penguinAd->getId); ##4 clicks
is($bruce->displayImpression(), $penguinAd->get('renderedAd'), 'displayImpression returns still returns penguinAd, but deactivates it after 4 clicks');
my ($penguinActive) = $session->db->quickArray('select isActive from advertisement where adId=?',[$penguinAd->getId]);
is($penguinActive, 0, 'displayImpression deactiveated penguinAd');
is($bruce->displayImpression(), $jokerAd->get('renderedAd'), 'displayImpression now returns jokerAd');
my ($jokerActive) = $session->db->quickArray('select isActive from advertisement where adId=?',[$jokerAd->getId]);
is($jokerActive, 1, 'displayImpression did not deactiveate jokerAd after one impression');
$bruce->displayImpression();
($jokerActive) = $session->db->quickArray('select isActive from advertisement where adId=?',[$jokerAd->getId]);
is($jokerActive, 0, 'displayImpression deactivated jokerAd after two impressions');
#vim:ft=perl

303
t/AdSpace/Ad.t
View file

@ -45,171 +45,162 @@ plan tests => $numTests;
my $session = WebGUI::Test->session;
my $ad;
my ($richAd, $textAd, $imageAd, $nonAd, $setAd);
my $adSpace;
my $imageStorage = WebGUI::Storage->create($session);
WebGUI::Test->addToCleanup($imageStorage);
$imageStorage->addFileFromScalar('foo.bmp', 'This is not really an image');
$session->request->env->{REMOTE_ADDR} = '10.0.0.1';
$session->request->env->{HTTP_USER_AGENT} = 'Mozilla/5.0';
$session->request->env->{REMOTE_ADDR} = '10.0.0.1';
$session->request->env->{HTTP_USER_AGENT} = 'Mozilla/5.0';
$adSpace = WebGUI::AdSpace->create($session, {name=>"Tim Robbins"});
$ad=WebGUI::AdSpace::Ad->create($session, $adSpace->getId, {"type" => "text"});
isa_ok($ad,"WebGUI::AdSpace::Ad");
my $adSpace = WebGUI::AdSpace->create($session, {name=>"Tim Robbins"});
WebGUI::Test->addToCleanup($adSpace);
$ad=WebGUI::AdSpace::Ad->create($session, $adSpace->getId, {"type" => "text"});
isa_ok($ad,"WebGUI::AdSpace::Ad");
isa_ok($ad->session, 'WebGUI::Session');
is($ad->get('type'), 'text', 'property set during object creation');
isa_ok($ad->session, 'WebGUI::Session');
is($ad->get('type'), 'text', 'property set during object creation');
my $ad2 = WebGUI::AdSpace::Ad->new($session, $ad->getId);
cmp_deeply($ad2, $ad, "new returns an identical object to the original what was created");
my $ad2 = WebGUI::AdSpace::Ad->new($session, $ad->getId);
cmp_deeply($ad2, $ad, "new returns an identical object to the original what was created");
undef $ad2;
undef $ad2;
my $data = $session->db->quickHashRef("select adId, adSpaceId from advertisement where adId=?",[$ad->getId]);
my $data = $session->db->quickHashRef("select adId, adSpaceId from advertisement where adId=?",[$ad->getId]);
ok(exists $data->{adId}, "create()");
is($data->{adId}, $ad->getId, "getId()");
is($data->{adSpaceId}, $ad->get('adSpaceId'), "get() adSpaceId");
ok(exists $data->{adId}, "create()");
is($data->{adId}, $ad->getId, "getId()");
is($data->{adSpaceId}, $ad->get('adSpaceId'), "get() adSpaceId");
foreach my $setting (keys %{ $newAdSettings } ) {
is($newAdSettings->{$setting}, $ad->get($setting),
sprintf "default setting for %s", $setting);
}
$richAd = WebGUI::AdSpace::Ad->create($session, $adSpace->getId);
$richAd->set({
type => 'rich',
richMedia => 'This is rich, ^@;'
});
my $renderedAd = $richAd->get('renderedAd');
my $userName = $session->user->username;
like($renderedAd, qr/This is rich, $userName/, 'Rich media ads render macros');
##In this series of tests, we'll render a text ad and then pick it apart and make
##sure that all the requisite components are in there.
$adSpace->set({
width => 102,
height => 202
});
$textAd = WebGUI::AdSpace::Ad->create($session, $adSpace->getId);
$textAd->set({
type => 'text',
borderColor => 'black',
backgroundColor => 'white',
textColor => 'blue',
title => 'This is a text ad',
adText => 'Will hack for Gooey dolls.',
});
my $renderedTextAd = $textAd->get('renderedAd');
my $textP = HTML::TokeParser->new(\$renderedTextAd);
##Outer div checks
my $token = $textP->get_tag("div");
my $style = $token->[1]{style};
like($style, qr/height:200/, 'adSpace height rendered correctly');
like($style, qr/width:100/, 'adSpace width rendered correctly');
like($style, qr/border:solid black/, 'ad borderColor rendered correctly');
##Link checks
$token = $textP->get_tag("a");
my $href = $token->[1]{onclick};
like($href, qr/op=clickAd/, 'ad link has correct operation');
my $adId = $textAd->getId;
like($href, qr/id=\Q$adId\E/, 'ad link has correct ad id');
$style = $token->[1]{style};
like($style, qr/background-color:white/, 'ad link background is white');
$token = $textP->get_tag("span");
$style = $token->[1]{style};
like($style, qr/color:blue/, 'ad title text foreground is blue');
$token = $textP->get_tag("span");
$style = $token->[1]{style};
like($style, qr/color:blue/, 'ad title text foreground is blue');
my $adText = $textP->get_trimmed_text('/span');
is($adText, $textAd->get('adText'), 'ad text is correct');
##Ditto for the image ad
$adSpace->set({
width => 250,
height => 250
});
$imageAd = WebGUI::AdSpace::Ad->create($session, $adSpace->getId);
$imageAd->set({
type => 'image',
title => 'This is an image ad',
storageId => $imageStorage->getId,
});
my $renderedImageAd = $imageAd->get('renderedAd');
my $textP = HTML::TokeParser->new(\$renderedImageAd);
##Outer div checks
my $token = $textP->get_tag("div");
my $style = $token->[1]{style};
like($style, qr/height:250/, 'adSpace height rendered correctly, image');
like($style, qr/width:250/, 'adSpace width rendered correctly, image');
##Link checks
$token = $textP->get_tag("a");
my $href = $token->[1]{onclick};
like($href, qr/op=clickAd/, 'ad link has correct operation, image');
$adId = $imageAd->getId;
like($href, qr/id=\Q$adId\E/, 'ad link has correct ad id, image');
$token = $textP->get_tag("img");
$style = $token->[1]{src};
is($style, $imageStorage->getUrl($imageStorage->getFiles->[0]), 'ad image points at correct file');
$style = $token->[1]{alt};
is($style, $imageAd->get('title'), 'ad title matches, image');
my $nonAdProperties = {
type => 'nothing',
title => 'This ad will never render',
};
$nonAd = WebGUI::AdSpace::Ad->create($session, $adSpace->getId, $nonAdProperties);
my $renderedNonAd = $nonAd->get('renderedAd');
is($renderedNonAd, undef, 'undefined ad types are not rendered');
$nonAd->delete;
$nonAd = WebGUI::AdSpace::Ad->new($session, 'nonExistantId');
is($nonAd, undef, 'requesting a non-existant id via new returns undef');
my $setAd = WebGUI::AdSpace::Ad->create($session, $adSpace->getId, {isActive => 1});
is($setAd->get('isActive'), 1, 'set isActive true during instantiation');
$setAd->set({isActive=>0});
is($setAd->get('isActive'), 0, 'set isActive false during instantiation');
$setAd->delete;
my $setAd = WebGUI::AdSpace::Ad->create($session, $adSpace->getId, {priority => 1});
is($setAd->get('priority'), 1, 'set priority=1 during instantiation');
$setAd->set({priority=>0});
is($setAd->get('priority'), 0, 'set priority=0');
$setAd->set({ title => 'myTitle', url => 'http://www.nowhere.com', adText => 'Performing a valuable service for the community'});
is($setAd->get('url'), 'http://www.nowhere.com', 'set: url');
is($setAd->get('adText'), 'Performing a valuable service for the community', 'set: adText');
$setAd->set({ url => '', adText => ''});
is($setAd->get('url'), '', 'set: clearing url');
is($setAd->get('adText'), '', 'set: clearing adText');
END {
foreach my $advertisement ($ad, $richAd, $textAd, $imageAd, $nonAd, $setAd) {
if (defined $advertisement and ref $advertisement eq 'WebGUI::AdSpace::Ad') {
$advertisement->delete;
}
}
if (defined $adSpace and ref $adSpace eq 'WebGUI::AdSpace') {
$adSpace->delete;
}
foreach my $setting (keys %{ $newAdSettings } ) {
is($newAdSettings->{$setting}, $ad->get($setting),
sprintf "default setting for %s", $setting);
}
$richAd = WebGUI::AdSpace::Ad->create($session, $adSpace->getId);
$richAd->set({
type => 'rich',
richMedia => 'This is rich, ^@;'
});
my $renderedAd = $richAd->get('renderedAd');
my $userName = $session->user->username;
like($renderedAd, qr/This is rich, $userName/, 'Rich media ads render macros');
##In this series of tests, we'll render a text ad and then pick it apart and make
##sure that all the requisite components are in there.
$adSpace->set({
width => 102,
height => 202
});
$textAd = WebGUI::AdSpace::Ad->create($session, $adSpace->getId);
$textAd->set({
type => 'text',
borderColor => 'black',
backgroundColor => 'white',
textColor => 'blue',
title => 'This is a text ad',
adText => 'Will hack for Gooey dolls.',
});
my $renderedTextAd = $textAd->get('renderedAd');
my $textP = HTML::TokeParser->new(\$renderedTextAd);
##Outer div checks
my $token = $textP->get_tag("div");
my $style = $token->[1]{style};
like($style, qr/height:200/, 'adSpace height rendered correctly');
like($style, qr/width:100/, 'adSpace width rendered correctly');
like($style, qr/border:solid black/, 'ad borderColor rendered correctly');
##Link checks
$token = $textP->get_tag("a");
my $href = $token->[1]{onclick};
like($href, qr/op=clickAd/, 'ad link has correct operation');
my $adId = $textAd->getId;
like($href, qr/id=\Q$adId\E/, 'ad link has correct ad id');
$style = $token->[1]{style};
like($style, qr/background-color:white/, 'ad link background is white');
$token = $textP->get_tag("span");
$style = $token->[1]{style};
like($style, qr/color:blue/, 'ad title text foreground is blue');
$token = $textP->get_tag("span");
$style = $token->[1]{style};
like($style, qr/color:blue/, 'ad title text foreground is blue');
my $adText = $textP->get_trimmed_text('/span');
is($adText, $textAd->get('adText'), 'ad text is correct');
##Ditto for the image ad
$adSpace->set({
width => 250,
height => 250
});
$imageAd = WebGUI::AdSpace::Ad->create($session, $adSpace->getId);
$imageAd->set({
type => 'image',
title => 'This is an image ad',
storageId => $imageStorage->getId,
});
my $renderedImageAd = $imageAd->get('renderedAd');
my $textP = HTML::TokeParser->new(\$renderedImageAd);
##Outer div checks
my $token = $textP->get_tag("div");
my $style = $token->[1]{style};
like($style, qr/height:250/, 'adSpace height rendered correctly, image');
like($style, qr/width:250/, 'adSpace width rendered correctly, image');
##Link checks
$token = $textP->get_tag("a");
my $href = $token->[1]{onclick};
like($href, qr/op=clickAd/, 'ad link has correct operation, image');
$adId = $imageAd->getId;
like($href, qr/id=\Q$adId\E/, 'ad link has correct ad id, image');
$token = $textP->get_tag("img");
$style = $token->[1]{src};
is($style, $imageStorage->getUrl($imageStorage->getFiles->[0]), 'ad image points at correct file');
$style = $token->[1]{alt};
is($style, $imageAd->get('title'), 'ad title matches, image');
my $nonAdProperties = {
type => 'nothing',
title => 'This ad will never render',
};
$nonAd = WebGUI::AdSpace::Ad->create($session, $adSpace->getId, $nonAdProperties);
my $renderedNonAd = $nonAd->get('renderedAd');
is($renderedNonAd, undef, 'undefined ad types are not rendered');
$nonAd->delete;
$nonAd = WebGUI::AdSpace::Ad->new($session, 'nonExistantId');
is($nonAd, undef, 'requesting a non-existant id via new returns undef');
my $setAd = WebGUI::AdSpace::Ad->create($session, $adSpace->getId, {isActive => 1});
is($setAd->get('isActive'), 1, 'set isActive true during instantiation');
$setAd->set({isActive=>0});
is($setAd->get('isActive'), 0, 'set isActive false during instantiation');
$setAd->delete;
my $setAd = WebGUI::AdSpace::Ad->create($session, $adSpace->getId, {priority => 1});
is($setAd->get('priority'), 1, 'set priority=1 during instantiation');
$setAd->set({priority=>0});
is($setAd->get('priority'), 0, 'set priority=0');
$setAd->set({ title => 'myTitle', url => 'http://www.nowhere.com', adText => 'Performing a valuable service for the community'});
is($setAd->get('url'), 'http://www.nowhere.com', 'set: url');
is($setAd->get('adText'), 'Performing a valuable service for the community', 'set: adText');
$setAd->set({ url => '', adText => ''});
is($setAd->get('url'), '', 'set: clearing url');
is($setAd->get('adText'), '', 'set: clearing adText');
#vim:ft=perl

38
t/Asset/AssetLineage.t
View file

@ -17,7 +17,7 @@ use WebGUI::Session;
use WebGUI::User;
use WebGUI::Asset;
use Test::More tests => 94; # increment this value for each test you create
use Test::More tests => 96; # increment this value for each test you create
use Test::Deep;
use Test::Exception;
use Data::Dumper;
@ -85,8 +85,15 @@ my $snippet2 = $folder2->addChild( {
});
$versionTag->commit;
my @snipIds;
my $lineageIds;
####################################################
#
# getLineageSql
#
####################################################
note "getLineageSql";
ok $root->getLineageSql(['ancestors']), 'valid SQL returned in an error condition';
####################################################
#
@ -94,12 +101,8 @@ my $lineageIds;
#
####################################################
my $ids = $folder->getLineage(['self']);
cmp_deeply(
[$folder->getId],
$ids,
'getLineage: get self'
);
my @snipIds;
my $lineageIds;
@snipIds = map { $_->getId } @snippets;
$lineageIds = $folder->getLineage(['descendants']);
@ -107,7 +110,7 @@ $lineageIds = $folder->getLineage(['descendants']);
cmp_deeply($lineageIds, \@snipIds, 'default order returned by getLineage is lineage order');
@snipIds = map { $_->getId } @snippets;
$ids = $folder->getLineage(['descendants']);
my $ids = $folder->getLineage(['descendants']);
cmp_bag(
\@snipIds,
$ids,
@ -143,6 +146,13 @@ cmp_bag(
'... descendants of topFolder',
);
my $empty = getListFromIterator($root->getLineageIterator(['ancestors']));
cmp_bag(
$empty,
[],
'... getting ancestors of root returns empty array'
);
####################################################
#
# getLineageIterator
@ -194,6 +204,14 @@ cmp_bag(
'getLineageIterator: descendants of topFolder',
);
my $empty = getListFromIterator($root->getLineageIterator(['ancestors']));
cmp_bag(
$empty,
[],
'... getting ancestors of root returns empty array'
);
####################################################
#
# getFirstChild

8
t/Asset/AssetMetaData.t
View file

@ -30,6 +30,7 @@ $session->user({userId => 3});
my $root = WebGUI::Asset->getRoot($session);
my $versionTag = WebGUI::VersionTag->getWorking($session);
$versionTag->set({name=>"Asset Package test"});
WebGUI::Test->addToCleanup($versionTag);
####################################################
#
@ -229,11 +230,4 @@ END {
foreach my $metaDataFieldId (keys %{ $snippet->getMetaDataFields }) {
$snippet->deleteMetaDataField($metaDataFieldId);
}
foreach my $tag($versionTag) {
if (defined $tag and ref $tag eq 'WebGUI::VersionTag') {
$tag->rollback;
}
}
}

2
t/Asset/EMSSubmissionForm.t
View file

@ -505,6 +505,4 @@ $sub1->getFormattedComments;
} [], 'no warnings from calling a bunch of functions';
#done_testing();
#print 'press return to complete test' ; <>;
#vim:ft=perl

1
t/Asset/Event.t
View file

@ -129,6 +129,7 @@ sleep 2;
my $event6a = $event6->addRevision({ title => 'Event with storage', }, undef, { skipAutoCommitWorkflows => 1, });
ok($session->id->valid($event6a->get('storageId')), 'addRevision gives the new revision a valid storageId');
isnt($event6a->get('storageId'), $event6->get('storageId'), '... and it is different from the previous revision');
my $versionTag2 = WebGUI::VersionTag->getWorking($session);
WebGUI::Test->addToCleanup($versionTag2);
$versionTag2->commit;

12
t/Asset/Event/edit.t
View file

@ -62,6 +62,7 @@ my $calendar = $node->addChild( {
my $eventUrl;
$versionTags[-1]->commit;
WebGUI::Test->addToCleanup($versionTags[-1]);
#----------------------------------------------------------------------------
# Tests
@ -167,15 +168,6 @@ $properties = {
cmp_deeply( $event->get, superhashof( $properties ), 'Events properties saved correctly' );
#----------------------------------------------------------------------------
# Cleanup
END {
for my $tag ( @versionTags ) {
$tag->rollback;
}
}
#----------------------------------------------------------------------------
# getMechLogin( baseUrl, WebGUI::User, "identifier" )
# Returns a Test::WWW::Mechanize session after logging in the given user using
@ -197,3 +189,5 @@ sub getMechLogin {
return $mech;
}
#vim:ft=perl

10
t/Asset/Event/permissions.t
View file

@ -31,6 +31,7 @@ $session->user({ userId => 3 });
my @versionTags = ();
push @versionTags, WebGUI::VersionTag->getWorking($session);
$versionTags[-1]->set({name=>"Photo Test, add Gallery, Album and 1 Photo"});
WebGUI::Test->addToCleanup($versionTags[-1]);
my $registeredUser = WebGUI::User->new( $session, "new" );
WebGUI::Test->addToCleanup($registeredUser);
@ -59,6 +60,7 @@ plan tests => 12; # Increment this number for each test you create
# Test permissions of an event added by the Admin
push @versionTags, WebGUI::VersionTag->getWorking($session);
$versionTags[-1]->set({name=>"Photo Test, add Gallery, Album and 1 Photo"});
WebGUI::Test->addToCleanup($versionTags[-1]);
$event = $calendar->addChild({
className => 'WebGUI::Asset::Event',
ownerUserId => 3,
@ -77,10 +79,4 @@ $maker->prepare( {
fail => [ '1', $registeredUser, ],
} )->run;
#----------------------------------------------------------------------------
# Cleanup
END {
for my $tag ( @versionTags ) {
$tag->rollback;
}
}
#vim:ft=perl

2
t/Asset/File/GalleryFile/Photo/00base.t
View file

@ -93,3 +93,5 @@ my $properties = $photo->get;
$photo->purge;
dies_ok { WebGUI::Asset->newById($session, $properties->{assetId}) } "Photo no longer able to be instanciated";
#vim:ft=perl

3
t/Asset/File/GalleryFile/Photo/comment.t
View file

@ -30,6 +30,7 @@ my $node = WebGUI::Asset->getImportNode($session);
my @versionTags = ();
push @versionTags, WebGUI::VersionTag->getWorking($session);
WebGUI::Test->addToCleanup($versionTags[-1]);
$versionTags[-1]->set({name=>"Photo Test, add Gallery, Album and 1 Photo"});
WebGUI::Test->addToCleanup($versionTags[-1]);
@ -327,3 +328,5 @@ TODO: {
# TODO
ok( 0, "Visitor has their IP logged in visitorIp field" );
}
#vim:ft=perl

1
t/Asset/File/GalleryFile/Photo/download.t
View file

@ -84,3 +84,4 @@ ok(
"getDownloadFileUrl croaks if resolution doesn't exist",
);
#vim:ft=perl

133
t/Asset/File/GalleryFile/Photo/edit.t
View file

@ -14,18 +14,29 @@
use FindBin;
use strict;
use lib "$FindBin::Bin/../../../../lib";
use Test::More;
use Test::Deep;
use WebGUI::Test; # Must use this before any other WebGUI modules
use WebGUI::Asset;
use WebGUI::Asset::Wobject::Gallery;
use WebGUI::Asset::Wobject::GalleryAlbum;
use WebGUI::Asset::File::GalleryFile::Photo;
use WebGUI::VersionTag;
use WebGUI::Session;
plan skip_all => 'set WEBGUI_LIVE to enable this test' unless $ENV{WEBGUI_LIVE};
#----------------------------------------------------------------------------
# Init
my $session = WebGUI::Test->session;
my $node = WebGUI::Asset->getImportNode( $session );
my @versionTags = ( WebGUI::VersionTag->getWorking( $session ) );
# Create version tag and make sure it gets cleaned up
my $versionTag = WebGUI::VersionTag->getWorking($session);
addToCleanup($versionTag);
# Override some settings to make things easier to test
# userFunctionStyleId
@ -34,36 +45,43 @@ $session->setting->set( 'userFunctionStyleId', 'PBtmpl0000000000000132' );
$session->setting->set( 'specialState', '' );
# Create a user for testing purposes
my $user = WebGUI::User->new( $session, "new" );
my $user = WebGUI::User->new( $session, "new" );
WebGUI::Test->addToCleanup($user);
$user->username( 'dufresne' . time );
my $identifier = 'ritahayworth';
my $auth = WebGUI::Operation::Auth::getInstance( $session, $user->authMethod, $user->userId );
my $identifier = 'ritahayworth';
my $auth = WebGUI::Operation::Auth::getInstance( $session, $user->authMethod, $user->userId );
$auth->saveParams( $user->userId, $user->authMethod, {
'identifier' => Digest::MD5::md5_base64( $identifier ),
});
my ( $mech );
# Get the site's base URL
my $baseUrl = 'http://' . $session->config->get('sitename')->[0];
my @addArgs = ( undef, undef, { skipAutoCommitWorkflows => 1 } );
# Create gallery and a single album
my $gallery
= $node->addChild({
className => "WebGUI::Asset::Wobject::Gallery",
title => "gallery",
groupIdAddFile => 2, # Registered Users
styleTemplateId => "PBtmpl0000000000000132", # Blank Style
styleTemplateId => "PBtmpl0000000000000132", # Blank Style
});
my $album
= $gallery->addChild({
className => "WebGUI::Asset::Wobject::GalleryAlbum",
}, @addArgs );
ownerUserId => $user->getId,
title => "album",
},
undef,
undef,
{
skipAutoCommitWorkflows => 1,
});
$versionTags[-1]->commit;
# Commit assets for testing
$versionTag->commit;
my $photo;
# Get the site's base URL
my $baseUrl = 'http://' . $session->config->get('sitename')->[0];
# Common variables
my ( $mech, $photo );
#----------------------------------------------------------------------------
@ -78,18 +96,93 @@ if ( !$mech->success ) {
plan skip_all => "Cannot load URL '$baseUrl'. Will not test.";
}
plan tests => 5; # Increment this number for each test you create
plan tests => 10; # Increment this number for each test you create
#----------------------------------------------------------------------------
# Test permissions for new photos
$mech = Test::WWW::Mechanize->new;
# Save a new photo
$mech->get( $baseUrl . $album->getUrl("func=add;class=WebGUI::Asset::File::GalleryFile::Photo") );
$mech->content_lacks( 'value="editSave"' );
#----------------------------------------------------------------------------
# Test editing existing photo
# Create single photo inside the album
$photo
= $album->addChild({
className => "WebGUI::Asset::File::GalleryFile::Photo",
ownerUserId => $user->getId,
title => "photo",
synopsis => "synopsis",
keywords => "keywords",
location => "location",
friendsOnly => 0,
},
undef,
time() - 5 # Create photo asset in the past to avoid duplicate revision dates
);
# Attach image file to photo asset
$photo->setFile( WebGUI::Test->getTestCollateralPath("rotation_test.png") );
# New values for photo properties
my %properties = (
title => 'new photo',
synopsis => 'new synopsis',
keywords => 'new keywords',
location => 'new location',
friendsOnly => '1',
);
# Log in
$mech = getMechLogin( $baseUrl, $user, $identifier );
# Request photo edit view
$mech->get_ok( $baseUrl . $photo->getUrl('func=edit'), 'Request Photo edit view' );
# Try to submit edit form
$mech->submit_form_ok({
form_name => 'photoEdit',
fields => \%properties,
},
'Submit Photo edit form' );
# Re-create instance of Photo asset
$photo = WebGUI::Asset->newByDynamicClass($session, $photo->getId);
# Check whether properties were changed correctly
cmp_deeply($photo->get, superhashof(\%properties), 'All changes applied');
#----------------------------------------------------------------------------
# Test redirect to parent's edit view using the "proceed=editParent" parameter
# Create single photo inside the album
$photo
= $album->addChild({
className => "WebGUI::Asset::File::GalleryFile::Photo",
ownerUserId => $user->getId,
},
undef,
time() - 5 # Create photo asset in the past to avoid duplicate revision dates
);
# Attach image file to photo asset
$photo->setFile( WebGUI::Test->getTestCollateralPath("rotation_test.png") );
# Request photo edit view
$mech->get_ok( $baseUrl . $photo->getUrl('func=edit;proceed=editParent'), 'Request Photo edit view with "proceed=editParent"' );
# Submit changes
$mech->submit_form( form_name => 'photoEdit' );
# Currently, a redirect using the proceed parameter will not change the URL
# nor add the proper "func" argument. We have to look at the page content instead.
$mech->content_contains( 'name="galleryAlbumEdit"', "Redirected to parent's edit view" );
#----------------------------------------------------------------------------
# Test creating a new Photo
SKIP: {
skip "File control needs to be fixed to be more 508-compliant before this can be used", 4;
$mech = getMechLogin( $baseUrl, $user, $identifier );
@ -131,14 +224,6 @@ SKIP: {
);
}
#----------------------------------------------------------------------------
# Cleanup
END {
for my $tag ( @versionTags ) {
$tag->rollback;
}
}
#----------------------------------------------------------------------------
# getMechLogin( baseUrl, WebGUI::User, "identifier" )

3
t/Asset/File/GalleryFile/Photo/exif.t
View file

@ -26,6 +26,7 @@ use Image::ExifTool qw(:Public);
my $session = WebGUI::Test->session;
my $node = WebGUI::Asset->getImportNode($session);
my $versionTag = WebGUI::VersionTag->getWorking($session);
WebGUI::Test->addToCleanup($versionTag);
$versionTag->set({name=>"Photo Test"});
WebGUI::Test->addToCleanup($versionTag);
my $gallery
@ -80,3 +81,5 @@ is_deeply(
[ sort map { $_->{tag} } @{ $var->{exifLoop} } ],
"getTemplateVars gets a loop over the tags",
);
#vim:ft=perl

3
t/Asset/File/GalleryFile/Photo/makeResolutions.t
View file

@ -29,6 +29,7 @@ my $node = WebGUI::Asset->getImportNode($session);
my @versionTags = ();
push @versionTags, WebGUI::VersionTag->getWorking($session);
$versionTags[-1]->set({name=>"Photo Test"});
WebGUI::Test->addToCleanup($versionTags[-1]);
my ($gallery, $album, $photo);
$gallery
@ -224,3 +225,5 @@ $photo->update({ filename => 'page_title.jpg' });
"makeResolutions still makes valid resolutions when invalid resolutions given",
);
}
#vim:ft=perl

2
t/Asset/File/GalleryFile/Photo/makeShortcut.t
View file

@ -132,3 +132,5 @@ cmp_deeply(
#----------------------------------------------------------------------------
# www_makeShortcut
#vim:ft=perl

9
t/Asset/File/GalleryFile/Photo/setFile.t
View file

@ -25,6 +25,7 @@ use WebGUI::Asset::File::GalleryFile::Photo;
my $session = WebGUI::Test->session;
my $node = WebGUI::Asset->getImportNode($session);
my $versionTag = WebGUI::VersionTag->getWorking($session);
WebGUI::Test->addToCleanup($versionTag);
$versionTag->set({name=>"Photo Test"});
my $gallery
= $node->addChild({
@ -70,10 +71,4 @@ ok(
"Generated resolution file exists on the filesystem",
);
#----------------------------------------------------------------------------
# Cleanup
END {
$versionTag->rollback();
}
#vim:ft=perl

2
t/Asset/File/Image/setfile.t
View file

@ -25,6 +25,7 @@ use WebGUI::Asset::File::Image;
my $session = WebGUI::Test->session;
my $node = WebGUI::Asset->getImportNode($session);
my $versionTag = WebGUI::VersionTag->getWorking($session);
WebGUI::Test->addToCleanup($versionTag);
$versionTag->set({name=>"Image Test"});
WebGUI::Test->addToCleanup($versionTag);
my $image
@ -55,3 +56,4 @@ ok(
"Thumbnail file exists on the filesystem",
);
#vim:ft=perl

3
t/Asset/File/setfile.t
View file

@ -31,6 +31,7 @@ my $file
className => "WebGUI::Asset::File",
});
$versionTag->commit;
WebGUI::Test->addToCleanup($versionTag);
#----------------------------------------------------------------------------
# Tests
@ -54,3 +55,5 @@ is_deeply(
$storage->getFiles, ['WebGUI.pm'],
"Storage location contains only the file we added",
);
#vim:ft=perl

11
t/Asset/MatrixListing.t
View file

@ -26,6 +26,7 @@ my $node = WebGUI::Asset->getImportNode($session);
my ($matrix, $matrixListing);
my $versionTag = WebGUI::VersionTag->getWorking($session);
WebGUI::Test->addToCleanup($versionTag);
$versionTag->set({name=>"Matrix Listing Test"});
$matrix = $node->addChild({className=>'WebGUI::Asset::Wobject::Matrix'});
@ -34,6 +35,7 @@ $matrixListing = $matrix->addChild({className=>'WebGUI::Asset::MatrixListing'});
# Wikis create and autocommit a version tag when a child is added. Lets get the name so we can roll it back.
my $secondVersionTag = WebGUI::VersionTag->new($session,$matrixListing->get("tagId"));
WebGUI::Test->addToCleanup($secondVersionTag);
# Test for sane object types
isa_ok($matrix, 'WebGUI::Asset::Wobject::Matrix');
@ -53,11 +55,4 @@ isa_ok($matrixListing, 'WebGUI::Asset::MatrixListing');
# local $TODO = "Tests to make later";
# ok(0, 'Lots and lots to do');
#}
END {
# Clean up after thy self
$versionTag->rollback();
$secondVersionTag->rollback();
#$thirdVersionTag->rollback();
}
#vim:ft=perl

14
t/Asset/Redirect/mech.t
View file

@ -63,6 +63,7 @@ my $redirectToAsset
snippet => $testContent,
});
$versionTags[-1]->commit;
WebGUI::Test->addToCleanup($versionTags[-1]);
#----------------------------------------------------------------------------
# Tests
@ -81,6 +82,7 @@ plan tests => 12; # Increment this number for each test you create
#----------------------------------------------------------------------------
# Test operation with a public Redirect
push @versionTags, WebGUI::VersionTag->getWorking( $session );
WebGUI::Test->addToCleanup($versionTags[-1]);
$redirect
= $node->addChild({
className => 'WebGUI::Asset::Redirect',
@ -104,6 +106,7 @@ is(
#----------------------------------------------------------------------------
# Test operation with a private Redirect through a login
push @versionTags, WebGUI::VersionTag->getWorking( $session );
WebGUI::Test->addToCleanup($versionTags[-1]);
$redirect
= $node->addChild({
className => 'WebGUI::Asset::Redirect',
@ -137,6 +140,7 @@ is(
# Test operation with a private Redirect through a login with translate
# query params
push @versionTags, WebGUI::VersionTag->getWorking( $session );
WebGUI::Test->addToCleanup($versionTags[-1]);
$redirect
= $node->addChild({
className => 'WebGUI::Asset::Redirect',
@ -170,12 +174,4 @@ TODO: {
);
};
#----------------------------------------------------------------------------
# Cleanup
END {
for my $tag ( @versionTags ) {
$tag->rollback;
}
}
#vim:ft=perl

7
t/Asset/Shortcut/000-create-delete.t
View file

@ -25,6 +25,7 @@ my $session = WebGUI::Test->session;
my $node = WebGUI::Asset->getImportNode($session);
my $versionTag = WebGUI::VersionTag->getWorking($session);
$versionTag->set({name=>"Shortcut Test"});
WebGUI::Test->addToCleanup($versionTag);
# Make a snippet to shortcut
my $snippet
@ -32,12 +33,6 @@ my $snippet
className => "WebGUI::Asset::Snippet",
});
#----------------------------------------------------------------------------
# Cleanup
END {
$versionTag->rollback();
}
#----------------------------------------------------------------------------
# Tests
plan tests => 3;

10
t/Asset/Sku/Ad.t
View file

@ -92,6 +92,7 @@ EOCD
15@500000
EOID
});
WebGUI::Test->addToCleanup($sku);
$sku->applyOptions({
adtitle => 'Sold!',
@ -106,11 +107,4 @@ is($sku->getPrice, '19.00', 'get Price');
# $sku->onCompletePurchase($item); --> not really sure how to test the rest...
# $sku->onRefund
#----------------------------------------------------------------------------
# Cleanup
END {
$sku->purge;
}
1;
#vim:ft=perl

1
t/Asset/Sku/Donation.t
View file

@ -40,6 +40,7 @@ my $sku = $root->addChild({
title=>"Test Donation",
defaultPrice => 50.00,
});
WebGUI::Test->addToCleanup($sku);
isa_ok($sku, "WebGUI::Asset::Sku::Donation");
is($sku->getPrice, 50.00, "Price should be 50.00");

12
t/Asset/Sku/ProductCollateral.t
View file

@ -41,6 +41,8 @@ plan tests => 34; # Increment this number for each test you create
#----------------------------------------------------------------------------
# put your tests here
my $root = WebGUI::Asset->getRoot($session);
my $versionTag = WebGUI::VersionTag->getWorking($session);
WebGUI::Test->addToCleanup($versionTag);
my $product = $root->addChild({
className => "WebGUI::Asset::Sku::Product",
title => "Rock Hammer",
@ -307,12 +309,4 @@ lives_ok { $product6a->getAllCollateral('variantsJSON', 'vid', $newVid); }, 'Pro
$product6->purge;
#----------------------------------------------------------------------------
# Cleanup
END {
WebGUI::VersionTag->getWorking($session)->rollback;
}
1;
#vim:ft=perl

4
t/Asset/Story.t
View file

@ -274,7 +274,7 @@ cmp_deeply(
{
title => 'Story 1',
description => 'WebGUI was originally called Web Done Right.',
'link' => re('story-1$'),
'link' => all(re('^'.$session->url->getSiteURL),re('story-1$')),
guid => re('story-1$'),
author => 'JT Smith',
date => $story->lastModified,
@ -440,3 +440,5 @@ cmp_bag(
'...asset package data has the storage locations in it'
);
#vim:ft=perl

33
t/Asset/Template/HTMLTemplateExpr.t
View file

@ -27,26 +27,22 @@ plan tests => 2 + $num_tests;
my $session = WebGUI::Test->session;
# put your tests here
my ($versionTag, $template);
my $originalParsers = $session->config->get('templateParsers');
WebGUI::Test->originalConfig('templateParsers');
my $module = use_ok('HTML::Template::Expr');
my $plugin = use_ok('WebGUI::Asset::Template::HTMLTemplateExpr');
SKIP: {
skip "HTML::Template::Expr or plugin not loaded", $num_tests+1 unless $module;
my $plugin = use_ok('WebGUI::Asset::Template::HTMLTemplateExpr');
SKIP: {
skip "HTML::Template::Expr or plugin not loaded", $num_tests unless $plugin;
$session->config->set('templateParsers', ['WebGUI::Asset::Template::HTMLTemplate', 'WebGUI::Asset::Template::HTMLTemplateExpr',] );
($versionTag, $template) = setup_assets($session);
my $templateOutput = $template->process({ "foo.bar" => "baz", "number.value" => 2 });
my $companyName = $session->config->get('companyName');
like($templateOutput, qr/NAME=$companyName/, "session variable with underscores");
like($templateOutput, qr/FOOBAR=baz/, "explicit variable with dots");
like($templateOutput, qr/EQN=4/, "explicit variable with dots in expr");
}
skip "HTML::Template::Expr or plugin not loaded", $num_tests unless $plugin;
$session->config->set('templateParsers', ['WebGUI::Asset::Template::HTMLTemplate', 'WebGUI::Asset::Template::HTMLTemplateExpr',] );
my ($versionTag, $template) = setup_assets($session);
WebGUI::Test->addToCleanup($versionTag);
my $templateOutput = $template->process({ "foo.bar" => "baz", "number.value" => 2 });
my $companyName = $session->config->get('companyName');
like($templateOutput, qr/NAME=$companyName/, "session variable with underscores");
like($templateOutput, qr/FOOBAR=baz/, "explicit variable with dots");
like($templateOutput, qr/EQN=4/, "explicit variable with dots in expr");
}
sub setup_assets {
@ -68,8 +64,3 @@ sub setup_assets {
return ($versionTag, $template);
}
END {
if (defined $versionTag and ref $versionTag eq 'WebGUI::VersionTag') {
$versionTag->rollback;
}
}

57
t/Asset/Wobject/Calendar.t
View file

@ -120,10 +120,12 @@ cmp_deeply(
my $tz = $session->datetime->getTimeZone();
my $bday = WebGUI::DateTime->new($session, WebGUI::Test->webguiBirthday);
$dt = $bday->clone->truncate(to => 'day');
my $startDt = $dt->cloneToUserTimeZone->subtract(days => 1);
my $endDt = $dt->cloneToUserTimeZone->add(days => 1);
##Simulate how windows are built in each view method
my $startDt = $bday->cloneToUserTimeZone->truncate(to => 'day')->subtract(days => 1);
my $windowStart = $startDt->clone;
my $endDt = $startDt->clone->add(days => 2);
my $windowEnd = $endDt->clone->subtract(seconds => 1);
my $inside = $windowCal->addChild({
className => 'WebGUI::Asset::Event',
@ -217,6 +219,38 @@ my $justAfterwt = $windowCal->addChild({
timeZone => $tz,
}, undef, undef, {skipAutoCommitWorkflows => 1});
my $justBefore = $windowCal->addChild({
className => 'WebGUI::Asset::Event',
title => 'Just before the window. Ending date coincident with window start',
startDate => $startDt->clone->add(days => -1)->toDatabaseDate,
endDate => $startDt->clone->add(days => -1)->toDatabaseDate,
timeZone => $tz,
}, undef, undef, {skipAutoCommitWorkflows => 1});
my $justAfter = $windowCal->addChild({
className => 'WebGUI::Asset::Event',
title => 'Just after the window. Start date coincident with window end',
startDate => $endDt->clone->add(days => 1)->toDatabaseDate,
endDate => $endDt->clone->add(days => 1)->toDatabaseDate,
timeZone => $tz,
}, undef, undef, {skipAutoCommitWorkflows => 1});
my $starting = $windowCal->addChild({
className => 'WebGUI::Asset::Event',
title => 'Inside the window, same start date',
startDate => $startDt->toDatabaseDate,
endDate => $startDt->toDatabaseDate,
timeZone => $tz,
}, undef, undef, {skipAutoCommitWorkflows => 1});
my $ending = $windowCal->addChild({
className => 'WebGUI::Asset::Event',
title => 'Inside the window, same end date',
startDate => $endDt->clone->add(days => -1)->toDatabaseDate,
endDate => $endDt->clone->add(days => -1)->toDatabaseDate,
timeZone => $tz,
}, undef, undef, {skipAutoCommitWorkflows => 1});
my $coincident = $windowCal->addChild({
className => 'WebGUI::Asset::Event',
title => 'Coincident with the window start and window end',
@ -241,6 +275,7 @@ my $coincidentHigh = $windowCal->addChild({
timeZone => $tz,
}, undef, undef, {skipAutoCommitWorkflows => 1});
# no suffix = all day event
# wt suffix = with times
# inside
# insidewt
@ -252,7 +287,10 @@ my $coincidentHigh = $windowCal->addChild({
# |----------coincidentLow------------------|
# |--------------------coincidentHigh-------|
# window: |-------------------------------|
# starting--->|
# |<---ending
# justBeforewt justAfterwt
# justBefore justAfter
# outside high
# outside low
#
@ -262,16 +300,19 @@ my $tag2 = WebGUI::VersionTag->getWorking($session);
$tag2->commit;
addToCleanup($tag2);
is(scalar @{ $windowCal->getLineage(['children'])}, 13, 'added events to the window calendar');
is(scalar @{ $windowCal->getLineage(['children'])}, 17, 'added events to the window calendar');
my @window = $windowCal->getEventsIn($startDt->toDatabase, $endDt->toDatabase);
diag "startDate: ". $windowStart->toDatabase;
diag "endDate: ". $windowEnd->toDatabase;
my @window = $windowCal->getEventsIn($windowStart->toDatabase, $windowEnd->toDatabase);
cmp_bag(
[ map { $_->get('title') } @window ],
[ map { $_->get('title') }
($inside, $insidewt,
$straddle, $straddleHighwt, $straddleLowwt, $straddlewt,
$coincident, $coincidentLow, $coincidentHigh, )
$straddle, $straddleHighwt, $straddleLowwt, $straddlewt,
$coincident, $coincidentLow, $coincidentHigh, $starting,
$ending, )
],
'..returns correct set of events'
);
@ -368,7 +409,7 @@ my $monthCal = $node->addChild({
title => 'Calendar for doing event span testing, month',
});
$allDayDt = $bday->cloneToUserTimeZone;
$allDayDt = $bday->cloneToUserTimeZone;
my $nextMonthDt = $bday->cloneToUserTimeZone->add(months => 1)->truncate( to => 'month')->add(days => 29, hours => 19);
$allDay = $monthCal->addChild({

8
t/Asset/Wobject/Carousel.t
View file

@ -26,6 +26,7 @@ my $node = WebGUI::Asset->getImportNode($session);
my $versionTag = WebGUI::VersionTag->getWorking($session);
$versionTag->set({name=>"Search Test"});
WebGUI::Test->addToCleanup($versionTag);
my $carousel = $node->addChild({className=>'WebGUI::Asset::Wobject::Carousel'});
# Test for a sane object type
@ -41,9 +42,4 @@ foreach my $newSetting (keys %{$newSettings}) {
is ($carousel->get($newSetting), $newSettings->{$newSetting}, "updated $newSetting is ".$newSettings->{$newSetting});
}
END {
# Clean up after thy self
$versionTag->rollback();
}
#vim:ft=perl

7
t/Asset/Wobject/Collaboration/getThreads.t
View file

@ -25,6 +25,7 @@ use WebGUI::Session;
# Init
my $session = WebGUI::Test->session;
my @versionTags = ( WebGUI::VersionTag->getWorking( $session ) );
WebGUI::Test->addToCleanup($versionTags[-1]);
my @addChildArgs = ( {skipAutoCommitWorkflows=>1} );
my $collab = WebGUI::Asset->getImportNode( $session )->addChild({
className => 'WebGUI::Asset::Wobject::Collaboration',
@ -206,12 +207,6 @@ $session->request->setup_param({});
$session->scratch->delete($collab->getId.'_sortBy');
$session->scratch->delete($collab->getId.'_sortDir');
#----------------------------------------------------------------------------
# Cleanup
END {
$_->rollback for @versionTags;
}
#----------------------------------------------------------------------------
# sortThreads( \&sortSub, @threads )
# Sort threads according to the given subref. Return an arrayref of hashrefs

7
t/Asset/Wobject/Collaboration/permission.t
View file

@ -35,6 +35,7 @@ WebGUI::Test->addToCleanup($user{'2'});
my $versionTag = WebGUI::VersionTag->getWorking( $session );
$versionTag->set( { name => "Collaboration Test" } );
WebGUI::Test->addToCleanup($versionTag);
my @addArgs = ( undef, undef, { skipAutoCommitWorkflows => 1 } );
@ -106,8 +107,4 @@ $maker->prepare( {
fail => [ '1', $user{"2"}, ],
} )->run;
#----------------------------------------------------------------------------
# Cleanup
END {
$versionTag->rollback;
}
#vim:ft=perl

7
t/Asset/Wobject/DataForm/moveField.t
View file

@ -35,6 +35,7 @@ my $df = WebGUI::Asset->getImportNode( $session )
mailData => 0,
fieldConfiguration => '[]',
} );
WebGUI::Test->addToCleanup($df);
# Add three fields to the DataForm
$df->createField( "one", { label => "One" } );
@ -98,10 +99,4 @@ cmp_deeply(
);
#----------------------------------------------------------------------------
# Cleanup
END {
$df->purge;
WebGUI::VersionTag->getWorking( $session )->rollback;
}
#vim:ft=perl

8
t/Asset/Wobject/DataTable.t
View file

@ -27,8 +27,6 @@ use WebGUI::Session;
my $session = WebGUI::Test->session;
my $node = WebGUI::Asset->getImportNode( $session );
my $dt;
#----------------------------------------------------------------------------
# Tests
@ -41,6 +39,7 @@ my $dt = $node->addChild( {
className => 'WebGUI::Asset::Wobject::DataTable',
} );
isa_ok( $dt, 'WebGUI::Asset::Wobject::DataTable' );
WebGUI::Test->addToCleanup($dt);
#----------------------------------------------------------------------------
# Value and variables
@ -138,9 +137,4 @@ cmp_deeply(
"getTemplateVars returns complete and correct data structure",
);
#----------------------------------------------------------------------------
# Cleanup
END {
$dt->purge;
}
#vim:ft=perl

2
t/Asset/Wobject/InOutBoard.t
View file

@ -148,7 +148,7 @@ cmp_bag(
ignore(), ignore(), ignore(), ignore(),
],
'view: returns one entry for each user, entry is correct for user with status'
);
) or diag(Dumper $templateVars->{rows_loop});
################################################################
#

10
t/Asset/Wobject/Survey/Test.t
View file

@ -23,8 +23,6 @@ my $session = WebGUI::Test->session;
# Tests
plan tests => 94;
my ( $s, $t1 );
my $tp = use_ok('TAP::Parser');
my $tpa = use_ok('TAP::Parser::Aggregator');
@ -39,8 +37,9 @@ my $import_node = WebGUI::Asset->getImportNode($session);
$session->config->set('enableSurveyExpressionEngine', 1);
# Create a Survey
$s = $import_node->addChild( { className => 'WebGUI::Asset::Wobject::Survey', } );
my $s = $import_node->addChild( { className => 'WebGUI::Asset::Wobject::Survey', } );
isa_ok( $s, 'WebGUI::Asset::Wobject::Survey' );
WebGUI::Test->addToCleanup($s);
my $tag = WebGUI::VersionTag->getWorking($session);
$tag->commit;
@ -155,7 +154,8 @@ cmp_deeply(
'surveyOrderIndex correct'
);
$t1 = WebGUI::Asset::Wobject::Survey::Test->create( $session, { assetId => $s->getId } );
my $t1 = WebGUI::Asset::Wobject::Survey::Test->create( $session, { assetId => $s->getId } );
WebGUI::Test->addToCleanup(sub {$t1->delete();});
my $spec;
# No tests
@ -729,6 +729,4 @@ END_CMP
#----------------------------------------------------------------------------
# Cleanup
END {
$s->purge() if $s;
$t1->delete() if $t1;
}

7
t/Asset/Wobject/UserList.t
View file

@ -27,6 +27,7 @@ my $node = WebGUI::Asset->getImportNode($session);
my $versionTag = WebGUI::VersionTag->getWorking($session);
$versionTag->set({name=>"UserList Test"});
WebGUI::Test->addToCleanup($versionTag);
my $userList = $node->addChild({className=>'WebGUI::Asset::Wobject::UserList'});
# Test for a sane object type
@ -45,8 +46,4 @@ foreach my $newSetting (keys %{$newUserListSettings}) {
is ($userList->get($newSetting), $newUserListSettings->{$newSetting}, "updated $newSetting is ".$newUserListSettings->{$newSetting});
}
END {
# Clean up after thy self
$versionTag->rollback();
}
#vim:ft=perl

1
t/Auth/mech.t
View file

@ -70,6 +70,7 @@ my $asset
});
$versionTag->commit;
my $assetUrl = $baseUrl . $asset->get('url');
WebGUI::Test->addToCleanup($versionTag);
#----------------------------------------------------------------------------
# Tests

3
t/Config.t
View file

@ -16,6 +16,7 @@ use WebGUI::Test;
use Test::More tests => 14; # increment this value for each test you create
use Test::Deep;
use File::Basename qw(basename);
use Cwd;
my $config = WebGUI::Test->config;
my $configFile = WebGUI::Test->file;
@ -83,5 +84,7 @@ if ($cookieName eq "") {
}
$config->set('privateArray', ['a', 'b', 'c']);
WebGUI::Test->addToCleanup(sub { $config->delete('privateArray')});
cmp_bag($config->get('privateArray'), ['a', 'b', 'c'], 'set: array, not scalar');
#vim:ft=perl

8
t/Crud.t
View file

@ -34,6 +34,7 @@ plan tests => 55; # Increment this number for each test you create
# check table structure
WebGUI::Crud->crud_createTable($session);
WebGUI::Test->addToCleanup(sub { WebGUI::Crud->crud_dropTable($session); });
my $sth = $session->db->read("describe unnamed_crud_table");
my ($col, $type) = $sth->array();
is($col, 'id', "structure: id name");
@ -139,11 +140,4 @@ is(WebGUI::Crud->crud_getTableKey($session), 'id', 'default key is id');
is(WebGUI::Crud->crud_getTableName($session), 'unnamed_crud_table', 'default table is unnamed_crud_table');
is(WebGUI::Crud->crud_getSequenceKey($session), '', 'default sequence key is blank');
#----------------------------------------------------------------------------
# Cleanup
END {
WebGUI::Crud->crud_dropTable($session);
}
#vim:ft=perl

8
t/Crud/Subclass.t
View file

@ -30,6 +30,7 @@ plan tests => 4; # Increment this number for each test you create
# Create
WebGUI::Crud::Subclass->crud_createTable($session);
WebGUI::Test->addToCleanup(sub { WebGUI::Crud::Subclass->crud_dropTable($session); });
my $record1 = WebGUI::Crud::Subclass->create($session, { field1 => 10 });
isa_ok($record1, "WebGUI::Crud", "isa WebGUI::Crud");
is($record1->get('field1'), 10, "got back correct field1 value");
@ -38,11 +39,4 @@ is($record1->get('field1'), 10, "got back correct field1 value");
is(WebGUI::Crud::Subclass->create($session, { field1 => 0 })->get('field1'), 0, 'zero does not trigger default');
is(WebGUI::Crud::Subclass->create($session, { field1 => '' })->get('field1'), 5, '..but empty string intentionally triggers default');
#----------------------------------------------------------------------------
# Cleanup
END {
WebGUI::Crud::Subclass->crud_dropTable($session);
}
#vim:ft=perl

10
t/Crud/serialize.t
View file

@ -34,6 +34,9 @@ plan tests => 10; # Increment this number for each test you create
use_ok('WebGUI::Serialize');
WebGUI::Serialize->crud_createTable($session);
WebGUI::Test->addToCleanup(sub {
WebGUI::Serialize->crud_dropTable($session);
});
my $cereal = WebGUI::Serialize->create($session);
isa_ok($cereal, 'WebGUI::Serialize');
@ -112,11 +115,4 @@ cmp_deeply(
'get: returns safe references'
);
#----------------------------------------------------------------------------
# Cleanup
END {
WebGUI::Serialize->crud_dropTable($session);
}
#vim:ft=perl

72
t/Form/Template.t Normal file
View file

@ -0,0 +1,72 @@
#-------------------------------------------------------------------
# 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
#-------------------------------------------------------------------
use FindBin;
use strict;
use lib "$FindBin::Bin/../lib";
use WebGUI::Test;
use WebGUI::Form::Template;
use WebGUI::Session;
use Test::Deep;
use Test::More; # increment this value for each test you create
my $session = WebGUI::Test->session;
plan tests => 4;
my $versionTag = WebGUI::VersionTag->create( $session );
$versionTag->setWorking;
{
my $templateList = WebGUI::Asset::Template->getList( $session, 'style' );
my $elem = WebGUI::Form::Template->new( $session, {
namespace => 'style',
onlyCommitted => 0,
} );
$elem->setOptions;
cmp_deeply(
$templateList,
$elem->get('options'),
'setOption sets correct templates'
);
my $newTemplate = WebGUI::Asset->getRoot( $session )->addChild( {
title => 'Klazam',
menuTitle => 'Klazam',
template => '',
namespace => 'style',
className => 'WebGUI::Asset::Template',
} );
$elem->setOptions;
cmp_deeply(
{ %{$templateList}, $newTemplate->getId => 'Klazam' },
$elem->get('options'),
'setOption includes uncommitted templates when onlyCommitted is false'
);
$elem->set( onlyCommitted => 1 );
$elem->setOptions;
cmp_deeply(
$templateList,
$elem->get('options'),
'setOption excludes uncommitted templates when onlyCommitted is true'
);
my ( $id, $name ) = %{ $templateList };
$elem->set( 'value', $id );
is( $elem->getValueAsHtml, $name, 'getValueAsHtml return template name' );
}
$versionTag->rollback;

18
t/Group.t
View file

@ -92,7 +92,7 @@ my @ldapTests = (
);
plan tests => (164 + (scalar(@scratchTests) * 2) + scalar(@ipTests)); # increment this value for each test you create
plan tests => (168 + (scalar(@scratchTests) * 2) + scalar(@ipTests)); # increment this value for each test you create
my $session = WebGUI::Test->session;
$session->cache->remove('myTestKey');
@ -187,7 +187,7 @@ my $ldapProps = WebGUI::Test->getSmokeLDAPProps();
$session->db->setRow('ldapLink', 'ldapLinkId', $ldapProps, $ldapProps->{ldapLinkId});
my $ldap = WebGUI::LDAPLink->new($session, $ldapProps->{ldapLinkId});
is($ldap->getValue("ldapLinkId"),$ldapProps->{ldapLinkId},'ldap link created properly');
addToCleanup($ldap);
WebGUI::Test->addToCleanup($ldap);
my @shawshank;
@ -738,8 +738,8 @@ foreach my $ipTest (@ipTests) {
note "Checking for user Visitor session leak";
$ENV{REMOTE_ADDR} = '191.168.1.1';
my $remoteSession = WebGUI::Test->newSession;
$remoteSession->request->env->{REMOTE_ADDR} = '191.168.1.1';
$remoteSession->user({userId => 1});
my $localIpGroup = WebGUI::Group->new($session, 'new');
@ -748,8 +748,8 @@ foreach my $ipTest (@ipTests) {
ok !$remoteSession->user->isInGroup($localIpGroup->getId), 'Remote Visitor fails to be in the group';
$ENV{REMOTE_ADDR} = '192.168.33.1';
my $localSession = WebGUI::Test->newSession;
$localSession->request->env->{REMOTE_ADDR} = '192.168.33.1';
WebGUI::Test->addToCleanup($localIpGroup, $remoteSession, $localSession);
$localSession->user({userId => 1});
$localIpGroup->clearCaches;
@ -773,11 +773,15 @@ $gY->addUsers([$cacheDude->userId]);
ok( $cacheDude->isInGroup($gY->getId), "Cache dude added to group Y");
ok( $cacheDude->isInGroup($gZ->getId), "Cache dude is a member of group Z by group membership");
ok((grep $_ eq $gY->getId, @{ $cacheDude->getGroupIdsRecursive } ), 'Cache dude in Y by getGroupIdsRecursive');
$gY->deleteUsers([$cacheDude->userId]);
ok(eval { $gY->deleteUsers([$cacheDude->userId]); 1; }, "Y deleteUsers on Cache dude");
ok( !$cacheDude->isInGroup($gY->getId), "Cache dude removed from group Y");
ok( !$cacheDude->isInGroup($gZ->getId), "Cache dude removed from group Z too");
ok((! grep $_ eq $gY->getId, @{ $cacheDude->getGroupIdsRecursive } ), 'Cache dude not in Y getGroupIdsRecursive');
ok((! grep $_ eq $cacheDude->userId, @{ $gY->getAllUsers() } ), 'Cache dude not in Y getAllUsers');
ok( !$cacheDude->isInGroup($gY->getId), "Cache dude removed from group Y by isInGroup");
ok( !$cacheDude->isInGroup($gZ->getId), "Cache dude removed from group Z too by isInGroup");
my $gCache = WebGUI::Group->new($session, "new");
WebGUI::Test->addToCleanup($gCache);

1
t/Help/isa.t
View file

@ -167,3 +167,4 @@ cmp_deeply(
'isa imports variables with nested loops'
);
#vim:ft=perl

14
t/Inbox.t
View file

@ -23,6 +23,7 @@ my $session = WebGUI::Test->session;
# get a user so we can test retrieving messages for a specific user
my $admin = WebGUI::User->new($session, 3);
WebGUI::Test->addToCleanup(sub { WebGUI::Test->cleanupAdminInbox; });
# Begin tests by getting an inbox object
my $inbox = WebGUI::Inbox->new($session);
@ -40,6 +41,7 @@ my $new_message = {
};
my $message = $inbox->addMessage($new_message,{ no_email => 1, });
WebGUI::Test->addToCleanup($message);
isa_ok($message, 'WebGUI::Inbox::Message');
ok(defined($message), 'addMessage returned a response');
@ -51,8 +53,8 @@ ok($messageId, 'messageId retrieved');
####################################
# get a message based on messageId #
####################################
$message = $inbox->getMessage($messageId);
ok($message->getId == $messageId, 'getMessage returns message object');
my $messageCopy = $inbox->getMessage($messageId);
ok($messageCopy->getId == $messageId, 'getMessage returns message object');
#########################################################
# get a list (arrayref) of messages for a specific user #
@ -132,10 +134,4 @@ note $messages->[0]->getStatus;
note $messages->[0]->isRead;
is($inbox->getUnreadMessageCount($admin->userId), 3, '... really tracks unread messages');
END {
$session->db->write('delete from inbox where messageId = ?', [$message->getId]);
foreach my $message (@{ $inbox->getMessagesForUser($admin, 1000) } ) {
$message->setDeleted(3);
$message->delete(3);
}
}
#vim:ft=perl

114
t/Inbox/Groups.t Normal file
View file

@ -0,0 +1,114 @@
#-------------------------------------------------------------------
# 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
#------------------------------------------------------------------
# This script tests the creation, sending, and queuing of mail messages
use strict;
use warnings;
use FindBin;
use lib "$FindBin::Bin/../lib";
use WebGUI::Test;
use WebGUI::Session;
use WebGUI::Inbox;
use WebGUI::User;
use Test::More;
plan tests => 14;
use Data::Dumper;
#----------------------------------------------------------------------------
# Create two users; add both to a group; send mail from one to the group;
# make sure the other gets it; remove the second user from the group;
# make sure the second user still has the mail message.
# Send a message from Bill to Fred.
# Concerns bug #11594
my $session = WebGUI::Test->session;
my $userFred = WebGUI::User->create($session);
WebGUI::Test->addToCleanup($userFred);
$userFred->username('fred');
$userFred->profileField('receiveInboxEmailNotifications', 0);
my $userBill = WebGUI::User->create($session);
WebGUI::Test->addToCleanup($userBill);
$userBill->username('bill');
$userBill->profileField('receiveInboxEmailNotifications', 0);
my $group = WebGUI::Group->new($session, 'new');
WebGUI::Test->addToCleanup($group);
$group->addUsers([$userFred->userId, $userBill->userId]);
my $inbox = WebGUI::Inbox->new($session);
isa_ok($inbox, 'WebGUI::Inbox');
is($inbox->getUnreadMessageCount($userFred->userId), 0, '0 messages according to getUnreadMessageCount');
my $message = $inbox->addMessage({
message => 'The quick brown dog jumped over the lazy fox',
groupId => $group->getId, # to group
sentBy => $userBill->userId,
}, {
no_email => 1,
});
ok(defined($message), 'Message sent to user in group');
WebGUI::Test->addToCleanup($message);
isa_ok($message, 'WebGUI::Inbox::Message');
my $messageId = $message->getId;
ok($messageId, 'messageId retrieved');
my $messageList;
my $message_cnt;
$messageList = $inbox->getMessagesForUser($userFred);
$message_cnt = scalar(@{$messageList});
is($message_cnt, 1, '... 1 messages according to getMessagesForUser');
is($inbox->getUnreadMessageCount($userFred->userId), 1, '... 1 messages according to getUnreadMessageCount');
ok(eval { $group->deleteUsers([ $userFred->userId ]); 1; }, "Delete user from group");
ok((! grep $_ eq $userFred->userId, @{ $group->getAllUsers() } ), '... removed from group according to getAllUsers');
ok((! grep $_ eq $group->getId, @{ $userFred->getGroupIdsRecursive } ), '... removed from group according to getGroupIdsRecursive');
# note "group->getAllUsers: " . Dumper $group->getAllUsers();
# note "getGroupIdsRecursive: " . Dumper $userFred->getGroupIdsRecursive;
# note "user->getGroups: " . Dumper $userFred->getGroups;
# eval { $userFred->session->stow->delete("gotGroupsForUser"); }; # blow the cache
# note "group->getAllUsers: " . Dumper $group->getAllUsers();
# note "getGroupIdsRecursive: " . Dumper $userFred->getGroupIdsRecursive;
# note "user->getGroups: " . Dumper $userFred->getGroups;
$messageList = $inbox->getMessagesForUser($userFred);
$message_cnt = scalar(@{$messageList});
is($message_cnt, 1, '... still 1 messages according to getMessagesForUser');
# warn $messageList->[0]->getStatus; # 'Pending'
is(eval { $messageList->[0]->getId } || '', $messageId, '... getMessagesForUser able to get message with messageId matching the message sent');
is($inbox->getUnreadMessageCount($userFred->userId), 1, '... still 1 messages according to getUnreadMessageCount');
$message->delete($userFred->userId);
is(scalar(@{ $inbox->getMessagesForUser($userFred) }), 0, 'Message deleted: User has no undeleted messages');
#----------------------------------------------------------------------------

7
t/International.t
View file

@ -28,10 +28,6 @@ plan tests => $numTests;
my $loaded = use_ok('WebGUI::International');
SKIP: {
skip 'Module was not loaded, skipping all tests', $numTests-1 unless $loaded;
my $i18n = WebGUI::International->new($session, undef, 'English');
isa_ok($i18n, 'WebGUI::International', 'object of correct type created');
@ -119,5 +115,4 @@ is(
'Language check after SetLanguage contentHandler : key from missing file return English key'
);
}
#vim:ft=perl

37
t/Macro/CartItemCount.t
View file

@ -31,36 +31,29 @@ my $macro = 'WebGUI::Macro::CartItemCount';
my $loaded = use_ok($macro);
my $cart = WebGUI::Shop::Cart->newBySession($session);
WebGUI::Test->addToCleanup($cart);
my $donation = WebGUI::Asset->getRoot($session)->addChild({
className => 'WebGUI::Asset::Sku::Donation',
title => 'Charitable donation',
defaultPrice => 10.00,
});
WebGUI::Test->addToCleanup($donation);
SKIP: {
my $output;
skip "Unable to load $macro", $numTests-1 unless $loaded;
$output = WebGUI::Macro::CartItemCount::process($session);
is ($output, '0', 'Empty cart returns 0 items');
my $output;
my $item1 = $cart->addItem($donation);
$output = WebGUI::Macro::CartItemCount::process($session);
is ($output, '1', 'Cart contains 1 item');
$output = WebGUI::Macro::CartItemCount::process($session);
is ($output, '0', 'Empty cart returns 0 items');
my $item2 = $cart->addItem($donation);
$output = WebGUI::Macro::CartItemCount::process($session);
is ($output, '2', 'Cart contains 2 items, 1 each');
my $item1 = $cart->addItem($donation);
$output = WebGUI::Macro::CartItemCount::process($session);
is ($output, '1', 'Cart contains 1 item');
$item2->setQuantity(10);
$output = WebGUI::Macro::CartItemCount::process($session);
is ($output, '11', 'Cart contains 11 items, 1 and 10');
my $item2 = $cart->addItem($donation);
$output = WebGUI::Macro::CartItemCount::process($session);
is ($output, '2', 'Cart contains 2 items, 1 each');
$item2->setQuantity(10);
$output = WebGUI::Macro::CartItemCount::process($session);
is ($output, '11', 'Cart contains 11 items, 1 and 10');
}
END {
$cart->delete;
$donation->purge;
}
#vim:ft=perl

6
t/Macro/FilePump.t
View file

@ -113,11 +113,5 @@ is(
'... check illegal file type access returns empty string'
);
#----------------------------------------------------------------------------
# Cleanup
END {
$bundle->delete;
}
#vim:ft=perl

6
t/Macro/GroupText.t
View file

@ -50,6 +50,7 @@ is($output, 'Group Not a Group was not found', 'Non-existant group returns an er
##Create a small database
$session->db->dbh->do('DROP TABLE IF EXISTS myUserTable');
$session->db->dbh->do(q!CREATE TABLE myUserTable (userId CHAR(22) binary NOT NULL default '', PRIMARY KEY(userId)) TYPE=InnoDB!);
WebGUI::Test->addToCleanup(SQL => 'DROP TABLE IF EXISTS myUserTable');
##Create a bunch of users and put them in the table.
@ -116,7 +117,4 @@ $output = join ',',
;
is($output, 'user,disti,int_disti', 'user is in all three groups');
##clean up everything
END {
$session->db->dbh->do('DROP TABLE IF EXISTS myUserTable');
}
#vim:ft=perl

8
t/Macro/H_homeLink.t
View file

@ -22,6 +22,7 @@ use Test::More; # increment this value for each test you create
my $session = WebGUI::Test->session;
my ($versionTag, $template) = addTemplate();
WebGUI::Test->addToCleanup($versionTag);
my $homeAsset = WebGUI::Asset->getDefault($session);
@ -126,9 +127,4 @@ sub simpleTextParser {
return ($url, $label);
}
END {
if (defined $versionTag and ref $versionTag eq 'WebGUI::VersionTag') {
$versionTag->rollback;
}
}
#vim:ft=perl

5
t/Macro/SQL.t
View file

@ -32,6 +32,7 @@ my $WebGUIdbLink = WebGUI::DatabaseLink->new($session, '0');
my $originalMacroAccessValue = $WebGUIdbLink->macroAccessIsAllowed();
$session->db->dbh->do('DROP TABLE IF EXISTS testTable');
WebGUI::Test->addToCleanup(SQL => 'DROP TABLE testTable');
$session->db->dbh->do('CREATE TABLE testTable (zero int(8), one int(8), two int(8), three int(8), four int(8), five int(8), six int(8), seven int(8), eight int(8), nine int(8), ten int(8), eleven int(8) ) TYPE=InnoDB');
$session->db->dbh->do('INSERT INTO testTable (zero, one, two, three, four, five, six, seven, eight, nine, ten, eleven ) VALUES(0,1,2,3,4,5,6,7,8,9,10,11)');
$session->db->dbh->do('INSERT INTO testTable (zero, one, two, three, four, five, six, seven, eight, nine, ten, eleven ) VALUES(100,101,102,103,104,105,106,107,108,109,110,111)');
@ -154,6 +155,4 @@ my $output = WebGUI::Macro::SQL::process(
);
is($output, 'zero', 'alternate linkId works');
END {
$session->db->dbh->do('DROP TABLE testTable');
}
#vim:ft=perl

118
t/Mail/Send.t
View file

@ -36,7 +36,9 @@ my $mime; # for getMimeEntity
#----------------------------------------------------------------------------
# Tests
plan tests => 17; # Increment this number for each test you create
plan tests => 33; # Increment this number for each test you create
WebGUI::Test->addToCleanup(SQL => 'delete from mailQueue');
#----------------------------------------------------------------------------
# Test create
@ -70,6 +72,8 @@ is( $mime->parts(0)->as_string =~ m/\n/, $newlines,
"addText should add newlines after 78 characters",
);
is ( $mime->parts(0)->effective_type, 'text/plain', '... sets the correct MIME type' );
#----------------------------------------------------------------------------
# Test addHtml
$mail = WebGUI::Mail::Send->create( $session );
@ -81,13 +85,13 @@ $mail->addHtml($text);
$mime = $mail->getMimeEntity;
# TODO: Test that addHtml creates an HTML wrapper if no html or body tag exists
# TODO: Test that addHtml creates a body with the right content type
# addHtml should add newlines after 78 characters
$newlines = length $text / 78;
is( $mime->parts(0)->as_string =~ m/\n/, $newlines,
"addHtml should add newlines after 78 characters",
);
is ( $mime->parts(0)->effective_type, 'text/html', '... sets the correct MIME type' );
# TODO: Test that addHtml does not create an HTML wrapper if html or body tag exist
@ -121,7 +125,54 @@ is($dbMail->getMimeEntity->head->get('List-ID'), "=?UTF-8?Q?H=C3=84ufige=20Frage
# TODO: Test that addHtml creates a body with the right content type
my $smtpServerOk;
{
my $mail = WebGUI::Mail::Send->create( $session );
ok ! $mail->{_footerAdded}, 'footerAdded flag set to false by default';
$mail->addFooter;
ok $mail->{_footerAdded}, '... flag set after calling addFooter';
my $number_of_parts;
$number_of_parts = $mail->getMimeEntity->parts;
is $number_of_parts, 1, '... added 1 part for a footer';
$mail->addFooter;
ok $mail->{_footerAdded}, '... flag still set after calling addFooter again';
$number_of_parts = $mail->getMimeEntity->parts;
is $number_of_parts, 1, '... 2nd footer not added';
}
{
my $mail = WebGUI::Mail::Send->create( $session );
$mail->addText('some text');
$mail->addFooter;
my $number_of_parts;
$number_of_parts = $mail->getMimeEntity->parts;
is $number_of_parts, 1, 'addFooter did not add any other parts';
my $body = $mail->getMimeEntity->parts(0)->as_string;
$body =~ s/\A.+?(?=some text)//s;
is $body, "some text\n\nMy Company\ninfo\@mycompany.com\nhttp://www.mycompany.com\n", '... footer appended to the first part as text';
}
{
my $mail = WebGUI::Mail::Send->create( $session );
$mail->addHtml('some <b>markup</b>');
$mail->addFooter;
my $number_of_parts;
$number_of_parts = $mail->getMimeEntity->parts;
is $number_of_parts, 1, 'addFooter did not add any other parts';
my $body = $mail->getMimeEntity->parts(0)->as_string;
$body =~ s/\A.+?<body>\n//sm;
$body =~ s!</body>.+\Z!!sm;
is $body, "some <b>markup</b>\n<br />\n<br />\nMy Company<br />\ninfo\@mycompany.com<br />\nhttp://www.mycompany.com<br />\n", '... footer appended to the first part as text';
}
{
my $mail = WebGUI::Mail::Send->create( $session );
$mail->addText('This is a textual email');
my $result = $mail->getMimeEntity->is_multipart;
ok(defined $result && $result, 'by default, we make multipart messages');
}
my $smtpServerOk = 0;
#----------------------------------------------------------------------------
# Test emailOverride
@ -326,10 +377,61 @@ cmp_bag(
'send: when the original is sent, new messages are created for each user in the group, following their user profile settings'
);
# TODO: Test the emailToLog config setting
#----------------------------------------------------------------------------
# Cleanup
END {
$session->db->write('delete from mailQueue');
SKIP: {
my $numtests = 2; # Number of tests in this block
skip "Cannot test making emails single part", $numtests unless $smtpServerOk;
WebGUI::Test::MailServer::test_smtp($session, sub {
my $cb = shift;
# Send the mail
my $mail
= WebGUI::Mail::Send->create( $session, {
to => 'norton@localhost',
} );
$mail->addText("They say it has no memory. That's where I want to live the rest of my life. A warm place with no memory.");
ok ($mail->getMimeEntity->is_multipart, 'starting with a multipart message');
$mail->send;
my $received = $cb->();
if (!$received) {
skip "Cannot making single part: No response received from smtpd", 1;
}
# Test the mail
my $parser = MIME::Parser->new();
$parser->output_to_core(1);
my $parsed_message = $parser->parse_data($received->{contents});
ok (!$parsed_message->is_multipart, 'converted to singlepart since it only has 1 part.');
});
}
SKIP: {
my $numtests = 2; # Number of tests in this block
skip "Cannot test making emails single part", $numtests unless $smtpServerOk;
WebGUI::Test::MailServer::test_smtp($session, sub {
my $cb = shift;
# Send the mail
my $mail = WebGUI::Mail::Send->create( $session, { to => 'norton@localhost', } );
$mail->addText("You know what the Mexicans say about the Pacific?");
$mail->addText("They say it has no memory. That's where I want to live the rest of my life. A warm place with no memory.");
ok ($mail->getMimeEntity->is_multipart, 'starting with a multipart message');
$mail->send;
my $received = $cb->();
if (!$received) {
skip "Cannot making single part: No response received from smtpd", $numtests;
}
# Test the mail
my $parser = MIME::Parser->new();
$parser->output_to_core(1);
my $parsed_message = $parser->parse_data($received->{contents});
ok ( $parsed_message->is_multipart, 'left as multipart since it has more than 1 part');
});
}
# TODO: Test the emailToLog config setting

1
t/Operation/Auth.t
View file

@ -54,4 +54,3 @@ unlike(
qr/<input type="hidden" name="method" value="login" /,
"Hidden form elements for login NOT displayed to valid user",
);

1
t/Pluggable.t
View file

@ -135,3 +135,4 @@ is($dumper->Dump, q|$VAR1 = {
);
};
#vim:ft=perl

5
t/ProfileCategory.t
View file

@ -33,6 +33,7 @@ my @labels = map { $_->getLabel } @{ $categories };
my %originalProperties = %{ $categories->[0]->get };
my %properties = %originalProperties;
WebGUI::Test->addToCleanup(sub { $categories->[0]->set(\%originalProperties); });
$properties{visible} = 0;
$categories->[0]->set(\%properties);
@ -41,6 +42,4 @@ my @newLabels = map { $_->getLabel } @{ $newCategories };
cmp_bag(\@newLabels, \@labels, 'Setting a category to not be visible does not change its availability through getCategories, with no options');
END {
$categories->[0]->set(\%originalProperties);
}
#vim:ft=perl

2
t/Session.t
View file

@ -56,7 +56,9 @@ my $slaveHash2 = {
};
$session->config->set('dbslave2', $slaveHash2);
WebGUI::Test->addToCleanup(sub {$session->config->delete('dbslave2');});
my $slave2 = $session->dbSlave;
isa_ok($slave2, 'WebGUI::SQL::db');
#vim:ft=perl

1
t/Session/DateTime.t
View file

@ -301,3 +301,4 @@ $session->user({user => $dude});
is($dt->epochToHuman($wgbday), '8/16/2001 9:00 pm', 'epochToHuman: constructs a default locale if the language does not provide one.');
$session->user({userId => 1});
#vim:ft=perl

7
t/Session/Icon.t
View file

@ -39,6 +39,7 @@ my $session = WebGUI::Test->session;
####################################################
my $origToolbar = $session->user->profileField('toolbar');
WebGUI::Test->addToCleanup(sub { $session->user->profileField('toolbar', $origToolbar); },);
my $toolbars = $session->url->extras('toolbar/');
my $request = $session->request;
@ -167,12 +168,6 @@ sub linkAndText {
return @parsedParams;
}
my $icon = $session->icon->drag();
END {
$session->user->profileField('toolbar', $origToolbar);
}
sub fetchTestSet {
return (
{

8
t/Session/Privilege.t
View file

@ -67,6 +67,7 @@ my $session = WebGUI::Test->session;
my $privilege = $session->privilege;
my ($versionTag, $userTemplate) = setup_assets($session);
WebGUI::Test->addToCleanup($versionTag);
isa_ok($privilege, 'WebGUI::Session::Privilege', 'session has correct object type');
@ -135,9 +136,4 @@ sub setup_assets {
return ($versionTag, $userTemplate);
}
END {
if (defined $versionTag and ref $versionTag eq 'WebGUI::VersionTag') {
$versionTag->rollback;
}
}
#vim:ft=perl

273
t/Session/Scratch.t
View file

@ -1,140 +1,133 @@
#-------------------------------------------------------------------
# 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
#-------------------------------------------------------------------
use FindBin;
use strict;
use lib "$FindBin::Bin/../lib";
use WebGUI::Test;
use WebGUI::Session;
use Test::More tests => 62; # increment this value for each test you create
use Test::Deep;
my $session = WebGUI::Test->session;
my $scratch = $session->scratch;
my $maxCount = 10;
$scratch->deleteAll();
for (my $count = 1; $count <= $maxCount; $count++){
$scratch->set("Test$count",$count);
}
for (my $count = 1; $count <= $maxCount; $count++){
is($scratch->get("Test$count"), $count, "Passed set/get $count");
}
is($scratch->delete("nonExistantVariable"), undef, 'delete returns value if deleted, otherwise undef');
is($scratch->delete("Test1"), 1, 'delete returns number deleted');
is($scratch->delete(), undef, 'delete without name of variable to delete returns undef');
is($scratch->get("Test1"), undef, "delete()");
$scratch->deleteAll;
is($scratch->get("Test2"), undef, "deleteAll()");
my $testScratchSession = $scratch->session();
is($testScratchSession, $session, "session()");
##Build some variables to test database persistency
for (my $count = 1; $count <= $maxCount; $count++){
$scratch->set("dBase$count",$count);
my ($setValue) = $session->db->quickArray("select value from userSessionScratch where sessionId=? and name=?",[$session->getId, "dBase$count"]);
is($setValue, $count, "database store for set on $count");
}
##Creating a new session with the previous session's Id should clone the scratch data
my $newSession = WebGUI::Session->open(WebGUI::Test->file, undef, $session->getId);
is($newSession->getId, $session->getId, "Successful session duplication");
for (my $count = 1; $count <= $maxCount; $count++){
is($newSession->scratch->get("dBase$count"), $count, "Passed set/get $count");
}
$scratch->set("dBase5", 15);
my ($changedValue) = $session->db->quickArray("select value from userSessionScratch where sessionId=? and name=?",[$session->getId, "dBase5"]);
is($changedValue, 15, "changing stored scratch value");
is($scratch->get("dBase5"), 15, "checking cached scratch value");
$newSession->scratch->deleteAll;
$newSession->close;
is($scratch->set('retVal',2), 1, 'set returns number of rows affected');
is($scratch->set(), undef, 'set returns undef unless it gets a name');
is($scratch->set('','value'), undef, 'set returns undef unless it gets a name even if there is a value');
############################################
#
# Multi-session deleting
#
############################################
my @sessionBank = map { WebGUI::Session->open(WebGUI::Test->file) } 0..3;
##Set variables to be deleted by name
foreach my $i (0..3) {
$sessionBank[$i]->scratch->set('deletableName', $i);
}
##Set variables to be deleted by name and value
$sessionBank[0]->scratch->set('deletableValue', 'a');
$sessionBank[1]->scratch->set('deletableValue', 'a');
$sessionBank[2]->scratch->set('deletableValue', 'b');
$sessionBank[2]->scratch->set('falseValue', '');
$sessionBank[3]->scratch->set('deletableValue', 'c');
$sessionBank[3]->scratch->set('falseValue', '0');
is($scratch->deleteName(), undef, 'deleteName without name of variable to delete returns undef');
is($sessionBank[2]->scratch->deleteName("deletableName"), 4, 'deleteName returns number of elements deleted');
is($sessionBank[2]->scratch->get("deletableName"), undef, 'deleteName clears session cached in the object that calls it');
is($sessionBank[1]->scratch->get('deletableName'), 1, "deleteName does not change session cached vriables");
my ($entries) = $session->db->quickArray("select count(name) from userSessionScratch where name=?",['deletableName']);
is($entries, 0, "deleteName deletes entries in the database");
is($sessionBank[1]->scratch->deleteNameByValue('deletableValue', 'a'), 2, 'deleteNameByValue deleted two rows');
($entries) = $session->db->quickArray("select count(name) from userSessionScratch where name=?",['deletableValue']);
is($entries, 2, "deleteNameByValue deleted entries in the database");
is($sessionBank[1]->scratch->get('deletableValue'), undef, 'deleteNameByValue removes session cache in object that called it...');
is($sessionBank[0]->scratch->get('deletableValue'), 'a', 'but not in any other object whose database entry was cleared');
cmp_bag($session->db->buildArrayRef('select value from userSessionScratch where name=?',['deletableValue']), ['b', 'c'], 'deleteNameByValue values that were not deleted');
is($sessionBank[2]->scratch->deleteNameByValue('deletableValue', 'c'), 1, 'deleteNameByValue deleted one row');
is($sessionBank[0]->scratch->deleteNameByValue('',35), undef, 'deleteNameByValue requires a NAME');
is($sessionBank[0]->scratch->deleteNameByValue('scratch'), undef, 'deleteNameByValue requires a value');
is($sessionBank[0]->scratch->deleteNameByValue('',''), undef, 'deleteNameByValue require a NAME and a VALUE');
is($sessionBank[3]->scratch->deleteNameByValue('falseValue','0'), 1, 'deleteNameByValue will delete values that are false (0)');
is($sessionBank[2]->scratch->deleteNameByValue('falseValue',''), 1, "deleteNameByValue will delete values that are false ('')");
$scratch->setLanguageOverride('English');
is($scratch->getLanguageOverride, 'English', 'session scratch language is not correctly set');
$scratch->removeLanguageOverride;
is($scratch->getLanguageOverride, undef, 'The session scratch variable language is not removed');
$scratch->setLanguageOverride('myimmaginarylanguagethatisnotinstalled');
is($scratch->getLanguageOverride, undef, 'A non-existing language is set');
$scratch->setLanguageOverride('English');
$scratch->setLanguageOverride();
is($scratch->getLanguageOverride, 'English', 'A empty string is falsely recognised as a language');
END {
$session->scratch->deleteAll;
foreach my $wgSess ($newSession, @sessionBank) {
if (defined $wgSess and ref $wgSess eq 'WebGUI::Session') {
note "Closing session";
$wgSess->scratch->deleteAll;
$wgSess->var->end;
$wgSess->close;
}
}
}
#-------------------------------------------------------------------
# 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
#-------------------------------------------------------------------
use FindBin;
use strict;
use lib "$FindBin::Bin/../lib";
use WebGUI::Test;
use WebGUI::Session;
use Test::More tests => 62; # increment this value for each test you create
use Test::Deep;
my $session = WebGUI::Test->session;
my $scratch = $session->scratch;
my $maxCount = 10;
$scratch->deleteAll();
for (my $count = 1; $count <= $maxCount; $count++){
$scratch->set("Test$count",$count);
}
for (my $count = 1; $count <= $maxCount; $count++){
is($scratch->get("Test$count"), $count, "Passed set/get $count");
}
is($scratch->delete("nonExistantVariable"), undef, 'delete returns value if deleted, otherwise undef');
is($scratch->delete("Test1"), 1, 'delete returns number deleted');
is($scratch->delete(), undef, 'delete without name of variable to delete returns undef');
is($scratch->get("Test1"), undef, "delete()");
$scratch->deleteAll;
is($scratch->get("Test2"), undef, "deleteAll()");
my $testScratchSession = $scratch->session();
is($testScratchSession, $session, "session()");
##Build some variables to test database persistency
for (my $count = 1; $count <= $maxCount; $count++){
$scratch->set("dBase$count",$count);
my ($setValue) = $session->db->quickArray("select value from userSessionScratch where sessionId=? and name=?",[$session->getId, "dBase$count"]);
is($setValue, $count, "database store for set on $count");
}
##Creating a new session with the previous session's Id should clone the scratch data
my $newSession = WebGUI::Session->open(WebGUI::Test->file, undef, $session->getId);
WebGUI::Test->addToCleanup($newSession);
is($newSession->getId, $session->getId, "Successful session duplication");
for (my $count = 1; $count <= $maxCount; $count++){
is($newSession->scratch->get("dBase$count"), $count, "Passed set/get $count");
}
$scratch->set("dBase5", 15);
my ($changedValue) = $session->db->quickArray("select value from userSessionScratch where sessionId=? and name=?",[$session->getId, "dBase5"]);
is($changedValue, 15, "changing stored scratch value");
is($scratch->get("dBase5"), 15, "checking cached scratch value");
$newSession->scratch->deleteAll;
$newSession->close;
is($scratch->set('retVal',2), 1, 'set returns number of rows affected');
is($scratch->set(), undef, 'set returns undef unless it gets a name');
is($scratch->set('','value'), undef, 'set returns undef unless it gets a name even if there is a value');
############################################
#
# Multi-session deleting
#
############################################
my @sessionBank = map { WebGUI::Session->open(WebGUI::Test->file) } 0..3;
WebGUI::Test->addToCleanup(@sessionBank);
##Set variables to be deleted by name
foreach my $i (0..3) {
$sessionBank[$i]->scratch->set('deletableName', $i);
}
##Set variables to be deleted by name and value
$sessionBank[0]->scratch->set('deletableValue', 'a');
$sessionBank[1]->scratch->set('deletableValue', 'a');
$sessionBank[2]->scratch->set('deletableValue', 'b');
$sessionBank[2]->scratch->set('falseValue', '');
$sessionBank[3]->scratch->set('deletableValue', 'c');
$sessionBank[3]->scratch->set('falseValue', '0');
is($scratch->deleteName(), undef, 'deleteName without name of variable to delete returns undef');
is($sessionBank[2]->scratch->deleteName("deletableName"), 4, 'deleteName returns number of elements deleted');
is($sessionBank[2]->scratch->get("deletableName"), undef, 'deleteName clears session cached in the object that calls it');
is($sessionBank[1]->scratch->get('deletableName'), 1, "deleteName does not change session cached vriables");
my ($entries) = $session->db->quickArray("select count(name) from userSessionScratch where name=?",['deletableName']);
is($entries, 0, "deleteName deletes entries in the database");
is($sessionBank[1]->scratch->deleteNameByValue('deletableValue', 'a'), 2, 'deleteNameByValue deleted two rows');
($entries) = $session->db->quickArray("select count(name) from userSessionScratch where name=?",['deletableValue']);
is($entries, 2, "deleteNameByValue deleted entries in the database");
is($sessionBank[1]->scratch->get('deletableValue'), undef, 'deleteNameByValue removes session cache in object that called it...');
is($sessionBank[0]->scratch->get('deletableValue'), 'a', 'but not in any other object whose database entry was cleared');
cmp_bag($session->db->buildArrayRef('select value from userSessionScratch where name=?',['deletableValue']), ['b', 'c'], 'deleteNameByValue values that were not deleted');
is($sessionBank[2]->scratch->deleteNameByValue('deletableValue', 'c'), 1, 'deleteNameByValue deleted one row');
is($sessionBank[0]->scratch->deleteNameByValue('',35), undef, 'deleteNameByValue requires a NAME');
is($sessionBank[0]->scratch->deleteNameByValue('scratch'), undef, 'deleteNameByValue requires a value');
is($sessionBank[0]->scratch->deleteNameByValue('',''), undef, 'deleteNameByValue require a NAME and a VALUE');
is($sessionBank[3]->scratch->deleteNameByValue('falseValue','0'), 1, 'deleteNameByValue will delete values that are false (0)');
is($sessionBank[2]->scratch->deleteNameByValue('falseValue',''), 1, "deleteNameByValue will delete values that are false ('')");
$scratch->setLanguageOverride('English');
is($scratch->getLanguageOverride, 'English', 'session scratch language is not correctly set');
$scratch->removeLanguageOverride;
is($scratch->getLanguageOverride, undef, 'The session scratch variable language is not removed');
$scratch->setLanguageOverride('myimmaginarylanguagethatisnotinstalled');
is($scratch->getLanguageOverride, undef, 'A non-existing language is set');
$scratch->setLanguageOverride('English');
$scratch->setLanguageOverride();
is($scratch->getLanguageOverride, 'English', 'A empty string is falsely recognised as a language');
#vim:ft=perl

1
t/Session/Stow.t
View file

@ -80,3 +80,4 @@ is( $session->stow->get( 'possibilities', { noclone => 1 } ), $arr,
"With noclone returns same reference"
);
#vim:ft=perl

1
t/Session/Style.t
View file

@ -178,6 +178,7 @@ is($macroOutput, 1, 'generateAdditionalHeadTags: process a macro');
####################################################
my ($versionTag, $templates, $article, $snippet) = setup_assets($session);
WebGUI::Test->addToCleanup($versionTag);
$style->sent(0);
is($style->sent, 0, 'process: setup sent to 0');

Some files were not shown because too many files have changed in this diff Show more