libmason-perl 2.21-1 / usr / share / perl5 / Mason / Test / Class.pm

package Mason::Test::Class;
{
  $Mason::Test::Class::VERSION = '2.21';
}
use Carp;
use File::Basename;
use File::Path;
use File::Temp qw(tempdir);
use Mason;
use Mason::Util qw(trim write_file);
use Method::Signatures::Simple;
use Test::Class::Most;
use Test::LongString;
use Class::Load;
use strict;
use warnings;

__PACKAGE__->SKIP_CLASS("abstract base class");

# RO accessors
sub comp_root { $_[0]->{comp_root} }
sub data_dir  { $_[0]->{data_dir} }
sub interp    { $_[0]->{interp} }
sub temp_dir  { $_[0]->{temp_dir} }
sub temp_root { $_[0]->{temp_root} }

# RW class accessors
my $default_plugins = [];
sub default_plugins { $default_plugins = $_[1] if defined( $_[1] ); $default_plugins; }

my $gen_path_count = 0;
my $parse_count    = 0;
my $temp_dir_count = 0;

our $current_test_object;

sub _startup : Test(startup) {
    my $self    = shift;
    my $verbose = $ENV{TEST_VERBOSE};
    $self->{temp_root} = tempdir( 'mason-test-XXXX', TMPDIR => 1, CLEANUP => $verbose ? 0 : 1 );
    printf STDERR ( "\n*** temp_root = %s, no cleanup\n", $self->{temp_root} ) if $verbose;
    $self->setup_dirs;
}

method setup_dirs () {
    $self->{temp_dir}  = join( "/", $self->{temp_root}, $temp_dir_count++ );
    $self->{comp_root} = $self->{temp_dir} . "/comps";
    $self->{data_dir}  = $self->{temp_dir} . "/data";
    mkpath( [ $self->{comp_root}, $self->{data_dir} ], 0, 0775 );
    $self->setup_interp(@_);
}

method setup_interp () {
    $self->{interp} = $self->create_interp(@_);
}

method create_interp () {
    my (%params) = @_;
    $params{plugins} = $default_plugins if @$default_plugins;
    my $mason_root_class = delete( $params{mason_root_class} ) || 'Mason';
    Class::Load::load_class($mason_root_class);
    rmtree( $self->data_dir );
    return $mason_root_class->new(
        comp_root => $self->comp_root,
        data_dir  => $self->data_dir,
        %params,
    );
}

method add_comp (%params) {
    $self->_validate_keys( \%params, qw(path src v verbose) );
    my $path    = $params{path} || die "must pass path";
    my $source  = $params{src}  || " ";
    my $verbose = $params{v}    || $params{verbose};
    die "'$path' is not absolute" unless substr( $path, 0, 1 ) eq '/';
    my $source_file = $self->comp_root . $path;
    $self->mkpath_and_write_file( $source_file, $source );
    if ($verbose) {
        print STDERR "*** $path ***\n";
        my $output = $self->interp->_compile( $source_file, $path );
        print STDERR "$output\n";
    }
}

method remove_comp (%params) {
    my $path = $params{path} || die "must pass path";
    my $source_file = join( "/", $self->comp_root, $path );
    unlink($source_file);
}

method _gen_comp_path () {
    my $caller        = ( caller(2) )[3];
    my ($caller_base) = ( $caller =~ /([^:]+)$/ );
    my $path          = "/$caller_base" . ( ++$gen_path_count ) . ".mc";
    return $path;
}

method test_comp (%params) {
    my $path    = $params{path} || $self->_gen_comp_path;
    my $source  = $params{src}  || " ";
    my $verbose = $params{v}    || $params{verbose};

    $self->add_comp( path => $path, src => $source, verbose => $verbose );
    delete( $params{src} );

    $self->test_existing_comp( %params, path => $path );
}

method test_existing_comp (%params) {
    $self->_validate_keys( \%params, qw(args desc expect expect_data expect_error path v verbose) );
    my $path         = $params{path} or die "must pass path";
    my $caller       = ( caller(1) )[3];
    my $desc         = $params{desc} || $path;
    my $expect       = trim( $params{expect} );
    my $expect_error = $params{expect_error};
    my $expect_data  = $params{expect_data};
    my $verbose      = $params{v} || $params{verbose};
    my $args         = $params{args} || {};
    ( my $request_path = $path ) =~ s/\.m[cpi]$//;

    my @run_params = ( $request_path, %$args );
    local $current_test_object = $self;

    if ( defined($expect_error) ) {
        $desc ||= $expect_error;
        throws_ok( sub { $self->interp->run(@run_params) }, $expect_error, $desc );
    }
    if ( defined($expect) ) {
        $desc ||= $caller;
        my $output = trim( $self->interp->run(@run_params)->output );
        if ( ref($expect) eq 'Regexp' ) {
            like( $output, $expect, $desc );
        }
        else {
            is( $output, $expect, $desc );
        }
    }
    if ( defined($expect_data) ) {
        $desc ||= $caller;
        cmp_deeply( $self->interp->run(@run_params)->data, $expect_data, $desc );
    }
}

method run_test_in_comp (%params) {
    my $test = delete( $params{test} ) || die "must pass test";
    my $args = delete( $params{args} ) || {};
    $params{path} ||= $self->_gen_comp_path;
    $self->add_comp( %params, src => '% $.args->{_test}->($self);' );
    ( my $request_path = $params{path} ) =~ s/\.m[cpi]$//;
    my @run_params = ( $request_path, %$args );
    $self->interp->run( @run_params, _test => $test );
}

method test_parse (%params) {
    my $caller        = ( caller(1) )[3];
    my ($caller_base) = ( $caller =~ /([^:]+)$/ );
    my $desc          = $params{desc};
    my $source        = $params{src} || croak "must pass src";
    my $expect_list   = $params{expect};
    my $expect_error  = $params{expect_error};
    croak "must pass either expect or expect_error" unless $expect_list || $expect_error;

    my $path = "/parse/comp" . $parse_count++;
    my $file = $self->temp_dir . $path;
    $self->mkpath_and_write_file( $file, $source );

    if ($expect_error) {
        $desc ||= $expect_error;
        throws_ok( sub { $self->interp->_compile( $file, $path ) }, $expect_error, $desc );
    }
    else {
        $desc ||= $caller;
        my $output = $self->interp->_compile( $file, $path );
        foreach my $expect (@$expect_list) {
            if ( ref($expect) eq 'Regexp' ) {
                like_string( $output, $expect, "$desc - $expect" );
            }
            else {
                contains_string( $output, $expect, "$desc - $expect" );
            }
        }
    }
}

method mkpath_and_write_file ($source_file, $source) {
    unlink($source_file) if -e $source_file;
    mkpath( dirname($source_file), 0, 0775 );
    write_file( $source_file, $source );
}

method _validate_keys ($params, @allowed_keys) {
    my %is_allowed = map { ( $_, 1 ) } @allowed_keys;
    if ( my @bad_keys = grep { !$is_allowed{$_} } keys(%$params) ) {
        croak "bad parameters: " . join( ", ", @bad_keys );
    }
}

1;