From 7eda8f7d46df25eb9a47c14e49561df3b9b3f199 Mon Sep 17 00:00:00 2001 From: Scott Walters Date: Tue, 10 Aug 2010 11:24:39 -0400 Subject: [PATCH] Numerous corrections to tests. Currently, "Looks like you failed 62 tests of 3882". Many transient, non-deterministic failures lurk and specific asset types need special cases added in test subclasses. --- t/tests/Test/WebGUI/Asset.pm | 214 ++++++++++++++++++++++++++++++----- 1 file changed, 187 insertions(+), 27 deletions(-) diff --git a/t/tests/Test/WebGUI/Asset.pm b/t/tests/Test/WebGUI/Asset.pm index 565c0a339..4187c9f4b 100644 --- a/t/tests/Test/WebGUI/Asset.pm +++ b/t/tests/Test/WebGUI/Asset.pm @@ -8,6 +8,10 @@ package Test::WebGUI::Asset; #------------------------------------------------------------------- # http://www.plainblack.com info@plainblack.com #------------------------------------------------------------------- + +use strict; +use warnings; + use base qw/My::Test::Class/; use Test::More; @@ -17,6 +21,28 @@ use WebGUI::Test; use WebGUI::Utility; use Data::Dumper; +sub debug { + + # if the last eval { } caught something, give full diagnostics on that and stop the tests. + # while working through these bugs in here, it does no good to run the test suite until completion after something blows up. + + my $e = Exception::Class->caught() or return; + my $line = (caller)[2]; + + if( Scalar::Util::blessed( $e ) ) { + note( $line . ': ' . $e->error . "\n" . $e->full_message . "\n" . $e->trace->as_string ); + } else { + note( $line . ': ' . "\n(non-object error:) $e" ); + } + + return; # XXX enable/disable aborting tests on failure + + warn "going to exit in ... a whole bunch... of seconds"; + sleep 10; + # system 'sleep 6000'; # sleep 10; # this way, we can control-c it! + exit; +} + sub assetUiLevel { return 1; } @@ -29,6 +55,29 @@ sub parent_list { return []; } +sub flattenFormObjects { + my $arr = shift; + my @result; + my @no_arrays = map { (ref $_ eq 'ARRAY') ? flattenFormObjects($_) : $_ } @$arr; + for my $formob (@no_arrays) { + if($formob->get('buttons')) { + push @result, flattenFormObjects( $formob->get('buttons') ); + } else { + push @result, $formob; + } + } + @result; +} + +sub formProperties { + my $asset = shift; + my %properties = + map { ( $_ => $asset->get($_) ) } + # map { [ $_ => $asset->getFormProperties($_) ] } + grep { ! $asset->meta->find_attribute_by_name( $_ )->noFormPost } $asset->getProperties; + return %properties; +} + sub getAnchoredAsset { my $test = shift; my $session = $test->session; @@ -37,6 +86,7 @@ sub getAnchoredAsset { my $asset = $parents[-1]->addChild({ className => $test->class, }, undef, undef, {skipNotification => 1, skipAutoCommitWorkflows => 1,}); + # warn "XXX getAnchoredAsset: created new asset of Id: " . $asset->getId . ' of type: ' . ref $asset; $tag->commit; foreach my $a ($asset, @parents) { $a = $a->cloneFromDb; @@ -53,7 +103,7 @@ sub getMyParents { my $default = WebGUI::Asset->getDefault($session); push @parents, $default; my $parent = $default; - foreach $parent_class (@{ $parent_classes }) { + foreach my $parent_class (@{ $parent_classes }) { my $new_parent = $parent->addChild({className => $parent_class}, undef, undef, {skipNotification => 1, skipAutoCommitWorkflows => 1,}); push @parents, $new_parent; $parent = $new_parent; @@ -67,14 +117,19 @@ sub _constructor : Test(4) { my $session = $test->session; my $asset = $test->class->new({session => $session}); - isa_ok $asset, $test->class; - isa_ok $asset->session, 'WebGUI::Session'; + note '=' x 80; + note "Constructor: CLASS " . $test->class; + note '=' x 80; + + isa_ok $asset, $test->class, "asset we created isa ``@{[ $test->class ]}''"; + isa_ok $asset->session, 'WebGUI::Session', "the session @{[ $test->class ]} we created isa WebGUI::Session"; is $asset->session->getId, $session->getId, 'asset was assigned the correct session'; note "calling new with no assetId throws an exception"; $asset = eval { WebGUI::Asset->new($session, ''); }; my $e = Exception::Class->caught; isa_ok $e, 'WebGUI::Error'; + undef $@; } @@ -82,7 +137,7 @@ sub t_00_class_dispatch : Test(2) { my $test = shift; my $session = $test->session; note "Class dispatch"; - my $asset = $test->class->new({session => $session}); + # my $asset = $test->class->new({session => $session}); my $asset = WebGUI::Asset->new({ session => $session, @@ -92,6 +147,9 @@ sub t_00_class_dispatch : Test(2) { isa_ok $asset, 'WebGUI::Asset'; is $asset->className, 'WebGUI::Asset', 'passing className is ignored'; + + debug($@); + undef $@; } sub t_00_get_tables : Test(1) { @@ -103,6 +161,9 @@ sub t_00_get_tables : Test(1) { $test->list_of_tables, 'Set of tables for properties is correct' ); + + debug($@); + undef $@; } sub t_00_getParent : Test(2) { @@ -127,6 +188,9 @@ sub t_00_getParent : Test(2) { $session->db->write("delete from asset where assetId like 'wg8TestAsset00000%'"); $session->db->write("delete from assetData where assetId like 'wg8TestAsset00000%'"); + + debug($@); + undef $@; } sub t_00_newByPropertyHashRef : Test(2) { @@ -137,6 +201,9 @@ sub t_00_newByPropertyHashRef : Test(2) { $asset = WebGUI::Asset->newByPropertyHashRef($session, {className => $test->class, title => 'The Shawshank Snippet'}); isa_ok $asset, $test->class; is $asset->title, 'The Shawshank Snippet', 'title is assigned from the property hash'; + + debug($@); + undef $@; } sub t_00_scan_properties : Test(1) { @@ -149,6 +216,9 @@ sub t_00_scan_properties : Test(1) { } ok !@undefined_tables, "all properties have tables defined" or diag "except these: ".join ", ", @undefined_tables; + + debug($@); + undef $@; } sub t_01_assetId : Test(4) { @@ -162,6 +232,9 @@ sub t_01_assetId : Test(4) { $asset = $test->class->new({ session => $session, assetId => '' }); ok !$session->id->valid($asset->assetId), 'blank assetId in constructor is okay??'; + + debug($@); + undef $@; } sub t_01_title : Test(6) { @@ -184,6 +257,8 @@ sub t_01_title : Test(6) { #is $asset->get('title'), $asset->title, '... get(title) works'; + debug($@); + undef $@; } sub t_01_menuTitle : Test(8) { @@ -220,6 +295,9 @@ sub t_01_menuTitle : Test(8) { menuTitle => 'menuTitle asset', }); is $asset->menuTitle, 'menuTitle asset', '... set via constructor'; + + debug($@); + undef $@; } sub t_01_uiLevel : Test(1) { @@ -228,6 +306,9 @@ sub t_01_uiLevel : Test(1) { note "uiLevel"; my $asset = $test->class->new({session => $session}); is $asset->uiLevel, $test->assetUiLevel, 'asset uiLevel check'; + + debug($@); + undef $@; } sub t_01_write_update : Test(8) { @@ -265,6 +346,9 @@ sub t_01_write_update : Test(8) { $session->db->write("delete from asset where assetId=?", [$testId]); $session->db->write("delete from assetData where assetId=?", [$testId]); + + debug($@); + undef $@; } sub t_05_cut_paste : Test(5) { @@ -276,11 +360,19 @@ sub t_05_cut_paste : Test(5) { is $asset->state, 'clipboard', 'asset state updated'; my $session_asset = $session->asset(); $session->asset($parents[-1]); - ok $asset->canPaste, 'canPaste: allowed to paste here'; - ok $parents[-1]->paste($asset->assetId), 'paste returns true when it pastes'; - $asset_prime = $asset->cloneFromDb; + ok eval { $asset->canPaste }, 'canPaste: allowed to paste here'; + debug($@); + undef $@; + ok eval { $parents[-1]->paste($asset->assetId) }, 'paste returns true when it pastes'; + debug($@); + undef $@; + my $asset_prime = eval { $asset->cloneFromDb }; + debug($@); + undef $@; is $asset_prime->state, 'published', 'asset state updated'; $session->asset($session_asset); + debug($@); + undef $@; } sub t_05_keywords : Test(3) { @@ -291,6 +383,8 @@ sub t_05_keywords : Test(3) { $asset->keywords('chess set'); is $asset->keywords, 'chess set', 'set and get of keywords via direct accessor'; is $asset->get('keywords'), 'chess set', 'via get method'; + debug($@); + undef $@; } sub t_05_purge : Test(3) { @@ -300,12 +394,15 @@ sub t_05_purge : Test(3) { my ($tag, $asset, @parents) = $test->getAnchoredAsset(); my @tables = $asset->meta->get_tables; ok $asset->purge, 'purge returns true if it was purged'; - throws_ok { WebGUI::Asset->newById($session, $asset->assetId); } 'WebGUI::Error::InvalidParam', 'Unable to fetch asset by assetId now'; + throws_ok { WebGUI::Asset->newById($session, $asset->assetId); } 'WebGUI::Error::InvalidParam', 'Unable to fetch asset by assetId now'; + undef $@; # or else Test::Class barfs my $exists_in_table = 0; foreach my $table (@tables) { $exists_in_table ||= $session->db->quickScalar("select count(*) from `$table` where assetId=?",[$asset->assetId]); } ok ! $exists_in_table, 'assetId removed from all asset tables'; + debug($@); + undef $@; } sub t_10_addRevision : Tests { @@ -319,9 +416,11 @@ sub t_10_addRevision : Tests { isa_ok( $newRevision, Scalar::Util::blessed( $asset ), "addRevision returns new revision of asset object" ); is( $newRevision->title, "Newly Revised Title", "properties set correctly" ); is( $newRevision->revisionDate, $asset->revisionDate+2, 'revisionDate set correctly' ); - is( $newRevision->tagId, $tag->getId, "Added to existing working tag" ); + is( $newRevision->tagId, $tag->getId, "Added to existing working tag" ); # XXX failing for WebGUI::Asset::MapPoint $newRevision->purgeRevision; + debug($@); + undef $@; } sub t_11_getEditForm : Tests { @@ -336,7 +435,7 @@ sub t_11_getEditForm : Tests { # assetId, className, keywords isa_ok( $f->getTab('meta')->getField('assetId'), 'WebGUI::Form::Guid' ); - isa_ok( $f->getTab('meta')->getField('class'), 'WebGUI::Form::ClassName' ); + isa_ok( $f->getTab('meta')->getField('className'), 'WebGUI::Form::ClassName' ); isa_ok( $f->getTab('meta')->getField('keywords'), 'WebGUI::Form::Keywords' ); # Tabs @@ -345,22 +444,60 @@ sub t_11_getEditForm : Tests { isa_ok( $f->getTab('security'), 'WebGUI::FormBuilder::Tab' ); isa_ok( $f->getTab('meta'), 'WebGUI::FormBuilder::Tab' ); - # Properties - my $properties = map { !$asset->meta->find_attribute_by_name( $_ )->noFormPost } $asset->getProperties; - use Data::Dumper; - note( Dumper $f->getFieldsRecursive ); - exit; - cmp_deeply( - $f->getFieldsRecursive, - bag( map { superhashof( $asset->getFormProperties( $_ ) ) } @$properties ), - ); - # Metadata # Property overrides - ok( !$f->getField('func'), 'form must not contain "func"' ); + # Properties + use Data::Dumper; + + # note( "f: " . Dumper $f->getFieldsRecursive ); + + # $asset->getProperties vs $asset->getEditForm->getFieldsRecursive + + my @properties = grep { ! $asset->meta->find_attribute_by_name( $_ )->noFormPost } $asset->getProperties; + @properties = map { $asset->getFormProperties($_) } @properties; + + my @form = flattenFormObjects($f->getFieldsRecursive); # mixture of arrays of Form objects and arrays-of-arrays of them; flatten it out + @form = map $_->{_params}, @form; # hash with label, uiLevel, hoverHelp, tab, etc fields in it # XXX API method rather than peeking + + # Missing: 40 references + # Extra: 28 references + # cmp_deeply( + # [ map { $asset->getFormProperties($_) } @properties ], + # bag( map { superhashof($_) } @form ), + # 'getProperties agrees with getEditForm->getFieldsRecursive', + # ); + + # Missing: 25 references + # Extra: 37 references + # cmp_deeply( + # \@form, + # bag( map { superhashof($asset->getFormProperties($_)) } @properties ), + # 'getProperties agrees with getEditForm->getFieldsRecursive', + # ); + + my %superlist = map { ( $_->{label} => 1 ) } grep { $_->{label} } @form, @properties; + note "all labels: " . join ', ', keys %superlist; + + for my $label (keys %superlist) { + no warnings 'uninitialized'; + note "label ``$label'' not in properties" if ! grep { $_->{label} eq $label } @properties; + 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( + [ sort { $a cmp $b } map { $_->{label} } @form ], + [ sort { $a cmp $b } map { $_->{label} } @properties ], + 'getProperties agrees with getEditForm->getFieldsRecursive', + ); + + debug($@); + undef $@; + } sub t_20_www_editSave : Tests { @@ -374,22 +511,45 @@ sub t_20_www_editSave : Tests { $asset->groupIdEdit( 7 ); # Everybody! Everybody! $tag->setWorking; - $session->request->setup_body({ - title => "Newly Saved Title", - }); - $asset->www_editSave; + +# $tag = WebGUI::VersionTag->create($session, {}); $tag->setWorking; # XXXXXX +sleep 2; # also XXXX + + # warn "XXX formProperties: " . Dumper [ formProperties($asset) ]; + + my %mergedProperties = ( + formProperties($asset), + title => "Newly Saved Title", + ); + + $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? + debug($@); + undef $@; # Get the newly-created revision of the asset - my $newRevision = WebGUI::Asset->newPending( $session, $asset->getId ); + ok( my $newRevision = eval { WebGUI::Asset->newPending( $session, $asset->getId ); }, 'newPending returns true' ); + debug($@); + undef $@; + ok( $newRevision->tagId, 'new revision has a tag' ); is( $newRevision->tagId, $tag->getId, 'new revision tagId is current working tag' ); + if( $mergedProperties{templateId} ) { + is( $newRevision->templateId, $mergedProperties{templateId}, 'new revision has the corret templateId' ); + } # Alter permissions so it does not work + # XXX todo? # Set locked so it does not work + # XXX todo? - $asset->groupIdEdit( $oldGroupId ); + eval { $asset->groupIdEdit( $oldGroupId ); }; + + debug($@); + undef $@; } 1;