merge to 10219
This commit is contained in:
Colin Kuskie
parent
ae28bf79c8
commit
4c1307e3d0
194 changed files with 8203 additions and 2134 deletions
|
|
@ -810,10 +810,6 @@ END {
|
|||
if defined $origExtras;
|
||||
$session->config->set( 'uploadsURL', $origUploads)
|
||||
if defined $origUploads;
|
||||
$session->setting->set('urlExtension', $origUrlExtension)
|
||||
if defined $origUrlExtension;
|
||||
$session->setting->set('notFoundPage', $origNotFoundPage)
|
||||
if defined $origNotFoundPage;
|
||||
if (defined $originalAssetOverrides) {
|
||||
$session->config->set('assets', $originalAssetOverrides);
|
||||
}
|
||||
|
|
|
|||
|
|
@ -770,6 +770,10 @@ $exportPath->rmtree;
|
|||
);
|
||||
|
||||
my $numberCreatedAll = scalar @createdFiles;
|
||||
push @createdFiles,
|
||||
[ qw/ the_latest_news the_latest_news.atom /],
|
||||
[ qw/ the_latest_news the_latest_news.rss /],
|
||||
;
|
||||
|
||||
# turn them into Path::Class::File objects
|
||||
my @shouldExist = map { Path::Class::File->new($exportPath, @{$_})->absolute->stringify } @createdFiles;
|
||||
|
|
@ -870,6 +874,11 @@ $gettingStarted->update({ isExportable => 0 });
|
|||
[ qw/ documentation free-documentation index.html /],
|
||||
);
|
||||
my $numberCreated = scalar @createdFiles;
|
||||
push @createdFiles,
|
||||
[ qw/ the_latest_news the_latest_news.atom /],
|
||||
[ qw/ the_latest_news the_latest_news.rss /],
|
||||
;
|
||||
|
||||
@shouldExist = map { Path::Class::File->new($exportPath, @{$_})->absolute->stringify } @createdFiles;
|
||||
|
||||
$exportPath->recurse( callback => sub { my $o = shift; $o->is_dir ? return : push @doExist, $o->absolute->stringify } );
|
||||
|
|
|
|||
|
|
@ -195,7 +195,6 @@ cmp_deeply(
|
|||
#
|
||||
####################################################
|
||||
|
||||
my $origMetaEnabled = $session->setting->get("metaDataEnabled");
|
||||
$session->setting->set("metaDataEnabled", 1);
|
||||
|
||||
# add another field for comparison
|
||||
|
|
@ -236,6 +235,5 @@ END {
|
|||
$tag->rollback;
|
||||
}
|
||||
}
|
||||
$session->setting->set("metaDataEnabled", $origMetaEnabled);
|
||||
|
||||
}
|
||||
|
|
|
|||
|
|
@ -30,11 +30,8 @@ my $node = WebGUI::Asset->getImportNode( $session );
|
|||
my @versionTags = ( WebGUI::VersionTag->getWorking( $session ) );
|
||||
|
||||
# Override some settings to make things easier to test
|
||||
my %oldSettings;
|
||||
# userFunctionStyleId
|
||||
$oldSettings{ userFunctionStyleId } = $session->setting->get( 'userFunctionStyleId' );
|
||||
$session->setting->set( 'userFunctionStyleId', 'PBtmpl0000000000000132' );
|
||||
$oldSettings{ defaultVersionTagWorkflow } = $session->setting->get( 'defaultVersionTagWorkflow' );
|
||||
$session->setting->set( 'defaultVersionTagWorkflow', 'pbworkflow000000000003' );
|
||||
|
||||
# Create a user for testing purposes
|
||||
|
|
@ -173,10 +170,6 @@ END {
|
|||
}
|
||||
|
||||
$user->delete;
|
||||
|
||||
for my $key ( keys %oldSettings ) {
|
||||
$session->setting->set( $key, $oldSettings{ $key } );
|
||||
}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -27,12 +27,9 @@ my $node = WebGUI::Asset->getImportNode( $session );
|
|||
my @versionTags = ( WebGUI::VersionTag->getWorking( $session ) );
|
||||
|
||||
# Override some settings to make things easier to test
|
||||
my %oldSettings;
|
||||
# userFunctionStyleId
|
||||
$oldSettings{ userFunctionStyleId } = $session->setting->get( 'userFunctionStyleId' );
|
||||
$session->setting->set( 'userFunctionStyleId', 'PBtmpl0000000000000132' );
|
||||
# specialState
|
||||
$oldSettings{ specialState } = $session->setting->get( 'specialState' );
|
||||
$session->setting->set( 'specialState', '' );
|
||||
|
||||
# Create a user for testing purposes
|
||||
|
|
@ -141,9 +138,6 @@ END {
|
|||
|
||||
$user->delete;
|
||||
|
||||
for my $key ( keys %oldSettings ) {
|
||||
$session->setting->set( $key, $oldSettings{ $key } );
|
||||
}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -20,6 +20,7 @@ BEGIN {
|
|||
$mocker->fake_new('WebGUI::Form::Image');
|
||||
}
|
||||
|
||||
use File::Copy;
|
||||
use WebGUI::Test;
|
||||
use WebGUI::Session;
|
||||
use WebGUI::Image;
|
||||
|
|
@ -29,23 +30,23 @@ use WebGUI::Form::File;
|
|||
|
||||
use Test::More; # increment this value for each test you create
|
||||
use Test::Deep;
|
||||
plan tests => 7;
|
||||
plan tests => 11;
|
||||
|
||||
my $session = WebGUI::Test->session;
|
||||
|
||||
my $square = WebGUI::Image->new($session, 100, 100);
|
||||
$square->setBackgroundColor('#0000FF');
|
||||
my $rectangle = WebGUI::Image->new($session, 100, 200);
|
||||
$rectangle->setBackgroundColor('#0000FF');
|
||||
|
||||
##Create a storage location
|
||||
my $storage = WebGUI::Storage->create($session);
|
||||
|
||||
##Save the image to the location
|
||||
$square->saveToStorageLocation($storage, 'square.png');
|
||||
$rectangle->saveToStorageLocation($storage, 'blue.png');
|
||||
|
||||
##Do a file existance check.
|
||||
|
||||
ok((-e $storage->getPath and -d $storage->getPath), 'Storage location created and is a directory');
|
||||
cmp_bag($storage->getFiles, ['square.png'], 'Only 1 file in storage with correct name');
|
||||
cmp_bag($storage->getFiles, ['blue.png'], 'Only 1 file in storage with correct name');
|
||||
|
||||
##Initialize an Image Asset with that filename and storage location
|
||||
|
||||
|
|
@ -68,9 +69,29 @@ is($asset->get('storageId'), $asset->getStorageLocation->getId, 'Image Asset sto
|
|||
|
||||
$asset->update({
|
||||
storageId => $storage->getId,
|
||||
filename => 'square.png',
|
||||
filename => 'blue.png',
|
||||
});
|
||||
|
||||
my $filename = $asset->getStorageLocation->getPath . "/" . $asset->get("filename");
|
||||
|
||||
my @stat_before = stat($filename);
|
||||
$asset->getStorageLocation->rotate($asset->get("filename"), 90);
|
||||
my @stat_after = stat($filename);
|
||||
is(isnt_array(\@stat_before, \@stat_after), 1, 'Image is different after rotation');
|
||||
|
||||
@stat_before = stat($filename);
|
||||
$asset->getStorageLocation->resize($asset->get("filename"), 200, 300);
|
||||
my @stat_after = stat($filename);
|
||||
is(isnt_array(\@stat_before, \@stat_after), 1, 'Image is different after resize');
|
||||
|
||||
@stat_before = stat($filename);
|
||||
$asset->getStorageLocation->crop($asset->get("filename"), 100, 125, 10, 25);
|
||||
my @stat_after = stat($filename);
|
||||
is(isnt_array(\@stat_before, \@stat_after), 1, 'Image is different after crop');
|
||||
|
||||
my $sth = $session->db->read('describe ImageAsset annotations');
|
||||
isnt($sth->hashRef, undef, 'Annotations column is defined');
|
||||
|
||||
is($storage->getId, $asset->get('storageId'), 'Asset updated with correct new storageId');
|
||||
is($storage->getId, $asset->getStorageLocation->getId, 'Cached Asset storage location updated with correct new storageId');
|
||||
|
||||
|
|
@ -81,3 +102,13 @@ END {
|
|||
$versionTag->rollback;
|
||||
}
|
||||
}
|
||||
|
||||
sub isnt_array {
|
||||
my ($a, $b) = @_;
|
||||
|
||||
for (my $i = 0; $i < @{ $a }; ++$i) {
|
||||
return 1 if @{ $a }[$i] ne @{ $b }[$i];
|
||||
}
|
||||
|
||||
return 0;
|
||||
}
|
||||
|
|
|
|||
|
|
@ -29,12 +29,9 @@ my $node = WebGUI::Asset->getImportNode( $session );
|
|||
my @versionTags = ( WebGUI::VersionTag->getWorking( $session ) );
|
||||
|
||||
# Override some settings to make things easier to test
|
||||
my %oldSettings;
|
||||
# userFunctionStyleId
|
||||
$oldSettings{ userFunctionStyleId } = $session->setting->get( 'userFunctionStyleId' );
|
||||
$session->setting->set( 'userFunctionStyleId', 'PBtmpl0000000000000132' );
|
||||
# specialState
|
||||
$oldSettings{ specialState } = $session->setting->get( 'specialState' );
|
||||
$session->setting->set( 'specialState', '' );
|
||||
|
||||
# Create a user for testing purposes
|
||||
|
|
@ -180,8 +177,4 @@ END {
|
|||
}
|
||||
|
||||
$user->delete;
|
||||
|
||||
for my $key ( keys %oldSettings ) {
|
||||
$session->setting->set( $key, $oldSettings{ $key } );
|
||||
}
|
||||
}
|
||||
|
|
|
|||
116
t/Asset/Sku/Ad.t
Normal file
116
t/Asset/Sku/Ad.t
Normal file
|
|
@ -0,0 +1,116 @@
|
|||
# vim:syntax=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
|
||||
#------------------------------------------------------------------
|
||||
|
||||
# Write a little about what this script tests.
|
||||
#
|
||||
# This tests WebGUI::Asset::Sku::Ad
|
||||
|
||||
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::Session;
|
||||
use WebGUI::Asset;
|
||||
use WebGUI::Asset::Sku::Ad;
|
||||
use WebGUI::AdSpace;
|
||||
use WebGUI::Storage;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Init
|
||||
my $session = WebGUI::Test->session;
|
||||
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
|
||||
plan tests => 8; # Increment this number for each test you create
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# put your tests here
|
||||
|
||||
my $discounts = <<'EOT';
|
||||
5@500
|
||||
10@1000
|
||||
EOT
|
||||
|
||||
my $discountsWithJunk = <<'EOT';
|
||||
comment
|
||||
5@500 nuthr cmnt
|
||||
|
||||
10@1000heresatuf1
|
||||
last coment
|
||||
EOT
|
||||
|
||||
# print $discounts, $discountsWithJunk;
|
||||
|
||||
cmp_deeply([WebGUI::Asset::Sku::Ad::parseDiscountText($discounts)],
|
||||
[ [ 5,500 ],[10,1000] ],
|
||||
'parseDiscounttext parses correctly');
|
||||
|
||||
cmp_deeply([WebGUI::Asset::Sku::Ad::parseDiscountText($discountsWithJunk)],
|
||||
[ [ 5,500 ],[10,1000] ],
|
||||
'parseDiscounttext ignores comments and blank space');
|
||||
|
||||
is( WebGUI::Asset::Sku::Ad::getDiscountText('Discount at %s',$discounts),
|
||||
'Discount at 500,1000',
|
||||
'getDiscountText formats the text correctly');
|
||||
|
||||
is( WebGUI::Asset::Sku::Ad::getDiscountAmount($discounts,100),0,'no discount');
|
||||
is( WebGUI::Asset::Sku::Ad::getDiscountAmount($discounts,550),5,'5% discount');
|
||||
is( WebGUI::Asset::Sku::Ad::getDiscountAmount($discounts,1050),10,'10% discount');
|
||||
|
||||
# make an AdSku object
|
||||
|
||||
my $root = WebGUI::Asset->getRoot($session);
|
||||
|
||||
|
||||
my $sku = $root->addChild({
|
||||
className => "WebGUI::Asset::Sku::Ad",
|
||||
title => "Ad Space For Sale",
|
||||
adSpace => 'qwert',
|
||||
priority => 1,
|
||||
pricePerClick => 0.01,
|
||||
pricePerImpression => 0.0001,
|
||||
clickDiscounts => <<'EOCD',
|
||||
5@500
|
||||
10@50000
|
||||
EOCD
|
||||
impressionDiscounts => <<'EOID',
|
||||
5@10000
|
||||
15@500000
|
||||
EOID
|
||||
});
|
||||
|
||||
$sku->applyOptions({
|
||||
adtitle => 'Sold!',
|
||||
link => 'http://localhost/',
|
||||
clicks => 1000,
|
||||
impressions => 100000,
|
||||
image => 'asdfgh', # don't need this unless I test onCompletePurchse...
|
||||
});
|
||||
|
||||
is($sku->getConfiguredTitle, 'Ad Space For Sale (Sold!)', 'configured title');
|
||||
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;
|
||||
|
||||
|
|
@ -32,7 +32,7 @@ use WebGUI::Asset::Wobject::Collaboration;
|
|||
use WebGUI::Asset::Post;
|
||||
use WebGUI::Asset::Wobject::Layout;
|
||||
use Data::Dumper;
|
||||
use Test::More tests => 4; # increment this value for each test you create
|
||||
use Test::More tests => 7; # increment this value for each test you create
|
||||
|
||||
my $session = WebGUI::Test->session;
|
||||
|
||||
|
|
@ -60,6 +60,36 @@ ok(defined $collab->get('groupToEditPost'), 'groupToEditPost field is defined');
|
|||
|
||||
# Verify sane defaults
|
||||
cmp_ok($collab->get('groupToEditPost'), 'eq', $collab->get('groupIdEdit'), 'groupToEditPost defaults to groupIdEdit correctly');
|
||||
is($collab->get('itemsPerFeed'), 25, 'itemsPerFeed is set to the default');
|
||||
|
||||
# finally, add the post to the collaboration system
|
||||
my $props = {
|
||||
className => 'WebGUI::Asset::Post::Thread',
|
||||
content => 'hello, world!',
|
||||
};
|
||||
my $post = $collab->addChild($props,
|
||||
undef,
|
||||
undef,
|
||||
{
|
||||
skipAutoCommitWorkflows => 1,
|
||||
});
|
||||
|
||||
# Test for a sane object type
|
||||
isa_ok($post, 'WebGUI::Asset::Post::Thread');
|
||||
|
||||
$props = {
|
||||
className => 'WebGUI::Asset::Post::Thread',
|
||||
content => 'jello, world!',
|
||||
};
|
||||
$post = $collab->addChild($props,
|
||||
undef,
|
||||
undef,
|
||||
{
|
||||
skipAutoCommitWorkflows => 1,
|
||||
});
|
||||
|
||||
my $rssitems = $collab->getRssFeedItems();
|
||||
is(scalar @{ $rssitems }, 2, 'rssitems set to number of posts added');
|
||||
|
||||
TODO: {
|
||||
local $TODO = "Tests to make later";
|
||||
|
|
|
|||
|
|
@ -28,12 +28,9 @@ my $node = WebGUI::Asset->getImportNode( $session );
|
|||
my @versionTags = ( WebGUI::VersionTag->getWorking( $session ) );
|
||||
|
||||
# Override some settings to make things easier to test
|
||||
my %oldSettings;
|
||||
# userFunctionStyleId
|
||||
$oldSettings{ userFunctionStyleId } = $session->setting->get( 'userFunctionStyleId' );
|
||||
$session->setting->set( 'userFunctionStyleId', 'PBtmpl0000000000000132' );
|
||||
# specialState
|
||||
$oldSettings{ specialState } = $session->setting->get( 'specialState' );
|
||||
$session->setting->set( 'specialState', '' );
|
||||
|
||||
# Create a user for testing purposes
|
||||
|
|
@ -120,10 +117,6 @@ END {
|
|||
}
|
||||
|
||||
$user->delete;
|
||||
|
||||
for my $key ( keys %oldSettings ) {
|
||||
$session->setting->set( $key, $oldSettings{ $key } );
|
||||
}
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
|
|||
|
|
@ -65,16 +65,13 @@ for my $i ( 0 .. 5 ) {
|
|||
$versionTag->commit;
|
||||
|
||||
# Override some settings to make things easier to test
|
||||
my %oldSettings;
|
||||
# userFunctionStyleId
|
||||
$oldSettings{ userFunctionStyleId } = $session->setting->get( 'userFunctionStyleId' );
|
||||
$session->setting->set( 'userFunctionStyleId', 'PBtmpl0000000000000132' );
|
||||
# specialState
|
||||
$oldSettings{ specialState } = $session->setting->get( 'specialState' );
|
||||
$session->setting->set( 'specialState', '' );
|
||||
|
||||
my ( $mech );
|
||||
my $baseUrl = 'http://' . $session->config->get('sitename')->[0];
|
||||
my $baseUrl = $session->url->getSiteURL;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
|
|
@ -122,7 +119,4 @@ cmp_deeply(
|
|||
# Cleanup
|
||||
END {
|
||||
$versionTag->rollback();
|
||||
for my $key ( keys %oldSettings ) {
|
||||
$session->setting->set( $key, $oldSettings{ $key } );
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -18,7 +18,7 @@ my $session = WebGUI::Test->session;
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
my $tests = 11;
|
||||
my $tests = 19;
|
||||
plan tests => $tests + 1;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -63,10 +63,31 @@ $survey->responseIdCookies(0);
|
|||
my $responseId = $survey->responseId;
|
||||
my $s = WebGUI::Asset::Wobject::Survey->newByResponseId($session, $responseId);
|
||||
is($s->getId, $survey->getId, 'newByResponseId returns same Survey');
|
||||
is($s->get('maxResponsesPerUser'), 1, 'maxResponsesPerUser defaults to 1');
|
||||
ok($s->canTakeSurvey, '..which means user can take survey');
|
||||
|
||||
#for my $address (@{ $survey->responseJSON->surveyOrder }) {
|
||||
# diag (Dumper $address);
|
||||
#}
|
||||
# Complete Survey
|
||||
$s->surveyEnd();
|
||||
|
||||
# Uncache canTake
|
||||
delete $s->{canTake};
|
||||
delete $s->{responseId};
|
||||
$s->responseIdCookies(0);
|
||||
ok(!$s->canTakeSurvey, 'Cannot take survey a second time (maxResponsesPerUser=1)');
|
||||
cmp_deeply($s->responseId, undef, '..and similarly cannot get responseId');
|
||||
|
||||
# Change maxResponsesPerUser to 2
|
||||
$s->update({maxResponsesPerUser => 2});
|
||||
delete $s->{canTake};
|
||||
ok($s->canTakeSurvey, '..but can take when maxResponsesPerUser increased to 2');
|
||||
ok($s->responseId, '..and similarly can get responseId');
|
||||
|
||||
# Change maxResponsesPerUser to 0
|
||||
$s->update({maxResponsesPerUser => 0});
|
||||
delete $s->{canTake};
|
||||
delete $s->{responseId};
|
||||
ok($s->canTakeSurvey, '..and also when maxResponsesPerUser set to 0 (unlimited)');
|
||||
ok($s->responseId, '..(and similarly for responseId)');
|
||||
|
||||
# www_jumpTo
|
||||
{
|
||||
|
|
|
|||
116
t/Asset/Wobject/Survey/ExpressionEngine.t
Normal file
116
t/Asset/Wobject/Survey/ExpressionEngine.t
Normal file
|
|
@ -0,0 +1,116 @@
|
|||
# Tests WebGUI::Asset::Wobject::Survey
|
||||
#
|
||||
#
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
use FindBin;
|
||||
use lib "$FindBin::Bin/../../../lib";
|
||||
use Test::More;
|
||||
use Test::Deep;
|
||||
use Test::MockObject::Extends;
|
||||
use Test::Exception;
|
||||
use Data::Dumper;
|
||||
use List::Util qw/shuffle/;
|
||||
use WebGUI::Test; # Must use this before any other WebGUI modules
|
||||
use WebGUI::Session;
|
||||
use Tie::IxHash;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Init
|
||||
my $session = WebGUI::Test->session;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
my $tests = 36;
|
||||
plan tests => $tests + 1;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# put your tests here
|
||||
|
||||
my $usedOk = use_ok('WebGUI::Asset::Wobject::Survey::ExpressionEngine');
|
||||
|
||||
SKIP: {
|
||||
|
||||
skip $tests, "Unable to load ExpressionEngine" unless $usedOk;
|
||||
|
||||
my $e = "WebGUI::Asset::Wobject::Survey::ExpressionEngine";
|
||||
|
||||
is( $e->run( $session, 'jump { 1 } target' ),
|
||||
undef, "Nothing happens unless we turn on enableSurveyExpressionEngine in config" );
|
||||
WebGUI::Test->originalConfig('enableSurveyExpressionEngine');
|
||||
$session->config->set( 'enableSurveyExpressionEngine', 1 );
|
||||
is( $e->run( $session, 'jump { 1 } target' ), 'target', "..now we're in business!" );
|
||||
|
||||
my %values = (
|
||||
n => 5,
|
||||
s1 => 'my string',
|
||||
);
|
||||
|
||||
my %scores = (
|
||||
n1 => 1,
|
||||
n2 => 2,
|
||||
);
|
||||
|
||||
# These should all jump to 'target'
|
||||
my @should_pass = (
|
||||
q{jump { 1 } target},
|
||||
q{jump { return 1 } target},
|
||||
q{jump { "string" } target},
|
||||
q{jump { value(n) == 5 } target},
|
||||
q{jump { value(n) > 0 } target},
|
||||
q{jump { value(s1) eq "my string" } target},
|
||||
q{jump { value(s1) =~ m/my/ } target},
|
||||
q{jump { value(n) == 4 or value(n) == 5 } target},
|
||||
q{jump { value(n) == 5 && value(n) > 0 } target},
|
||||
q{jump { (value(n) > 1 ? 10 : 11) == 10 } target},
|
||||
q{jump { $a=1; $a++; $a++; $a *= 2; $a == 6 } target},
|
||||
q{jump { @a = (1..10); $a[0] == 1 && @a == 10 } target}, # arrays
|
||||
q{jump { if (value(n) == 5) { 1 } else { 0 } } target}, # if statement
|
||||
q{jump { $q2 = 3; $avg = (value(n) + $q2) / 2; $avg == 4 } target}, # look ma, averages!
|
||||
q{jump { $q2 = 3; avg(value(n), $q2) == 4 } target}, # look ma, built-in avg sub!
|
||||
q{jump { value(n) == 5 } target; jump { value(n) == 5 } targetX}, # first jump wins
|
||||
q{jump { value(n) == 0 } targetX; jump { value(n) == 5 } target}, # false jumps ignored
|
||||
q{jump { min(3,5,2) == 2 } target}, # List::Util min
|
||||
q{jump { sum(value(n),1,1,1) == 8 } target}, # List::Util sum, etc..
|
||||
q{jump { score(n1) == 1 && score(n2) == 2 } target}, # score() works
|
||||
);
|
||||
|
||||
my @should_fail = (
|
||||
q{}, # empty
|
||||
q{ return }, # empty
|
||||
q{1}, # doesn't call jump
|
||||
q|{|, # doesn't compile
|
||||
q{blah-dee-blah-blah}, # rubbish expression
|
||||
q{jump {} target}, # empty anon sub to jump
|
||||
q{jump { 0 } target}, # false sub to jump
|
||||
q{jump { value(n) == 500 } target},
|
||||
q{jump { value(s1) eq 'blah' } target},
|
||||
q{jump { time } target}, # time and other opcodes not allowed
|
||||
);
|
||||
|
||||
for my $expr (@should_pass) {
|
||||
is( $e->run( $session, $expr, { values => \%values, scores => \%scores } ),
|
||||
'target', "\"$expr\" jumps as expected" );
|
||||
}
|
||||
|
||||
for my $expr (@should_fail) {
|
||||
is( $e->run( $session, $expr, { values => \%values, scores => \%scores } ),
|
||||
undef, "\"$expr\" fails as expected" );
|
||||
}
|
||||
|
||||
$e->run( $session, q{jump {$x = value(s1); $x = 'X'} target}, { values => \%values } );
|
||||
is( $values{s1}, 'my string', "Expression can't modify values" );
|
||||
|
||||
like( $e->run( $session, '{', { validate => 1 } ), qr/Missing right curly/, "Validation option works" );
|
||||
|
||||
# Check validTargets option
|
||||
is( $e->run( $session, q{jump {1} target}, { values => \%values, validTargets => { a => 1 } } ),
|
||||
undef, 'target is not valid' );
|
||||
is( $e->run( $session, q{jump {1} target}, { values => \%values, validTargets => { target => 1 } } ),
|
||||
'target', '..whereas now it is ok' );
|
||||
}
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Cleanup
|
||||
END { }
|
||||
|
|
@ -22,7 +22,7 @@ my $session = WebGUI::Test->session;
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
my $tests = 79;
|
||||
my $tests = 64;
|
||||
plan tests => $tests + 1;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -323,85 +323,129 @@ is($rJSON->lastResponse(), 5, 'goto: finds first if there are duplicates');
|
|||
|
||||
####################################################
|
||||
#
|
||||
# processGotoExpression
|
||||
#
|
||||
####################################################
|
||||
throws_ok { $rJSON->parseGotoExpression() } 'WebGUI::Error::InvalidParam', 'processGotoExpression takes exception to empty arguments';
|
||||
is($rJSON->parseGotoExpression(q{}),
|
||||
undef, '.. and undef with empty expression');
|
||||
is($rJSON->parseGotoExpression('blah-dee-blah-blah'),
|
||||
undef, '.. and undef with duff expression');
|
||||
is($rJSON->parseGotoExpression(':'),
|
||||
undef, '.. and undef with missing target');
|
||||
is($rJSON->parseGotoExpression('t1:'),
|
||||
undef, '.. and undef with missing expression');
|
||||
cmp_deeply($rJSON->parseGotoExpression('t1: 1'),
|
||||
{ target => 't1', expression => '1'}, 'works for simple numeric expression');
|
||||
cmp_deeply($rJSON->parseGotoExpression('t1: 1 - 23 + 456 * (78 / 9.0)'),
|
||||
{ target => 't1', expression => '1 - 23 + 456 * (78 / 9.0)'}, 'works for expression using all algebraic tokens');
|
||||
is($rJSON->parseGotoExpression('t1: 1 + &'), undef, '.. but disallows expression containing non-whitelisted token');
|
||||
cmp_deeply($rJSON->parseGotoExpression('t1: 1 = 3'),
|
||||
{ target => 't1', expression => '1 == 3'}, 'converts single = to ==');
|
||||
cmp_deeply($rJSON->parseGotoExpression('t1: 1 != 3 <= 4 >= 5'),
|
||||
{ target => 't1', expression => '1 != 3 <= 4 >= 5'}, q{..but doesn't mess with other ops containing =});
|
||||
cmp_deeply($rJSON->parseGotoExpression('t1: q1 + q2 * q3 - 4', { q1 => 11, q2 => 22, q3 => 33}),
|
||||
{ target => 't1', expression => '11 + 22 * 33 - 4'}, 'substitues q for value');
|
||||
cmp_deeply($rJSON->parseGotoExpression('t1: a silly var name * 10 + another var name', { 'a silly var name' => 345, 'another var name' => 456}),
|
||||
{ target => 't1', expression => '345 * 10 + 456'}, '..it even works for vars with spaces in their names');
|
||||
is($rJSON->parseGotoExpression('t1: qX + 3', { q1 => '7'}),
|
||||
undef, q{..but doesn't like invalid var names});
|
||||
|
||||
####################################################
|
||||
#
|
||||
# gotoExpression
|
||||
# responseScoresByVariableName
|
||||
#
|
||||
####################################################
|
||||
|
||||
$rJSON->survey->section([0])->{variable} = 's0';
|
||||
$rJSON->survey->section([1])->{variable} = 's1';
|
||||
$rJSON->survey->section([2])->{variable} = 's2';
|
||||
$rJSON->survey->section([3])->{variable} = 's3';
|
||||
$rJSON->survey->question([1,0])->{variable} = 's1q0';
|
||||
$rJSON->survey->answer([1,0,0])->{value} = 3;
|
||||
$rJSON->survey->question([1,1])->{variable} = 's1q1';
|
||||
$rJSON->survey->answer([1,0,0])->{value} = 100; # set answer score
|
||||
$rJSON->survey->answer([1,1,0])->{value} = 200; # set answer score
|
||||
cmp_deeply($rJSON->responseScoresByVariableName, {}, 'scores initially empty');
|
||||
|
||||
$rJSON->lastResponse(2);
|
||||
$rJSON->recordResponses({
|
||||
'1-0-0' => 'My chosen answer',
|
||||
'1-1-0' => 'My chosen answer',
|
||||
});
|
||||
cmp_deeply($rJSON->responseScoresByVariableName, { s1q0 => 100, s1q1 => 200, s1 => 300}, 'scores now reflect q answers and section totals');
|
||||
|
||||
####################################################
|
||||
#
|
||||
# processGotoExpression
|
||||
#
|
||||
####################################################
|
||||
# Turn on the survey Expression Engine
|
||||
WebGUI::Test->originalConfig('enableSurveyExpressionEngine');
|
||||
$session->config->set('enableSurveyExpressionEngine', 1);
|
||||
$rJSON->survey->section([0])->{variable} = 's0'; # our first test jump target
|
||||
$rJSON->survey->section([2])->{variable} = 's2'; # our second test jump target
|
||||
$rJSON->survey->question([1,0])->{variable} = 's1q0'; # a question variable to use in our expressions
|
||||
$rJSON->survey->answer([1,0,0])->{recordedAnswer} = 3; # value recorded in responses hash for multi-choice answer
|
||||
|
||||
$rJSON->lastResponse(2);
|
||||
$rJSON->recordResponses({
|
||||
'1-0comment' => 'Section 1, question 0 comment',
|
||||
'1-0-0' => 'First answer',
|
||||
'1-0-0' => 'My chosen answer',
|
||||
'1-0-0comment' => 'Section 1, question 0, answer 0 comment',
|
||||
});
|
||||
is($rJSON->processGotoExpression('blah-dee-blah-blah'), undef, 'invalid gotoExpression is false');
|
||||
ok($rJSON->processGotoExpression('s0: s1q0 = 3'), '3 == 3 is true');
|
||||
ok(!$rJSON->processGotoExpression('s0: s1q0 = 4'), '3 == 4 is false');
|
||||
ok($rJSON->processGotoExpression('s0: s1q0 != 2'), '3 != 2 is true');
|
||||
ok(!$rJSON->processGotoExpression('s0: s1q0 != 3'), '3 != 3 is false');
|
||||
ok($rJSON->processGotoExpression('s0: s1q0 > 2'), '3 > 2 is true');
|
||||
ok($rJSON->processGotoExpression('s0: s1q0 < 4'), '3 < 2 is true');
|
||||
ok(!$rJSON->processGotoExpression('s0: s1q0 >= 4'), '3 >= 4 is false');
|
||||
ok(!$rJSON->processGotoExpression('s0: s1q0 <= 2'), '3 >= 4 is false');
|
||||
is($rJSON->lastResponse, 4, 'lastResponse at 4 before any gotoExpressions processed');
|
||||
|
||||
cmp_deeply($rJSON->processGotoExpression(<<"END_EXPRESSION"), {target => 's2', expression => '3 == 3'}, 'first true expression wins');
|
||||
s0: s1q0 <= 2
|
||||
s2: s1q0 = 3
|
||||
END_EXPRESSION
|
||||
$rJSON->processGotoExpression('blah-dee-blah-blah {');
|
||||
is($rJSON->lastResponse, 4, '..unchanged after duff expression');
|
||||
|
||||
ok(!$rJSON->processGotoExpression(<<"END_EXPRESSION"), 'but multiple false expressions still false');
|
||||
s0: s1q0 <= 2
|
||||
s2: s1q0 = 345
|
||||
END_EXPRESSION
|
||||
$rJSON->processGotoExpression('jump { value(s1q0) == 4} s0');
|
||||
is($rJSON->lastResponse, 4, '..unchanged after false expression');
|
||||
|
||||
$rJSON->processGotoExpression('s0: s1q0 = 3');
|
||||
is($rJSON->lastResponse(), -1, '.. lastResponse changed to -1 due to processGoto(s0)');
|
||||
$rJSON->processGotoExpression('s2: s1q0 = 3');
|
||||
is($rJSON->lastResponse(), 4, '.. lastResponse changed to 4 due to processGoto(s2)');
|
||||
$rJSON->processGotoExpression('jump { value(s1q0) == 4} s0; jump { value(s1q0) == 5} s0;');
|
||||
is($rJSON->lastResponse, 4, '..similarly for multi-statement false expression');
|
||||
|
||||
$rJSON->processGotoExpression('jump { value(s1q0) == 3} DUFF_TARGET');
|
||||
is($rJSON->lastResponse, 4, '..similarly for expression with invalid target');
|
||||
|
||||
$rJSON->processGotoExpression('jump { value(s1q0) == 3} s0');
|
||||
is($rJSON->lastResponse, -1, '..but updated to s0 after true expression');
|
||||
|
||||
$rJSON->processGotoExpression('jump { value(s1q0) == 4} s0; jump { value(s1q0) == 3} s2');
|
||||
is($rJSON->lastResponse, 4, '..changed again for multi-statement true expression');
|
||||
|
||||
$rJSON->processGotoExpression('jump { score(s1q0) == 100} s0');
|
||||
is($rJSON->lastResponse, -1, '..and again when score used');
|
||||
|
||||
$rJSON->processGotoExpression('jump { score("s1") == 300} s2');
|
||||
is($rJSON->lastResponse, 4, '..and again when section score total used');
|
||||
|
||||
$rJSON->responses({});
|
||||
$rJSON->questionsAnswered(-1 * $rJSON->questionsAnswered);
|
||||
|
||||
####################################################
|
||||
#
|
||||
# recordedNamedResponses (coming soon)
|
||||
#
|
||||
####################################################
|
||||
# {
|
||||
#
|
||||
# # $rJSON->survey->question([1,0])->{questionType} = 'Multiple Choice';
|
||||
# # $rJSON->survey->answer([1,0,0])->{value} = 5;
|
||||
# # cmp_deeply($rJSON->recordedNamedResponses, {}, 'recordedNamedResponses initially empty');
|
||||
# # $rJSON->lastResponse(2);
|
||||
# # $rJSON->recordResponses({
|
||||
# # '1-0comment' => 'Section 1, question 0 comment',
|
||||
# # '1-0-0' => 'My chosen answer',
|
||||
# # '1-0-0comment' => 'Section 1, question 0, answer 0 comment',
|
||||
# # });
|
||||
# # cmp_deeply($rJSON->recordedNamedResponses, { s1q0 => 5 }, '..now shows multi-choice answer value');
|
||||
# # $rJSON->survey->answer([1,0,0])->{value} = 'blah';
|
||||
# # cmp_deeply($rJSON->recordedNamedResponses, { s1q0 => 'blah' }, '..also works with string value');
|
||||
# # $rJSON->survey->loadTypes;
|
||||
# # my $a =
|
||||
# # diag(Dumper ($rJSON->survey->multipleChoiceTypes));
|
||||
#
|
||||
# $rJSON->survey->question([1,0])->{variable} = 's1q0';
|
||||
#
|
||||
# # First try with generic Multi Choice
|
||||
# $rJSON->survey->question( [ 1, 0 ] )->{questionType} = 'Multiple Choice';
|
||||
# $rJSON->survey->answer( [ 1, 0, 0 ] )->{recordedAnswer} = 'My recordedAnswer';
|
||||
# $rJSON->lastResponse(2);
|
||||
# $rJSON->recordResponses( { '1-0-0' => 'My chosen answer', } );
|
||||
# is( $rJSON->responses->{'1-0-0'}->{value}, 'My recordedAnswer', 'Multi-choice uses recordedAnswer' );
|
||||
#
|
||||
# # Then with Yes/No bundle
|
||||
# $rJSON->survey->question( [ 1, 0 ] )->{questionType} = 'Yes/No';
|
||||
# $rJSON->lastResponse(2);
|
||||
# $rJSON->recordResponses( { '1-0-0' => 'My chosen answer', } );
|
||||
# is( $rJSON->responses->{'1-0-0'}->{value}, 'My recordedAnswer', 'Multi-choice bundle also uses recordedAnswer' );
|
||||
#
|
||||
# # Then with Text
|
||||
# $rJSON->survey->question( [ 1, 0 ] )->{questionType} = 'Text';
|
||||
# $rJSON->lastResponse(2);
|
||||
# $rJSON->recordResponses( { '1-0-0' => 'My entered text', } );
|
||||
# is( $rJSON->responses->{'1-0-0'}->{value}, 'My entered text', 'Text type uses entered text' );
|
||||
# diag( Dumper( $rJSON->responses ) );
|
||||
# diag( Dumper( $rJSON->recordedNamedResponses ) );
|
||||
# }
|
||||
|
||||
####################################################
|
||||
#
|
||||
# recordResponses
|
||||
#
|
||||
####################################################
|
||||
|
||||
$rJSON->survey->question([1,0])->{questionType} = 'Multiple Choice';
|
||||
$rJSON->lastResponse(4);
|
||||
my $terminals;
|
||||
cmp_deeply(
|
||||
|
|
@ -426,6 +470,7 @@ $rJSON->survey->question([1,0])->{terminal} = 1;
|
|||
$rJSON->survey->question([1,0])->{terminalUrl} = 'question 1-0 terminal';
|
||||
|
||||
$rJSON->lastResponse(2);
|
||||
$rJSON->survey->answer([1,0,0])->{recordedAnswer} = 1; # Set recordedAnswer
|
||||
cmp_deeply(
|
||||
$rJSON->recordResponses({
|
||||
'1-0comment' => 'Section 1, question 0 comment',
|
||||
|
|
|
|||
|
|
@ -13,8 +13,8 @@ use Data::Dumper;
|
|||
use WebGUI::Test; # Must use this before any other WebGUI modules
|
||||
use WebGUI::Session;
|
||||
use JSON;
|
||||
#use Clone qw/clone/;
|
||||
use Storable qw/dclone/;
|
||||
use Clone qw/clone/;
|
||||
#use Storable qw/dclone/;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
# Init
|
||||
|
|
@ -22,7 +22,7 @@ my $session = WebGUI::Test->session;
|
|||
|
||||
#----------------------------------------------------------------------------
|
||||
# Tests
|
||||
my $tests = 132;
|
||||
my $tests = 139;
|
||||
plan tests => $tests + 1 + 3;
|
||||
|
||||
#----------------------------------------------------------------------------
|
||||
|
|
@ -2002,7 +2002,30 @@ cmp_deeply(
|
|||
|
||||
####################################################
|
||||
#
|
||||
# totalSections
|
||||
# questions
|
||||
#
|
||||
####################################################
|
||||
{
|
||||
my $s = WebGUI::Asset::Wobject::Survey::SurveyJSON->new($session, '{}');
|
||||
# Add a new section
|
||||
my $address = $s->newObject([]);
|
||||
cmp_deeply($s->questions, [], 'Initially no questions');
|
||||
# Add a question to first section
|
||||
$address = $s->newObject([0]);
|
||||
is(scalar @{$s->questions}, 1, '..now 1 question');
|
||||
is(scalar @{$s->questions([0])}, 1, '..in the first section');
|
||||
is($s->questions([2]), undef, '..and none in the second section (which doesnt even exist)');
|
||||
|
||||
# Add a question to second section
|
||||
$address = $s->newObject([1]);
|
||||
is(scalar @{$s->questions}, 2, '..now 2 question2');
|
||||
is(scalar @{$s->questions([0])}, 1, '..1 in the first section');
|
||||
is(scalar @{$s->questions([1])}, 1, '..1 in the second section');
|
||||
}
|
||||
|
||||
####################################################
|
||||
#
|
||||
# totalSections, totalQuestions, totalAnswers
|
||||
#
|
||||
####################################################
|
||||
{
|
||||
|
|
@ -2123,13 +2146,13 @@ sub buildSectionSkeleton {
|
|||
my $sections = [];
|
||||
my ($bareSection, $bareQuestion, $bareAnswer) = getBareSkeletons();
|
||||
foreach my $questionSpec ( @{ $spec } ) {
|
||||
my $section = dclone $bareSection;
|
||||
my $section = clone $bareSection;
|
||||
push @{ $sections }, $section;
|
||||
foreach my $answers ( @{$questionSpec} ) {
|
||||
my $question = dclone $bareQuestion;
|
||||
my $question = clone $bareQuestion;
|
||||
push @{ $section->{questions} }, $question;
|
||||
while ($answers-- > 0) {
|
||||
my $answer = dclone $bareAnswer;
|
||||
my $answer = clone $bareAnswer;
|
||||
push @{ $question->{answers} }, $answer;
|
||||
}
|
||||
}
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@ use lib "$FindBin::Bin/../../lib";
|
|||
use WebGUI::Test;
|
||||
use WebGUI::Session;
|
||||
use WebGUI::PseudoRequest;
|
||||
use Test::More tests => 16; # increment this value for each test you create
|
||||
use Test::More tests => 17; # increment this value for each test you create
|
||||
use Test::Deep;
|
||||
use JSON;
|
||||
use WebGUI::Asset::Wobject::Thingy;
|
||||
|
|
@ -192,6 +192,14 @@ my ($fieldLabel, $columnType, $Null, $Key, $Default, $Extra) = $session->db->qui
|
|||
is($fieldLabel,"field_".$fieldId,"A column for the new field Field_$fieldId exists.");
|
||||
is($columnType,"longtext","The columns is the right type");
|
||||
|
||||
# Test duplicating a Thing
|
||||
|
||||
my $copyThingId = $thingy->duplicateThing($thingId);
|
||||
|
||||
$isValidId = $session->id->valid($copyThingId);
|
||||
|
||||
is($isValidId,1,"duplicating a Thing: duplicateThing returned a valid id: ".$copyThingId);
|
||||
|
||||
# Test adding, editing, getting and deleting thing data
|
||||
|
||||
my ($newThingDataId,$errors) = $thingy->editThingDataSave($thingId,'new',{"field_".$fieldId => 'test value'});
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue