File Coverage

blib/lib/HTML/Mason/Tests.pm

Criterion	Covered	Total	%
statement	221	254	87.0
branch	92	154	59.7
condition	22	51	43.1
subroutine	36	38	94.7
pod	8	12	66.6
total	379	509	74.4

package HTML::Mason::Tests;
$HTML::Mason::Tests::VERSION = '1.59';
use strict;
use warnings;

use Cwd;

use File::Path;
use File::Spec;

use HTML::Mason;
use HTML::Mason::Compiler::ToObject;

use Getopt::Long;

use Test::Builder ();

use vars qw($VERBOSE $DEBUG @SHARED);

my $Test = Test::Builder->new;

$VERBOSE = $ENV{MASON_DEBUG} || $ENV{MASON_VERBOSE} || $ENV{TEST_VERBOSE};
$DEBUG = $ENV{MASON_DEBUG};

$| = 1;

@SHARED = ( { path => '/shared/check_error',
              component => <<'EOF',
<% ($error) ? "Error: $error" : "No error!?" %>
<%init>
if ($error) {
  my @lines = split("\n",$error);
  $error = join("\n",@lines[0..$lines-1]);
  $error =~ s{\s+at .*}{}g;
}

<%args>
$error
$lines=>1

EOF
            },
            { path => '/shared/display_comp_obj',
              component => <<'EOF',
Declared args:
% my %decl = %{$comp->declared_args};
% foreach (sort keys %decl) {
<% $_ %><% (defined($decl{$_}->{default})) ? "=>".$decl{$_}->{default} : "" %>
% }

I am <% $comp->is_subcomp ? '' : 'not ' %>a subcomponent.
I am <% $comp->is_method ? '' : 'not ' %>a method.
I am <% $comp->is_file_based ? '' : 'not ' %>file-based.
% if (defined($comp->name)) {
My short name is <% $comp->name =~ /anon/ ? '[anon something]' : $comp->name %>.
% }
% if ($comp->is_subcomp and defined($comp->owner)) {
My parent component is <% $comp->owner->title %>.
% }
% if (defined($comp->dir_path)) {
My directory is <% $comp->dir_path %>.
% }
% my @subkeys = sort keys(%{$comp->subcomps});
I have <% scalar(@subkeys) %> subcomponent(s).
% if (@subkeys) {
Including one called <% $comp->subcomps($subkeys[0])->name %>.
% }
My title is <% $comp->title =~ /anon/ ? '[anon something]' : $comp->title %>.

% if (defined($comp->path)) {
My path is <% $comp->path %>.
% }
% if (defined($comp->comp_id)) {
My comp_id is <% $comp->comp_id =~ /anon/ ? '[anon something]' : $comp->comp_id %>.
% }
<%args>
$comp

EOF
            },
            { path => '/shared/display_req_obj',
              component => <<'EOF',
My depth is <% $m->depth %>.

I <% $m->is_subrequest ? 'am' : 'am not' %> a subrequest.

The top-level component is <% $m->request_comp->title %>.

My stack looks like:
-----
% foreach my $comp ($m->callers) {
<% $comp->title %>
% }
-----

EOF
            },
          );

#
# Get command options here so that we read tests_class before user
# calls new().
#
my %cmd_options;
GetOptions( 'create' => \$cmd_options{create},
            'tests-to-run=s' => \$cmd_options{tests_to_run},
            'tests-to-skip=s' => \$cmd_options{tests_to_skip},
            'tests-class=s' => \$cmd_options{tests_class},
            );

#
# Allow options to be passed in the environment as well.
#
$cmd_options{tests_to_run} = $ENV{MASON_TESTS_TO_RUN}
    if !defined($cmd_options{tests_to_run}) and defined($ENV{MASON_TESTS_TO_RUN});
$cmd_options{tests_to_skip} = $ENV{MASON_TESTS_TO_SKIP}
    if !defined($cmd_options{tests_to_skip}) and defined($ENV{MASON_TESTS_TO_SKIP});
$cmd_options{tests_class} = $ENV{MASON_TESTS_CLASS}
    if !defined($cmd_options{tests_class}) and defined($ENV{MASON_TESTS_CLASS});

# If user specifies tests_class, load that package; otherwise,
# default it to this package.
if (defined($cmd_options{tests_class})) {
    eval "use $cmd_options{tests_class}";
    die $@ if $@;
} else {
    $cmd_options{tests_class} = __PACKAGE__;
}

my %tests_to_run;
if ($cmd_options{tests_to_run}) {
    for ($cmd_options{tests_to_run}) { s/^\s+//; s/\s+$// }
    my @tests_to_run = split(/\s*,\s*/, $cmd_options{tests_to_run});
    if (grep { /[^0-9]/ } @tests_to_run) {
        @tests_to_run = sort { $a cmp $b } @tests_to_run;
    } else {
        @tests_to_run = sort { $a <=> $b } @tests_to_run;
    }
    %tests_to_run = map { ($_, 1) } @tests_to_run;
    $Test->diag(sprintf("Running only test%s %s\n", @tests_to_run == 1 ? "" : "s", join(", ", @tests_to_run)))
}

my %tests_to_skip;
if ($cmd_options{tests_to_skip}) {
    for ($cmd_options{tests_to_skip}) { s/^\s+//; s/\s+$// }
    my @tests_to_skip = split(/\s*,\s*/, $cmd_options{tests_to_skip});
    %tests_to_skip = map { ($_, 1) } @tests_to_skip;
    $Test->diag(printf ("Skipping test%s %s\n", @tests_to_skip == 1 ? "" : "s", join(", ", @tests_to_skip)));
}

sub new
{
    my $class = shift;
    my %p = (@_, %cmd_options);

    die "No group name provided\n"
        unless exists $p{name};

    die "No description for test group provided\n"
        unless exists $p{description};

    $p{pre_test_cleanup} = 1
        unless exists $p{pre_test_cleanup};

    return bless {
                  %p,
                  support => [],
                  tests => [],
                 }, $class;
}

# Returns the tests class to use for class methods - defaults to this package.
sub tests_class
{
    return $cmd_options{tests_class};
}

sub add_support
{
    my $self = shift;
    my %p = @_;

    die "'support' key array member contains no 'path' key\n"
        unless exists $p{path};

    die "'support' key array member contains no 'component' key\n"
        unless exists $p{component};

    push @{ $self->{support} }, \%p;
}

sub add_test
{
    my $self = shift;
    my %p = @_;

    die "no name provided for test\n"
        unless exists $p{name};

    unless ( exists $p{path} )
    {
        $p{path} = $p{call_path} || $p{name};
    }

    my $call_path = "/$self->{name}";
    if ( exists $p{call_path} )
    {
        $call_path .= '/' unless substr( $p{call_path}, 0, 1 ) eq '/';
        $call_path .= $p{call_path};
    }
    else
    {
        $call_path .= '/' . $p{name};
    }
    $p{call_path} = $call_path;

    if ( ref($p{call_args}) eq 'HASH' )
    {
        my @lst = %{$p{call_args}};
        $p{call_args} = \@lst;
    }
    elsif ( !exists($p{call_args}) ) {
        $p{call_args} = [];
    }

    die "'$p{name}' test has no description\n"
        unless exists $p{description};

    die "'$p{name}' test has no component\n"
        unless exists $p{component} || $p{skip_component};

    die "'$p{name}' test has no 'expect' or 'expect_error' key\n"
        unless exists $p{expect} || exists $p{expect_error} || $p{skip_expect} || $self->{create};

    foreach ( qw( interp_params ) )
    {
        die "$_ must be a hash reference"
            if exists $p{$_} && ! UNIVERSAL::isa( $p{$_}, 'HASH' );
    }

    push @{ $self->{tests} }, \%p;
}

sub run
{
    my $self = shift;

    die "No tests exist in this group"
        unless @{ $self->{tests} };

    if ($DEBUG)
    {
        $Test->diag( "Will " . ( $self->{create} ? '' : 'not ' ) . "create 'expect' files\n" );
    }

    eval
    {
        # 1 indicates to be silent on missing directories
        $self->_cleanup(1) if $self->{pre_test_cleanup};
        $self->_make_dirs;
        $self->_write_shared_comps;
        $self->_write_support_comps;
        $self->_run_tests;
    };

    $self->_cleanup unless $ENV{MASON_NO_CLEANUP};

    die $@ if $@;
}

sub _make_dirs
{
    my $self = shift;

    my $comp_root = $self->comp_root;
    my $data_dir = $self->data_dir;

    unless ( -d $self->comp_root )
    {
        $Test->diag( "Making comp_root directory: $comp_root\n" ) if $DEBUG;
        mkpath( $self->comp_root, 0, 0755 )
            or die "Unable to make base test directory '$comp_root': $!";
    }

    unless ( -d $self->data_dir )
    {
        $Test->diag( "Making data_dir directory: $data_dir\n" ) if $DEBUG;
        mkpath( $self->data_dir, 0, 0755 )
            or die "Unable to make base test directory '$data_dir': $!";
    }
}

sub base_path
{
    my $proto = shift;

    if (ref $proto)
    {
        $proto->{base_path} ||= File::Spec->catdir( cwd(), 'mason_tests', $$ );
        return $proto->{base_path};
    }
    else
    {
        return File::Spec->catdir( cwd(), 'mason_tests', $$ );
    }
}

sub comp_root
{
    my $proto = shift;

    return File::Spec->catdir( $proto->base_path, 'comps' );
}

sub data_dir
{
    my $proto = shift;

    return File::Spec->catdir( $proto->base_path, 'data' );
}

sub _write_shared_comps
{
    my $self = shift;

    return unless @SHARED;

    foreach my $comp ( @SHARED )
    {
        my @path = split m(/), $comp->{path};
        my $file = pop @path;

        my $dir = File::Spec->catdir( $self->comp_root, @path );

        $self->write_comp( $comp->{path}, $dir, $file, $comp->{component} );
    }
}

sub _write_support_comps
{
    my $self = shift;

    unless ( @{ $self->{support} } )
    {
        $Test->diag( "No support comps to create\n" ) if $DEBUG;
        return;
    }

    foreach my $supp ( @{ $self->{support} } )
    {
        my @path = split m(/), $supp->{path};
        my $file = pop @path;

        my $dir = File::Spec->catdir( $self->comp_root, $self->{name}, @path );

        $self->write_comp( $supp->{path}, $dir, $file, $supp->{component} );
    }
}

sub _write_test_comp
{
    my $self = shift;
    my $test = $self->{current_test};

    my @path = split m(/), $test->{path};
    my $file = pop @path;

    my $dir = File::Spec->catdir( $self->comp_root, $self->{name}, @path );
    unless ( -d $dir )
    {
        $Test->diag( "Making dir: $dir\n" ) if $DEBUG;
        mkpath( $dir, 0, 0755 )
            or die "Unable to create directory '$dir': $!";
    }

    $self->write_comp( $test->{path}, $dir, $file, $test->{component} );
}

sub write_comp
{
    my $self = shift;
    my ($path, $dir, $file, $component) = @_;

    unless (-d $dir)
    {
        $Test->diag( "Making dir: $dir\n" ) if $DEBUG;
        mkpath( $dir, 0, 0755 )
            or die "Unable to create directory '$dir': $!";
    }

    my $real_file = File::Spec->catfile( $dir, $file );

    $Test->diag( "Making component $path at $real_file\n" )
        if $DEBUG;

    open my $fh, ">$real_file"
        or die "Unable to write to '$real_file': $!";
    print $fh $component
        or die "Unable to write to '$real_file': $!";
    close $fh
        or die "Unable to write to '$real_file': $!";
}

sub _run_tests
{
    my $self = shift;

    my $count = scalar @{ $self->{tests} };
    $Test->plan( tests => $count );

    if ($VERBOSE)
    {
        $Test->diag( "Running $self->{name} tests ($count tests): $self->{description}\n" );
    }

    my $x = 1;
    foreach my $test ( @{ $self->{tests} } )
    {
        $self->{current_test} = $test;

        #
        # If tests_to_run or tests_to_skip were specified in the
        # environment or command line, check them to see whether to
        # run the test.
        #
        if (%tests_to_run or %tests_to_skip) {

            # Look for any of the specs [test_file_name:](test_number|test_name|*)
            my $wildcard_name = join(":", $self->{name}, "*");
            my $full_name = join(":", $self->{name}, $test->{name});
            my $full_number = join(":", $self->{name}, $x);
            my @all_specs = ($x, $test->{name}, $full_name, $full_number, $wildcard_name);

            # If our test isn't mentioned in %tests_to_run or is
            # mentioned in %tests_to_skip, skip it.
            #
            if ((%tests_to_run and !(grep { $tests_to_run{$_} } @all_specs))
                or (%tests_to_skip and (grep { $tests_to_skip{$_} } @all_specs))) {

                # Use presence of PERL_DL_NONLAZY to decide if we are
                # running inside "make test", and if so, actually
                # print the appropriate skip response to comply with the
                # Test::Harness standard. If the user is running the
                # test by hand, this would just be clutter.
                #
                # Checking PERL_DL_NONLAZY is a hack but I don't
                # know of a better detection method.
                #
                $self->_skip if ($ENV{PERL_DL_NONLAZY});
                $x++;
                next;
            }
        }
        $Test->diag( "Running $test->{name} (#$x): $test->{description}\n" ) if $VERBOSE;
        $self->_make_component unless $test->{skip_component};
        $self->_run_test;
        $x++;
    }
}

sub _make_component
{
    my $self = shift;
    my $test = $self->{current_test};
    $self->_write_test_comp;
}

sub _make_main_interp
{
    my $self = shift;
    my $test = $self->{current_test};
    return $test->{interp} if $test->{interp};

    my %interp_params = ( exists $test->{interp_params} ?
                          %{ $test->{interp_params} } :
                          () );

    if ($DEBUG && %interp_params)
    {
        $Test->diag( "Interp params:\n" );
        while ( my ($k, $v) = each %interp_params)
        {
            $Test->diag( "  $k => $v\n" );
        }
    }

    return $self->_make_interp ( comp_root => $self->comp_root,
                                 data_dir  => $self->data_dir,
                                 %interp_params );
}

sub _make_interp
{
    my ($class, %interp_params) = @_;

    return HTML::Mason::Interp->new( %interp_params );
}

sub _run_test
{
    my $self = shift;
    my $test = $self->{current_test};

    $self->{buffer} = '';
    my $interp = $self->_make_main_interp;
    $interp->out_method( sub { for (@_) { $self->{buffer} .= $_ if defined $_ } } );

    my $warnings = '';
    local $SIG{__WARN__} = sub { $warnings .= $_ for @_ };
    eval {
        # Run pre_code if test has it - pass in interp
        if ($test->{pre_code}) {
            $test->{pre_code}->($interp);
        }
        $self->_execute($interp);
    };

    return $self->check_result($@, $warnings);
}

sub _execute
{
    my ($self, $interp) = @_;
    my $test = $self->{current_test};

    $Test->diag( "Calling $test->{name} test with path: $test->{call_path}\n" ) if $DEBUG;
    $test->{pretest_code}->() if $test->{pretest_code};
    $interp->exec( $test->{call_path}, @{$test->{call_args}} );
}

sub check_result {
    my ($self, $error, $warnings) = @_;
    my $test = $self->{current_test};

    local $HTML::Mason::Tests::TODO = $self->{current_test}{todo}
        if exists $self->{current_test}{todo};
    $Test->todo if exists $self->{current_test}{todo};

    if ($error)
    {
        if ( $test->{expect_error} )
        {
            if ( $error =~ /$test->{expect_error}/ )
            {
                return $self->_success
            }
            else
            {
                if ($VERBOSE)
                {
                    $Test->diag( "Got error:\n$error\n...but expected something matching:\n$test->{expect_error}\n" );
                }
                return $self->_fail;
            }
        }
        else
        {
            $Test->diag( "Unexpected error running $test->{name}:\n$error" ) if $VERBOSE;
            return $self->_fail;
        }

    }
    elsif ( $test->{expect_error} )
    {
        $Test->diag( "Expected an error matching '$test->{expect_error}' but no error occurred - got successful output:\n$self->{buffer}\n" ) if $VERBOSE;
        return $self->_fail;
    }

    if ($self->{create})
    {
        $Test->diag( "Results for $test->{name}:\n$self->{buffer}\n" );
        return;
    }

    my $success =
        ( $test->{skip_expect} ?
          1 :
          $self->check_output( actual => $self->{buffer}, expect => $test->{expect} )
        );

    if ( $test->{expect_warnings} )
    {
        unless ( $warnings =~ /$test->{expect_warnings}/ )
        {
            $Test->diag( "Got warnings:\n$warnings\n...but expected something matching:\n$test->{expect_warnings}\n" );
            $success = 0;
        }
    }

    $Test->diag( "Got warnings: $warnings" ) if $warnings && ( ! $test->{expect_warnings} || $VERBOSE );
    $success = 0 if $test->{no_warnings} && $warnings;

    $success ? $self->_success : $self->_fail;
}

sub check_output
{
    my ($self, %p) = @_;

    my $same;

    # Allow a regex for $p{expect}
    if (ref $p{expect}) {
        $same = ($p{actual} =~ /$p{expect}/);

    } else {
        # Whitespace at end can vary.  (Or rather, it is varying in the tests, and
        # should be made not to vary, but I don't have time to fix it yet.)

        for ($p{actual}, $p{expect}) {  s/\s+$//  }
        $same = ($p{actual} eq $p{expect});
    }

    if (!$same and $VERBOSE) {
        $Test->diag( "Got ...\n-----\n$p{actual}\n-----\n   ... but expected ...\n-----\n$p{expect}\n-----\n" );
    }
    return $same;
}

sub _fail
{
    my $self = shift;
    my $test = $self->{current_test};

    $Test->ok( 0, $test->{name} );
}

sub _success
{
    my $self = shift;
    my $test = $self->{current_test};

    $Test->ok( 1, $test->{name} );
}

sub _skip
{
    my $self = shift;
    my $test = $self->{current_test};

    $Test->skip;
}

#
# We use our own rm_tree, rather than File::Path::rmtree, so that we
# can silently fail to entirely remove directories. On some systems
# .nfs files prevent total removal of directories but should not
# otherwise interfere with tests.
#
sub rm_tree {
    my ($path, $debug, $silent) = @_;
    $path =~ s#/$##;
    if (-d $path) {
        local *DIR;
        opendir DIR, $path or warn "Can't open $path: $!";
        while (defined(my $file = readdir DIR)) {
            next if $file eq '.' or $file eq '..';
            rm_tree("$path/$file");
        }
        closedir DIR;
        rmdir $path;
    } elsif (-f $path) {
        unlink $path;
    } else {
        $Test->diag( "Can't find $path to remove" )
            unless $silent;
    }
}

sub _cleanup
{
    my $self = shift;

    rm_tree( $self->base_path, $DEBUG, @_ );
}

1;

__END__