Gecko [ www.blackthorn-inc.com ]

Name	Size	Permission	Date
compat	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
data	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
lib	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
proverc	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
sample-tests	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
source_tests	[ DIR ]	drwxr-xr-x	2016-10-10 18:24
subclass_tests	[ DIR ]	drwxr-xr-x	2015-02-14 16:55
aggregator.t	9.35 KB	-r--r--r--	2014-12-27 11:48
bailout.t	3.12 KB	-r--r--r--	2014-12-27 11:48
base.t	4.68 KB	-r--r--r--	2014-12-27 11:48
callbacks.t	2.57 KB	-r--r--r--	2014-12-27 11:48
console.t	1.06 KB	-r--r--r--	2014-12-27 11:48
errors.t	4.64 KB	-r--r--r--	2014-12-27 11:48
file.t	13.61 KB	-r--r--r--	2014-12-27 11:48
glob-to-regexp.t	988 B	-r--r--r--	2014-12-27 11:48
grammar.t	11.55 KB	-r--r--r--	2014-12-27 11:48
harness-bailout.t	1.19 KB	-r--r--r--	2014-12-27 11:48
harness-subclass.t	1.58 KB	-r--r--r--	2014-12-27 11:48
harness.t	28.38 KB	-r--r--r--	2014-12-27 11:48
iterator_factory.t	4.8 KB	-r--r--r--	2014-12-27 11:48
iterators.t	5.68 KB	-r--r--r--	2014-12-27 11:48
multiplexer.t	4.53 KB	-r--r--r--	2014-12-27 11:48
nested.t	860 B	-r--r--r--	2014-12-27 11:48
nofork-mux.t	119 B	-r--r--r--	2014-12-27 11:48
nofork.t	1.55 KB	-r--r--r--	2014-12-27 11:48
object.t	772 B	-r--r--r--	2014-12-27 11:48
parse.t	30.97 KB	-r--r--r--	2014-12-27 11:48
parser-config.t	731 B	-r--r--r--	2014-12-27 11:48
parser-subclass.t	2.2 KB	-r--r--r--	2014-12-27 11:48
perl5lib.t	1.13 KB	-r--r--r--	2014-12-27 11:48
premature-bailout.t	2.32 KB	-r--r--r--	2014-12-27 11:48
process.t	1015 B	-r--r--r--	2014-12-27 11:48
prove.t	47.6 KB	-r--r--r--	2014-12-27 11:49
proveenv.t	338 B	-r--r--r--	2014-12-27 11:49
proverc.t	472 B	-r--r--r--	2014-12-27 11:48
proverun.t	4.14 KB	-r--r--r--	2014-12-27 11:48
proveversion.t	763 B	-r--r--r--	2014-12-27 11:48
regression.t	111.62 KB	-r--r--r--	2014-12-27 11:48
results.t	7.68 KB	-r--r--r--	2014-12-27 11:48
scheduler.t	5.33 KB	-r--r--r--	2014-12-27 11:48
source.t	8.21 KB	-r--r--r--	2014-12-27 11:48
source_handler.t	12.32 KB	-r--r--r--	2014-12-27 11:48
spool.t	3.12 KB	-r--r--r--	2014-12-27 11:48
state.t	7.7 KB	-r--r--r--	2014-12-27 11:48
state_results.t	4.95 KB	-r--r--r--	2014-12-27 11:48
streams.t	6.33 KB	-r--r--r--	2014-12-27 11:48
taint.t	1.3 KB	-r--r--r--	2014-12-27 11:49
testargs.t	4.95 KB	-r--r--r--	2014-12-27 11:48
unicode.t	3.73 KB	-r--r--r--	2014-12-27 11:48
yamlish-output.t	2.44 KB	-r--r--r--	2014-12-27 11:48
yamlish-writer.t	7.17 KB	-r--r--r--	2014-12-27 11:48
yamlish.t	15.01 KB	-r--r--r--	2014-12-27 11:48

Rename

#!/usr/bin/perl -w

BEGIN {
    unshift @INC, 't/lib';
}

use strict;
use warnings;

use Test::More tests => 45;
use File::Spec;

my $dir = 't/source_tests';

use_ok('TAP::Parser::Source');

sub ct($) {
    my $hash = shift;
    if ( $ENV{PERL_CORE} ) {
        delete $hash->{is_symlink};
        delete $hash->{lstat};
    }
    return $hash;
}

# Basic tests
{
    my $source = TAP::Parser::Source->new;
    isa_ok( $source, 'TAP::Parser::Source', 'new source' );
    can_ok(
        $source,
        qw( raw meta config merge switches test_args assemble_meta )
    );

is_deeply( $source->config, {}, 'config empty by default' );
    $source->config->{Foo} = { bar => 'baz' };
    is_deeply(
        $source->config_for('Foo'), { bar => 'baz' },
        'config_for( Foo )'
    );
    is_deeply(
        $source->config_for('TAP::Parser::SourceHandler::Foo'),
        { bar => 'baz' }, 'config_for( ...::SourceHandler::Foo )'
    );

ok( !$source->merge, 'merge not set by default' );
    $source->merge(1);
    ok( $source->merge, '... merge now set' );

is( $source->switches, undef, 'switches not set by default' );
    $source->switches( ['-Ilib'] );
    is_deeply( $source->switches, ['-Ilib'], '... switches now set' );

is( $source->test_args, undef, 'test_args not set by default' );
    $source->test_args( ['foo'] );
    is_deeply( $source->test_args, ['foo'], '... test_args now set' );

$source->raw( \'hello world' );
    my $meta = $source->assemble_meta;
    is_deeply(
        $meta,
        {   is_scalar    => 1,
            is_object    => 0,
            has_newlines => 0,
            length       => 11,
        },
        'assemble_meta for scalar that isnt a file'
    );

is( $source->meta, $meta, '... and caches meta' );
}

# array check
{
    my $source = TAP::Parser::Source->new;
    $source->raw( [ 'hello', 'world' ] );
    my $meta = $source->assemble_meta;
    is_deeply(
        $meta,
        {   is_array  => 1,
            is_object => 0,
            size      => 2,
        },
        'assemble_meta for array'
    );
}

# hash check
{
    my $source = TAP::Parser::Source->new;
    $source->raw( { hello => 'world' } );
    my $meta = $source->assemble_meta;
    is_deeply(
        $meta,
        {   is_hash   => 1,
            is_object => 0,
        },
        'assemble_meta for array'
    );
}

# glob check
{
    my $source = TAP::Parser::Source->new;
    $source->raw( \*__DATA__ );
    my $meta = $source->assemble_meta;
    is_deeply(
        $meta,
        {   is_glob   => 1,
            is_object => 0,
        },
        'assemble_meta for array'
    );
}

# object check
{
    my $source = TAP::Parser::Source->new;
    $source->raw( bless {}, 'Foo::Bar' );
    my $meta = $source->assemble_meta;
    is_deeply(
        $meta,
        {   is_object => 1,
            class     => 'Foo::Bar',
        },
        'assemble_meta for array'
    );
}

# file test
{
    my $test = File::Spec->catfile( $dir, 'source.t' );
    my $source = TAP::Parser::Source->new;

$source->raw( \$test );
    my $meta = $source->assemble_meta;

# separate meta->file to break up the test
    my $file = delete $meta->{file};
    is_deeply(
        ct $meta,
        ct {is_scalar    => 1,
            has_newlines => 0,
            length       => length($test),
            is_object    => 0,
            is_file      => 1,
            is_dir       => 0,
            is_symlink   => 0,
        },
        'assemble_meta for file'
    );

# now check file meta - remove things that will vary between platforms
    my $stat = delete $file->{stat};
    is( @$stat, 13, '... file->stat set' );
    ok( delete $file->{size}, '... file->size set' );
    ok( delete $file->{dir},  '... file->dir set' );
    isnt( delete $file->{read},    undef, '... file->read set' );
    isnt( delete $file->{write},   undef, '... file->write set' );
    isnt( delete $file->{execute}, undef, '... file->execute set' );
    is_deeply(
        ct $file,
        ct {basename   => 'source.t',
            ext        => '.t',
            lc_ext     => '.t',
            shebang    => '#!/usr/bin/perl',
            binary     => 0,
            text       => 1,
            empty      => 0,
            exists     => 1,
            is_dir     => 0,
            is_file    => 1,
            is_symlink => 0,

# Fix for bizarre -k bug in Strawberry Perl
            sticky => ( -k $test )[-1] ? 1 : 0,
            setgid => -g $test         ? 1 : 0,
            setuid => -u $test         ? 1 : 0,
        },
        '... file->* set'
    );
}

# dir test
{
    my $test   = $dir;
    my $source = TAP::Parser::Source->new;

$source->raw( \$test );
    my $meta = $source->assemble_meta;

# separate meta->file to break up the test
    my $file = delete $meta->{file};
    is_deeply(
        ct $meta,
        ct {is_scalar    => 1,
            has_newlines => 0,
            length       => length($test),
            is_object    => 0,
            is_file      => 0,
            is_dir       => 1,
            is_symlink   => 0,
        },
        'assemble_meta for directory'
    );

# now check file meta - remove things that will vary between platforms
    my $stat = delete $file->{stat};
    is( @$stat, 13, '... file->stat set' );
    ok( delete $file->{dir}, '... file->dir set' );
    isnt( delete $file->{size},    undef, '... file->size set' );
    isnt( delete $file->{binary},  undef, '... file->binary set' );
    isnt( delete $file->{empty},   undef, '... file->empty set' );
    isnt( delete $file->{read},    undef, '... file->read set' );
    isnt( delete $file->{write},   undef, '... file->write set' );
    isnt( delete $file->{execute}, undef, '... file->execute set' );
    is_deeply(
        ct $file,
        ct {basename   => 'source_tests',
            ext        => '',
            lc_ext     => '',
            text       => 0,
            exists     => 1,
            is_dir     => 1,
            is_file    => 0,
            is_symlink => 0,
            sticky     => ( -k $test )[-1] ? 1 : 0,
            setgid     => -g $test ? 1 : 0,
            setuid     => -u $test ? 1 : 0,
        },
        '... file->* set'
    );
}

# symlink test
SKIP: {
    my $symlink_exists = eval { symlink( '', '' ); 1 };
    $symlink_exists = 0 if $^O eq 'VMS'; # exists but not ready for prime time
    skip 'symlink not supported on this platform', 9 unless $symlink_exists;

my $test    = File::Spec->catfile( $dir, 'source.t' );
    my $symlink = File::Spec->catfile( $dir, 'source_link.T' );
    my $source  = TAP::Parser::Source->new;

eval { symlink( File::Spec->rel2abs($test), $symlink ) };
    if ( my $e = $@ ) {
        diag($@);
        die "aborting test";
    }

$source->raw( \$symlink );
    my $meta = $source->assemble_meta;

# separate meta->file to break up the test
    my $file = delete $meta->{file};
    is_deeply(
        ct $meta,
        ct {is_scalar    => 1,
            has_newlines => 0,
            length       => length($symlink),
            is_object    => 0,
            is_file      => 1,
            is_dir       => 0,
            is_symlink   => 1,
        },
        'assemble_meta for symlink'
    );

# now check file meta - remove things that will vary between platforms
    my $stat = delete $file->{stat};
    is( @$stat, 13, '... file->stat set' );
    my $lstat = delete $file->{lstat};
    is( @$lstat, 13, '... file->lstat set' );
    ok( delete $file->{size}, '... file->size set' );
    ok( delete $file->{dir},  '... file->dir set' );
    isnt( delete $file->{read},    undef, '... file->read set' );
    isnt( delete $file->{write},   undef, '... file->write set' );
    isnt( delete $file->{execute}, undef, '... file->execute set' );
    is_deeply(
        ct $file,
        ct {basename   => 'source_link.T',
            ext        => '.T',
            lc_ext     => '.t',
            shebang    => '#!/usr/bin/perl',
            binary     => 0,
            text       => 1,
            empty      => 0,
            exists     => 1,
            is_dir     => 0,
            is_file    => 1,
            is_symlink => 1,
            sticky     => ( -k $symlink )[-1] ? 1 : 0,
            setgid     => -g $symlink ? 1 : 0,
            setuid     => -u $symlink ? 1 : 0,
        },
        '... file->* set'
    );

unlink $symlink;
}