webgui-abuse.pl

#-------------------------------------------------------------------
# WebGUI is Copyright 2010 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 strict;
use warnings;

=for comment

Abuse WebGUI by creating random arrangements of assets.

cp webgui-abuse.pl /data/WebGUI8/t/tests/Test/WebGUI/ # paste-bait for self; to run

TODO:

v/ Copy runtests() and modify it to work in our own package
o. Rather than calling each subclass once and in order, run forever and continiously randomly pick one
v/ Pick a random node to be the parent rather than the previous behavior, which is to ask session for the default asset
o. Call view() in the randomly selected parent after the tests to see if it can cope with its new child
o. Call view() on every asset in the tree after each batch of tests?  getLineage() already instantiates every asset in the system.
o. Think of other sanity tests we can run on the asset tree; look over findBrokenAssets.pl for ideas and perhaps call into it
o. Fix the path hard-code; use $ENV{WEBGUI_CONFIG} ?
o. Actively counteract future measures taken by Test::WebGUI::Asset to cleanup test-temp assets
o. Trap failures on addChild() to be tolerant of assets blocking improper addition of children

=cut

use File::Spec::Functions qw( catdir rel2abs );
use File::Basename qw( dirname );
# use Test::Class::Load rel2abs( catdir ( '..', '..', dirname( __FILE__ ), 'tests' ) ); # XXX fix
use Test::Class::Load '/data/WebGUI8/t/tests';

#
#
#

local *Test::WebGUI::Asset::getAnchoredAsset = \&getAnchoredAsset;
runtests();

#
#
#

sub runtests {
    # modified version of Test::Class::runtests
    my @tests = @_;
    # ...
    @tests = Test::Class::_test_classes( 'Test::WebGUI::Asset' );
    my $Builder = Test::Class->builder() or die;
    my $all_passed = 1;
  TEST_OBJECT: 
    while(1) {
            my $t = $tests[int rand @tests];
            $t = $t->new unless ref($t);
            foreach my $method (Test::Class::_get_methods($t, Test::Class::STARTUP)) {
                Test::Class::_show_header($t, @tests) unless Test::Class::_has_no_tests($t, $method);
                my $method_passed = Test::Class::_run_method($t, $method, \@tests);
                $all_passed = 0 unless $method_passed;
                next TEST_OBJECT unless $method_passed;
            my $class = ref($t);
            my @setup    = Test::Class::_get_methods($t, Test::Class::SETUP);
            my @teardown = Test::Class::_get_methods($t, Test::Class::TEARDOWN);
            foreach my $test (Test::Class::_get_methods($t, Test::Class::TEST)) {
                local $Test::Class::Current_method = $test;
                $Builder->diag("\n$class->$test") if $ENV{TEST_VERBOSE};
                foreach my $method (@setup, $test, @teardown) {
                    Test::Class::_show_header($t, @tests) unless Test::Class::_has_no_tests($t, $method);
                    $all_passed = 0 unless Test::Class::_run_method($t, $method, \@tests);
                };
            };    
            foreach my $method (Test::Class::_get_methods($t, Test::Class::SHUTDOWN)) {
                Test::Class::_show_header($t, @tests) unless Test::Class::_has_no_tests($t, $method);
                $all_passed = 0 unless Test::Class::_run_method($t, $method, \@tests);
            }
        }
    }
    return($all_passed);
};  

#
#
#

sub getAnchoredAsset {
    my $test    = shift;
    my $session = $test->session or die;
    my $tag     = WebGUI::VersionTag->getWorking($session);
    my @parents = $test->main::getMyParents;
    my $asset   = $parents[-1]->addChild({
        className => $test->class,
        $test->constructorExtras($session),
    }, 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;
    }
    WebGUI::Test->addToCleanup($tag);
    return ($tag, $asset, @parents);
}

sub getMyParents {
    my $test           = shift;
    my $session        = $test->session;
    my $parent_classes = $test->parent_list;
    my @parents        = ();

    # my $default        = WebGUI::Asset->getDefault($session); # nope, pick a random asset instead:

    my $assets = WebGUI::Asset->getRoot($session)->getLineage(['descendants'], {returnObjects=>1});
    my $default = $assets->[ int rand @$assets ];

warn "randomly selected parent: " . ref($default) . ' title: ``' . $default->get('title') . "''";

    push @parents, $default;
    my $parent = $default;
    foreach my $parent_class (@{ $parent_classes }) {
        my $new_parent = $parent->addChild(
            {className => $parent_class, $test->constructorExtras($session), },
            undef,
            undef,
            {skipNotification => 1, skipAutoCommitWorkflows => 1,},
        );
        push @parents, $new_parent;
        $parent = $new_parent;
        WebGUI::Test->addToCleanup($new_parent);
    }
    return @parents;
}