Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
TestML	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
TestBridge.pm	10.52 KB	-r--r--r--	2014-12-27 11:48
TestUtils.pm	1.05 KB	-r--r--r--	2014-12-27 11:48

Rename

package TestBridge;

use strict;
use warnings;

use Test::More 0.99;
use TestUtils;
use TestML::Tiny;

BEGIN {
    $|  = 1;
    binmode(Test::More->builder->$_, ":utf8")
        for qw/output failure_output todo_output/;
}

use CPAN::Meta::YAML;

use Exporter   ();
our @ISA    = qw{ Exporter };
our @EXPORT = qw{
    run_all_testml_files
    run_testml_file
    test_yaml_roundtrip
    test_perl_to_yaml
    test_dump_error
    test_load_error
    test_yaml_json
    test_code_point
    error_like
    cmp_deeply
    _testml_has_points
};

# regular expressions for checking error messages; incomplete, but more
# can be added as more error messages get test coverage
my %ERROR = (
    E_CIRCULAR => qr{\QCPAN::Meta::YAML does not support circular references},
    E_FEATURE  => qr{\QCPAN::Meta::YAML does not support a feature},
    E_PLAIN    => qr{\QCPAN::Meta::YAML found illegal characters in plain scalar},
    E_CLASSIFY => qr{\QCPAN::Meta::YAML failed to classify the line},
);

# use XXX -with => 'YAML::XS';

#--------------------------------------------------------------------------#
# run_all_testml_files
#
# Iterate over all .tml files in a directory using a particular test bridge
# code # reference.  Each file is wrapped in a subtest with a test plan
# equal to the number of blocks.
#--------------------------------------------------------------------------#

sub run_all_testml_files {
    my ($label, $dir, $bridge, @args) = @_;

my $code = sub {
        my ($file, $blocks) = @_;
        subtest "$label: $file" => sub {
            plan tests => scalar @$blocks;
            $bridge->($_, @args) for @$blocks;
        };
    };

my @files = find_tml_files($dir);

run_testml_file($_, $code) for sort @files;
}

sub run_testml_file {
    my ($file, $code) = @_;

my $blocks = TestML::Tiny->new(
        testml => $file,
        version => '0.1.0',
    )->{function}{data};

$code->($file, $blocks);
}

sub _testml_has_points {
    my ($block, @points) = @_;
    my @values;
    for my $point (@points) {
        defined $block->{$point} or return;
        push @values, $block->{$point};
    }
    push @values, $block->{Label};
    return @values;
}

#--------------------------------------------------------------------------#
# test_yaml_roundtrip
#
# two blocks: perl, yaml
#
# Tests that a YAML string loads to the expected perl data.  Also, tests
# roundtripping from perl->YAML->perl.
#
# We can't compare the YAML for roundtripping because CPAN::Meta::YAML doesn't
# preserve order and comments.  Therefore, all we can test is that given input
# YAML we can produce output YAML that produces the same Perl data as the
# input.
#
# The perl must be an array reference of data to serialize:
#
# [ $thing1, $thing2, ... ]
#
# However, if a test point called 'serializes' exists, the output YAML is
# expected to match the input YAML and will be checked for equality.
#--------------------------------------------------------------------------#

sub test_yaml_roundtrip {
    my ($block) = @_;

my ($yaml, $perl, $label) =
      _testml_has_points($block, qw(yaml perl)) or return;

my %options = ();
    for (qw(serializes)) {
        if (defined($block->{$_})) {
            $options{$_} = 1;
        }
    }

my $expected = eval $perl; die $@ if $@;
    bless $expected, 'CPAN::Meta::YAML';

subtest $label, sub {
        # Does the string parse to the structure
        my $yaml_copy = $yaml;
        my $got       = eval { CPAN::Meta::YAML->read_string( $yaml_copy ); };
        is( $@, '', "CPAN::Meta::YAML parses without error" );
        is( $yaml_copy, $yaml, "CPAN::Meta::YAML does not modify the input string" );
        SKIP: {
            skip( "Shortcutting after failure", 2 ) if $@;
            isa_ok( $got, 'CPAN::Meta::YAML' );
            cmp_deeply( $got, $expected, "CPAN::Meta::YAML parses correctly" )
                or diag "ERROR: $CPAN::Meta::YAML::errstr\n\nYAML:$yaml";
        }

# Does the structure serialize to the string.
        # We can't test this by direct comparison, because any
        # whitespace or comments would be lost.
        # So instead we parse back in.
        my $output = eval { $expected->write_string };
        is( $@, '', "CPAN::Meta::YAML serializes without error" );
        SKIP: {
            skip( "Shortcutting after failure", 5 ) if $@;
            ok(
                !!(defined $output and ! ref $output),
                "CPAN::Meta::YAML serializes to scalar",
            );
            my $roundtrip = eval { CPAN::Meta::YAML->read_string( $output ) };
            is( $@, '', "CPAN::Meta::YAML round-trips without error" );
            skip( "Shortcutting after failure", 2 ) if $@;
            isa_ok( $roundtrip, 'CPAN::Meta::YAML' );
            cmp_deeply( $roundtrip, $expected, "CPAN::Meta::YAML round-trips correctly" );

# Testing the serialization
            skip( "Shortcutting perfect serialization tests", 1 ) unless $options{serializes};
            is( $output, $yaml, 'Serializes ok' );
        }

};
}

#--------------------------------------------------------------------------#
# test_perl_to_yaml
#
# two blocks: perl, yaml
#
# Tests that perl references serialize correctly to a specific YAML output
#
# The perl must be an array reference of data to serialize:
#
# [ $thing1, $thing2, ... ]
#--------------------------------------------------------------------------#

sub test_perl_to_yaml {
    my ($block) = @_;

my ($perl, $yaml, $label) =
      _testml_has_points($block, qw(perl yaml)) or return;

my $input = eval "no strict; $perl"; die $@ if $@;

subtest $label, sub {
        my $result = eval { CPAN::Meta::YAML->new( @$input )->write_string };
        is( $@, '', "write_string lives" );
        is( $result, $yaml, "dumped YAML correct" );
    };
}

#--------------------------------------------------------------------------#
# test_dump_error
#
# two blocks: perl, error 
#
# Tests that perl references result in an error when dumped
#
# The perl must be an array reference of data to serialize:
#
# [ $thing1, $thing2, ... ]
#
# The error must be a key in the %ERROR hash in this file
#--------------------------------------------------------------------------#

sub test_dump_error {
    my ($block) = @_;

my ($perl, $error, $label) =
      _testml_has_points($block, qw(perl error)) or return;

my $input = eval "no strict; $perl"; die $@ if $@;
    chomp $error;
    my $expected = $ERROR{$error};

subtest $label, sub {
        my $result = eval { CPAN::Meta::YAML->new( @$input )->write_string };
        ok( !$result, "returned false" );
        error_like( $expected, "Got expected error" );
    };
}

#--------------------------------------------------------------------------#
# test_load_error
#
# two blocks: yaml, error 
#
# Tests that a YAML string results in an error when loaded
#
# The error must be a key in the %ERROR hash in this file
#--------------------------------------------------------------------------#

sub test_load_error {
    my ($block) = @_;

my ($yaml, $error, $label) =
      _testml_has_points($block, qw(yaml error)) or return;

chomp $error;
    my $expected = $ERROR{$error};

subtest $label, sub {
        my $result = eval { CPAN::Meta::YAML->read_string( $yaml ) };
        is( $result, undef, 'read_string returns undef' );
        error_like( $expected, "Got expected error" )
            or diag "YAML:\n$yaml";
    };
}

#--------------------------------------------------------------------------#
# test_yaml_json
#
# two blocks: yaml, json
#
# Tests that a YAML string can be loaded to Perl and dumped to JSON and
# match an expected JSON output.  The expected JSON is loaded and dumped
# to ensure similar JSON dump options.
#--------------------------------------------------------------------------#

sub test_yaml_json {
    my ($block, $json_lib) = @_;
    $json_lib ||= do { require JSON::PP; 'JSON::PP' };

my ($yaml, $json, $label) =
      _testml_has_points($block, qw(yaml json)) or return;

subtest "$label", sub {
        # test YAML Load
        my $object = eval {
            CPAN::Meta::YAML::Load($yaml);
        };
        my $err = $@;
        ok !$err, "YAML loads";
        return if $err;

# test YAML->Perl->JSON
        # N.B. round-trip JSON to decode any \uNNNN escapes and get to
        # characters
        my $want = $json_lib->new->encode(
            $json_lib->new->decode($json)
        );
        my $got = $json_lib->new->encode($object);
        is $got, $want, "Load is accurate";
    };
}

#--------------------------------------------------------------------------#
# test_code_point
#
# two blocks: code, yaml
#
# Tests that a Unicode codepoint is correctly dumped to YAML as both
# key and value.
#
# The code test point must be a non-negative integer
#
# The yaml code point is the expected output of { $key => $value } where
# both key and value are the character represented by the codepoint.
#--------------------------------------------------------------------------#

sub test_code_point {
    my ($block) = @_;

my ($code, $yaml, $label) =
        _testml_has_points($block, qw(code yaml)) or return;

subtest "$label - Unicode map key/value test" => sub {
        my $data = { chr($code) => chr($code) };
        my $dump = CPAN::Meta::YAML::Dump($data);
        $dump =~ s/^---\n//;
        is $dump, $yaml, "Dump key and value of code point char $code";

my $yny = CPAN::Meta::YAML::Dump(CPAN::Meta::YAML::Load($yaml));
        $yny =~ s/^---\n//;
        is $yny, $yaml, "YAML for code point $code YNY roundtrips";

my $nyn = CPAN::Meta::YAML::Load(CPAN::Meta::YAML::Dump($data));
        cmp_deeply( $nyn, $data, "YAML for code point $code NYN roundtrips" );
    }
}

#--------------------------------------------------------------------------#
# error_like
#
# Test CPAN::Meta::YAML->errstr against a regular expression and clear the
# errstr afterwards
#--------------------------------------------------------------------------#

sub error_like {
    my ($regex, $label) = @_;
    $label = "Got expected error" unless defined $label;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    my $ok = like( $@, $regex, $label );
    return $ok;
}

#--------------------------------------------------------------------------#
# cmp_deeply
#
# is_deeply with some better diagnostics
#--------------------------------------------------------------------------#
sub cmp_deeply {
    my ($got, $want, $label) = @_;
    local $Test::Builder::Level = $Test::Builder::Level + 1;
    is_deeply( $got, $want, $label )
        or diag "GOT:\n", explain($got), "\nWANTED:\n", explain($want);
}