The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl -w
use strict;

use HTML::Mason::Tests;

my $tests = make_tests();
$tests->run;

sub make_tests
{
    my $group = HTML::Mason::Tests->tests_class->new( name => 'interp-mcr',
                                                      description => 'In-depth testing of multiple component roots' );

    $group->add_test( name           => 'no_dynamic_comp_root',
                      description    => 'change comp root without dynamic_comp_root',
                      pre_code       => sub {
                          my ($interp) = @_;
                          $interp->comp_root($group->data_dir);
                      },
                      skip_component => 1,
                      call_path      => '/',
                      expect_error   => qr/cannot assign new comp_root/,
                      );

    $group->add_test( name           => 'change_single_comp_root',
                      description    => 'change single root',
                      interp_params  => {comp_root => '/usr/local/foo',
                                         dynamic_comp_root => 1},
                      pre_code       => sub {
                          my ($interp) = @_;
                          $interp->comp_root('/usr/local/bar');
                      },
                      skip_component => 1,
                      call_path      => '/',
                      expect_error   => qr/was originally associated with .*, cannot change/,
                      );

    $group->add_test( name           => 'reuse_comp_root_key',
                      description    => 'change comp root key mapping',
                      interp_params  => {comp_root => [['foo' => '/usr/local/foo'],
                                                       ['bar' => '/usr/local/bar']],
                                         dynamic_comp_root => 1},
                      pre_code       => sub {
                          my ($interp) = @_;
                          $interp->comp_root([['foo' => '/usr/local/foo'],
                                              ['bar' => '/usr/local/baz']]),
                      },
                      skip_component => 1,
                      call_path      => '/',
                      expect_error   => qr/was originally associated with .*, cannot change/,
                      );

    # For each test below, change the interpreter's component root on
    # the fly, then make sure the right versions of /foo and /bar/ are
    # being loaded.  Also occasionally remove a component to make sure
    # that the next one gets loaded. Run with both static_source=0 and
    # static_source=1.
    #

    foreach my $static_source (0, 1) {
        my $interp = $group->_make_interp ( comp_root         => $group->comp_root,
                                            data_dir          => $group->data_dir,
                                            static_source     => $static_source,
                                            dynamic_comp_root => 1,
                                          );
        
        foreach my $root (1..4) {
            $group->add_support( path => "/$root/interp-mcr/$static_source/foo",
                                 component => "I am $root/foo, <& bar &>",
                               );
        }
        foreach my $root (7..8) {
            $group->add_support( path => "/$root/interp-mcr/$static_source/bar",
                                 component => "I am $root/bar",
                               );
        }

        my $make_test_for_roots = sub
        {
            my ($keys, %params) = @_;
            my $test_name = "test" . join('', @$keys) . "-" . $static_source;

            $group->add_test( name => $test_name,
                              description => "test roots assigned to " . join(", ", @$keys) . ", static_source=$static_source",
                              skip_component => 1,
                              interp => $interp,
                              pre_code => sub {
                                  $interp->comp_root([map { [$_, $group->comp_root . "/interp-mcr/$_"] } @$keys]);
                                  if ($params{remove}) {
                                      foreach my $comp (qw(foo bar)) {
                                          unlink("mason_tests/$$/comps/interp-mcr/$params{remove}/interp-mcr/$static_source/$comp");
                                      }
                                  }
                              },
                              call_path => "/$static_source/foo",
                              %params
                            );
        };

        $make_test_for_roots->([1, 7],           expect=>'I am 1/foo, I am 7/bar');
        $make_test_for_roots->([1, 2, 3, 4, 8],  expect=>'I am 1/foo, I am 8/bar');
        if ($static_source) {
            $make_test_for_roots->([1, 2, 3, 7], remove=>'1', expect=>'I am 1/foo, I am 7/bar');
        } else {
            $make_test_for_roots->([1, 2, 3, 7], remove=>'1', expect=>'I am 2/foo, I am 7/bar');
        }
        $make_test_for_roots->([2, 3, 4, 7],     expect=>'I am 2/foo, I am 7/bar');
        $make_test_for_roots->([5, 4, 2, 3, 8],  expect=>'I am 4/foo, I am 8/bar');
        $make_test_for_roots->([5, 6],           expect_error => qr/could not find component/);
        $make_test_for_roots->([1, 2, 3, 4],     expect_error => qr/could not find component/);
    }

    return $group;
}