view release on metacpan or  search on metacpan

lib/Test/MetaSyntactic.pm  view on Meta::CPAN

    return 'lib';
}

# load the theme in a random namespace
{
    my $num = 0;

    sub _load {
        my ( $theme, $do_import ) = @_;
        my $module = "Acme::MetaSyntactic::$theme";
        my $pkg    = sprintf "Acme::MetaSyntactic::SCRATCH_%04d", $num++;
        my $code   = $do_import
            ? "package $pkg; use $module; 1;"
            : "package $pkg; use $module (); 1;";
        my $ok     = eval $code;
        return ( $pkg, !$ok && $@ );
    }
}

# return a list of [ AMS object, details ]
sub _theme_sublists {
    my ($theme) = @_;
    my @metas;

    # assume the module has already been loaded
    no strict 'refs';
    my $class = "Acme::MetaSyntactic::$theme";

    if( $class->isa('Acme::MetaSyntactic::Locale') ) {
        for my $lang ( "Acme::MetaSyntactic::$theme"->languages() ) {
            push @metas,
                [ "Acme::MetaSyntactic::$theme"->new( lang => $lang ),
                  "$theme, $lang locale" ];
        }
    }
    elsif( $class->isa('Acme::MetaSyntactic::MultiList') ) {
        for my $cat ( "Acme::MetaSyntactic::$theme"->categories() ) {
            push @metas,
                [ "Acme::MetaSyntactic::$theme"->new( category => $cat ),
                  "$theme, $cat category" ];
        }
    }
    else {
        push @metas, [ "Acme::MetaSyntactic::$theme"->new(), $theme ];
    }

    return @metas;
}

# return the list of all theme items
sub _theme_items {
    my ($theme) = @_;

    # assume the module has already been loaded
    no strict 'refs';
    my $class = "Acme::MetaSyntactic::$theme";
    my @items
        = $class->isa('Acme::MetaSyntactic::List')
        ? @{"$class\::List"}
        : $class->isa('Acme::MetaSyntactic::MultiList')
        ? map @$_, values %{"$class\::MultiList"}
        : ();
    return @items;
}

sub _check_file_lines {
    my ($theme, $file, $mesg, $cb ) = @_;
    my $tb = __PACKAGE__->builder;
    $tb->plan( tests => 1 );
    local $Test::Builder::Level = $Test::Builder::Level + 1;

    # try to find a source file if none given
    $file ||= { Acme::MetaSyntactic->_find_themes(_starting_points) }->{$theme};

SKIP: {
        my ($fh, $skip);
        if ( $file ) {
            open $fh, $file or do { $skip = "Can't open $file: $!"; };
        }
        else {
            $skip = "This test needs the source file for $theme";
        }
        if( $skip ) {
            $tb->skip($skip);
            last SKIP;
        }

        my @lines = $cb->( <$fh> );
        $tb->is_num( scalar @lines, 0, sprintf $mesg, $file );
        map $tb->diag( $_ ), "Failed lines:\n", map "  $_", @lines if @lines;
        close $fh;
    }
}

#
# individual subtest functions
#

# t/01load.t
# t/51useall.t
sub subtest_load {
    my ($theme) = @_;
    my $tb = __PACKAGE__->builder;

    $tb->plan( tests => 2 );

    # load in the current process
    my ( $pkg, $error ) = _load( $theme, 1 );
    $tb->ok( !$error, "use Acme::MetaSyntactic::$theme;" );
    $tb->diag($error) if $error;

    # load in isolation
    local $ENV{PERL5LIB} = join $Config::Config{path_sep} || ';', @INC;
    `$^X -MAcme::MetaSyntactic::$theme -e1`;
    $tb->is_eq( $? >> 8, 0, "perl -MAcme::MetaSyntactic::$theme -e1" );
}

# t/02fixme.t
sub subtest_fixme {
    my ( $theme, $file ) = @_;
    $file = '' if !defined $file;
    _check_file_lines(
        $theme, $file,
        "No FIXME found in %s",
        sub { grep /\bFIXME\b/, @_ }
    );
}

sub subtest_encoding {
    my ( $theme, $file ) = @_;
    $file = '' if !defined $file;
    _check_file_lines(
        $theme, $file,
        "%s should have an =encoding line if it contains non-us-ascii characters",
        sub {
            my @non_ascii = grep /[^\x00-\x7f]/,   @_;
            my @encoding  = grep /^=encoding \S+/, @_;
            return @encoding ? () : @non_ascii;
        }
    );
}

# t/08theme.t
sub subtest_theme {
    my ($theme) = @_;
    my $tb = __PACKAGE__->builder;
    $tb->plan( tests => 2 );

    $tb->is_eq( eval { "Acme::MetaSyntactic::$theme"->theme },
        $theme, "theme() for Acme::MetaSyntactic::$theme" );
    $tb->is_eq( eval { "Acme::MetaSyntactic::$theme"->new->theme },
        $theme, "theme() for Acme::MetaSyntactic::$theme" );
}

# t/17import.t
sub subtest_import {
    my ($theme) = @_;
    my $tb = __PACKAGE__->builder;
    $tb->plan( tests => my $tests = 2 );

SKIP: {
        if ( $theme =~ /^(?:any|random)$/ ) {
            $tb->skip("Not testing import for theme $theme") for 1 .. $tests;
            last SKIP;
        }
        else {
            my ($pkg) = _load( $theme, 1 );
            my %seen = map { $_ => 1 } _theme_items($theme);

            no strict 'refs';
            $tb->ok( exists ${"$pkg\::"}{"meta$theme"},
                "meta$theme exported" );

            my @names
                = eval qq{package $pkg; no strict 'refs'; "meta$theme"->();};
            $tb->ok( exists $seen{ $names[0] }, "meta$theme -> $names[0]" );
        }
    }
}

# t/18import.t
sub subtest_noimport {
    my ($theme) = @_;
    my $tb = __PACKAGE__->builder;
    $tb->plan( tests => 1 );

    my ($pkg) = _load($theme);

    # meta$theme should not exist
    eval "package $pkg; meta$theme(1);";
    $tb->ok( $@ =~ /^Undefined subroutine &$pkg\::meta$theme called/,
        "meta$theme function not exported" );
}

# t/21format.t
sub subtest_format {
    my ($theme) = @_;
    my $tb = __PACKAGE__->builder;

    my @metas = _theme_sublists($theme);
    $tb->plan( tests => scalar @metas );

    for my $test (@metas) {
        my ( $ams, $theme ) = @$test;
        my @items = $ams->name(0);
        my @failed;
        my $ok = 0;
        ( /^[A-Za-z_]\w*$/ && ++$ok ) || push @failed, $_ for @items;
        $tb->is_num( $ok, scalar @items, "All names correct for $theme" );
        $tb->diag("Bad names: @failed") if @failed;
    }
}

# t/23length.t
sub subtest_length {
    my ($theme) = @_;
    my $tb = __PACKAGE__->builder;

    my @metas = _theme_sublists($theme);
    $tb->plan( tests => 2 * @metas );

    for my $t (@metas) {
        my ( $ams, $theme ) = @$t;

        # no empty themes
        my @items = $ams->name(0);
        $tb->cmp_ok( 0 + @items, '>=', 1, "$theme has at least one item" );