Add support for additional, required per-package constructor args.
Give better diagnostics on which properties don't appear in forms and vice versa so I can hopefully figure out the rhyme and reason to those that don't match. When an edit form takes attachmentsJson, stick some in there so it doesn't get upset and to give it a workout.
This commit is contained in:
parent
c74572bac1
commit
5d50866461
1 changed files with 47 additions and 11 deletions
|
|
@ -21,6 +21,10 @@ use WebGUI::Test;
|
||||||
use WebGUI::Utility;
|
use WebGUI::Utility;
|
||||||
use Data::Dumper;
|
use Data::Dumper;
|
||||||
|
|
||||||
|
sub constructorExtras {
|
||||||
|
return;
|
||||||
|
}
|
||||||
|
|
||||||
sub debug {
|
sub debug {
|
||||||
|
|
||||||
# if the last eval { } caught something, give full diagnostics on that and stop the tests.
|
# if the last eval { } caught something, give full diagnostics on that and stop the tests.
|
||||||
|
|
@ -85,6 +89,7 @@ sub getAnchoredAsset {
|
||||||
my @parents = $test->getMyParents;
|
my @parents = $test->getMyParents;
|
||||||
my $asset = $parents[-1]->addChild({
|
my $asset = $parents[-1]->addChild({
|
||||||
className => $test->class,
|
className => $test->class,
|
||||||
|
$test->constructorExtras, # XXX in the right spot?
|
||||||
}, undef, undef, {skipNotification => 1, skipAutoCommitWorkflows => 1,});
|
}, undef, undef, {skipNotification => 1, skipAutoCommitWorkflows => 1,});
|
||||||
# warn "XXX getAnchoredAsset: created new asset of Id: " . $asset->getId . ' of type: ' . ref $asset;
|
# warn "XXX getAnchoredAsset: created new asset of Id: " . $asset->getId . ' of type: ' . ref $asset;
|
||||||
$tag->commit;
|
$tag->commit;
|
||||||
|
|
@ -104,7 +109,12 @@ sub getMyParents {
|
||||||
push @parents, $default;
|
push @parents, $default;
|
||||||
my $parent = $default;
|
my $parent = $default;
|
||||||
foreach my $parent_class (@{ $parent_classes }) {
|
foreach my $parent_class (@{ $parent_classes }) {
|
||||||
my $new_parent = $parent->addChild({className => $parent_class}, undef, undef, {skipNotification => 1, skipAutoCommitWorkflows => 1,});
|
my $new_parent = $parent->addChild(
|
||||||
|
{className => $parent_class, $test->constructorExtras, },
|
||||||
|
undef,
|
||||||
|
undef,
|
||||||
|
{skipNotification => 1, skipAutoCommitWorkflows => 1,},
|
||||||
|
);
|
||||||
push @parents, $new_parent;
|
push @parents, $new_parent;
|
||||||
$parent = $new_parent;
|
$parent = $new_parent;
|
||||||
WebGUI::Test->addToCleanup($new_parent);
|
WebGUI::Test->addToCleanup($new_parent);
|
||||||
|
|
@ -115,7 +125,7 @@ sub getMyParents {
|
||||||
sub _constructor : Test(4) {
|
sub _constructor : Test(4) {
|
||||||
my $test = shift;
|
my $test = shift;
|
||||||
my $session = $test->session;
|
my $session = $test->session;
|
||||||
my $asset = $test->class->new({session => $session});
|
my $asset = $test->class->new({session => $session, $test->constructorExtras, });
|
||||||
|
|
||||||
note '=' x 80;
|
note '=' x 80;
|
||||||
note "Constructor: CLASS " . $test->class;
|
note "Constructor: CLASS " . $test->class;
|
||||||
|
|
@ -134,6 +144,7 @@ sub _constructor : Test(4) {
|
||||||
}
|
}
|
||||||
|
|
||||||
sub t_00_class_dispatch : Test(2) {
|
sub t_00_class_dispatch : Test(2) {
|
||||||
|
# XXX this could be moved out of Test::Class into a linear test, such as in Asset.t
|
||||||
my $test = shift;
|
my $test = shift;
|
||||||
my $session = $test->session;
|
my $session = $test->session;
|
||||||
note "Class dispatch";
|
note "Class dispatch";
|
||||||
|
|
@ -198,7 +209,11 @@ sub t_00_newByPropertyHashRef : Test(2) {
|
||||||
my $session = $test->session;
|
my $session = $test->session;
|
||||||
note "newByPropertyHashRef";
|
note "newByPropertyHashRef";
|
||||||
my $asset;
|
my $asset;
|
||||||
$asset = WebGUI::Asset->newByPropertyHashRef($session, {className => $test->class, title => 'The Shawshank Snippet'});
|
$asset = WebGUI::Asset->newByPropertyHashRef($session, {
|
||||||
|
className => $test->class,
|
||||||
|
title => 'The Shawshank Snippet',
|
||||||
|
$test->constructorExtras,
|
||||||
|
});
|
||||||
isa_ok $asset, $test->class;
|
isa_ok $asset, $test->class;
|
||||||
is $asset->title, 'The Shawshank Snippet', 'title is assigned from the property hash';
|
is $asset->title, 'The Shawshank Snippet', 'title is assigned from the property hash';
|
||||||
|
|
||||||
|
|
@ -224,13 +239,16 @@ sub t_00_scan_properties : Test(1) {
|
||||||
sub t_01_assetId : Test(4) {
|
sub t_01_assetId : Test(4) {
|
||||||
my $test = shift;
|
my $test = shift;
|
||||||
my $session = $test->session;
|
my $session = $test->session;
|
||||||
my $asset = $test->class->new({session => $session});
|
my $asset = $test->class->new({
|
||||||
|
session => $session,
|
||||||
|
$test->constructorExtras,
|
||||||
|
});
|
||||||
note "assetId, getId";
|
note "assetId, getId";
|
||||||
can_ok $asset, qw/assetId getId/;
|
can_ok $asset, qw/assetId getId/;
|
||||||
ok $session->id->valid( $asset->assetId), 'assetId generated by default is valid';
|
ok $session->id->valid( $asset->assetId), 'assetId generated by default is valid';
|
||||||
is $asset->assetId, $asset->getId, '... getId is an alias for assetId';
|
is $asset->assetId, $asset->getId, '... getId is an alias for assetId';
|
||||||
|
|
||||||
$asset = $test->class->new({ session => $session, assetId => '' });
|
$asset = $test->class->new({ session => $session, assetId => '', $test->constructorExtras, });
|
||||||
ok !$session->id->valid($asset->assetId), 'blank assetId in constructor is okay??';
|
ok !$session->id->valid($asset->assetId), 'blank assetId in constructor is okay??';
|
||||||
|
|
||||||
debug($@);
|
debug($@);
|
||||||
|
|
@ -240,7 +258,10 @@ sub t_01_assetId : Test(4) {
|
||||||
sub t_01_title : Test(6) {
|
sub t_01_title : Test(6) {
|
||||||
my $test = shift;
|
my $test = shift;
|
||||||
my $session = $test->session;
|
my $session = $test->session;
|
||||||
my $asset = $test->class->new({session => $session});
|
my $asset = $test->class->new({
|
||||||
|
session => $session,
|
||||||
|
$test->constructorExtras,
|
||||||
|
});
|
||||||
|
|
||||||
note "title";
|
note "title";
|
||||||
can_ok $asset, 'title';
|
can_ok $asset, 'title';
|
||||||
|
|
@ -264,7 +285,10 @@ sub t_01_title : Test(6) {
|
||||||
sub t_01_menuTitle : Test(8) {
|
sub t_01_menuTitle : Test(8) {
|
||||||
my $test = shift;
|
my $test = shift;
|
||||||
my $session = $test->session;
|
my $session = $test->session;
|
||||||
my $asset = $test->class->new({session => $session});
|
my $asset = $test->class->new({
|
||||||
|
session => $session,
|
||||||
|
$test->constructorExtras,
|
||||||
|
});
|
||||||
|
|
||||||
note "menuTitle";
|
note "menuTitle";
|
||||||
|
|
||||||
|
|
@ -272,6 +296,7 @@ sub t_01_menuTitle : Test(8) {
|
||||||
is $asset->menuTitle, 'Untitled', 'menuTitle: default is untitled';
|
is $asset->menuTitle, 'Untitled', 'menuTitle: default is untitled';
|
||||||
|
|
||||||
$asset = $test->class->new({
|
$asset = $test->class->new({
|
||||||
|
$test->constructorExtras,
|
||||||
session => $session,
|
session => $session,
|
||||||
title => 'asset title',
|
title => 'asset title',
|
||||||
});
|
});
|
||||||
|
|
@ -290,6 +315,7 @@ sub t_01_menuTitle : Test(8) {
|
||||||
is $asset->menuTitle, 'asset title', '... if HTML filters out all, returns default';
|
is $asset->menuTitle, 'asset title', '... if HTML filters out all, returns default';
|
||||||
|
|
||||||
$asset = $test->class->new({
|
$asset = $test->class->new({
|
||||||
|
$test->constructorExtras,
|
||||||
session => $session,
|
session => $session,
|
||||||
title => 'asset title',
|
title => 'asset title',
|
||||||
menuTitle => 'menuTitle asset',
|
menuTitle => 'menuTitle asset',
|
||||||
|
|
@ -304,7 +330,10 @@ sub t_01_uiLevel : Test(1) {
|
||||||
my $test = shift;
|
my $test = shift;
|
||||||
my $session = $test->session;
|
my $session = $test->session;
|
||||||
note "uiLevel";
|
note "uiLevel";
|
||||||
my $asset = $test->class->new({session => $session});
|
my $asset = $test->class->new({
|
||||||
|
session => $session,
|
||||||
|
$test->constructorExtras,
|
||||||
|
});
|
||||||
is $asset->uiLevel, $test->assetUiLevel, 'asset uiLevel check';
|
is $asset->uiLevel, $test->assetUiLevel, 'asset uiLevel check';
|
||||||
|
|
||||||
debug($@);
|
debug($@);
|
||||||
|
|
@ -429,7 +458,7 @@ sub t_11_getEditForm : Tests {
|
||||||
my $session = $test->session;
|
my $session = $test->session;
|
||||||
my ( $tag, $asset, @parents ) = $test->getAnchoredAsset();
|
my ( $tag, $asset, @parents ) = $test->getAnchoredAsset();
|
||||||
|
|
||||||
my $f = $asset->getEditForm;
|
my $f = $asset->getEditForm; # XXX "Attribute (name) is required" / CLASS WebGUI::Asset::Wobject::Poll... fixed, now it's something else: not ok 2105 - t_11_getEditForm died (Can't locate object method "raw" via package "WebGUI::FormBuilder::Tab" at /data/WebGUI/lib/WebGUI/Asset/Wobject/Poll.pm line 292.)
|
||||||
|
|
||||||
isa_ok( $f, 'WebGUI::FormBuilder' );
|
isa_ok( $f, 'WebGUI::FormBuilder' );
|
||||||
|
|
||||||
|
|
@ -478,6 +507,8 @@ sub t_11_getEditForm : Tests {
|
||||||
# 'getProperties agrees with getEditForm->getFieldsRecursive',
|
# 'getProperties agrees with getEditForm->getFieldsRecursive',
|
||||||
# );
|
# );
|
||||||
|
|
||||||
|
@form = grep { defined $_->{label} and $_->{label} ne 'Keywords' and $_->{label} ne 'Class Name' and $_->{label} ne 'Asset ID' } @form;
|
||||||
|
|
||||||
my %superlist = map { ( $_->{label} => 1 ) } grep { $_->{label} } @form, @properties;
|
my %superlist = map { ( $_->{label} => 1 ) } grep { $_->{label} } @form, @properties;
|
||||||
note "all labels: " . join ', ', keys %superlist;
|
note "all labels: " . join ', ', keys %superlist;
|
||||||
|
|
||||||
|
|
@ -487,8 +518,6 @@ sub t_11_getEditForm : Tests {
|
||||||
note "label ``$label'' not in form" if ! grep { $_->{label} eq $label } @form;
|
note "label ``$label'' not in form" if ! grep { $_->{label} eq $label } @form;
|
||||||
}
|
}
|
||||||
|
|
||||||
@form = grep { defined $_->{label} and $_->{label} ne 'Keywords' and $_->{label} ne 'Class Name' and $_->{label} ne 'Asset ID' } @form;
|
|
||||||
|
|
||||||
cmp_deeply(
|
cmp_deeply(
|
||||||
[ sort { $a cmp $b } map { $_->{label} } @form ],
|
[ sort { $a cmp $b } map { $_->{label} } @form ],
|
||||||
[ sort { $a cmp $b } map { $_->{label} } @properties ],
|
[ sort { $a cmp $b } map { $_->{label} } @properties ],
|
||||||
|
|
@ -522,6 +551,13 @@ sleep 2; # also XXXX
|
||||||
title => "Newly Saved Title",
|
title => "Newly Saved Title",
|
||||||
);
|
);
|
||||||
|
|
||||||
|
if( exists $mergedProperties{attachmentsJson} and ! defined $mergedProperties{attachmentsJson} ) {
|
||||||
|
# XXX move this to the Test::WebGUI::Asset::Template subclass... maybe make a postProcessMergedProperties method
|
||||||
|
$mergedProperties{attachmentsJson} = '[{"url":"/webgui.css","type":"stylesheet"}]';
|
||||||
|
}
|
||||||
|
|
||||||
|
local $SIG{__DIE__} = sub { use Carp; Carp::confess "@_"; };
|
||||||
|
|
||||||
$session->request->setup_body( \%mergedProperties );
|
$session->request->setup_body( \%mergedProperties );
|
||||||
|
|
||||||
ok(eval { $asset->www_editSave; }, 'www_editSave returns true'); # "DBD::mysql::db do failed: Duplicate entry ... for key 'PRIMARY' [for Statement "insert into assetData (assetId,revisionDate) values (?,?)"]" ... getting ready to insert into tables... assetId is: dinQXqxuUyrO0DmooZe4bg at /data/WebGUI/lib/WebGUI/AssetVersioning.pm line 123. XXX does that sleep 2 actually fix this or did I imagine that?
|
ok(eval { $asset->www_editSave; }, 'www_editSave returns true'); # "DBD::mysql::db do failed: Duplicate entry ... for key 'PRIMARY' [for Statement "insert into assetData (assetId,revisionDate) values (?,?)"]" ... getting ready to insert into tables... assetId is: dinQXqxuUyrO0DmooZe4bg at /data/WebGUI/lib/WebGUI/AssetVersioning.pm line 123. XXX does that sleep 2 actually fix this or did I imagine that?
|
||||||
|
|
|
||||||
Loading…
Add table
Add a link
Reference in a new issue