%PDF- %PDF-
Mini Shell

Mini Shell

Direktori : /home/opti/optisoftcom/.cpanm/work/1544535425.21555/Test-Harness-3.42/t/
Upload File :
Create Path :
Current File : /home/opti/optisoftcom/.cpanm/work/1544535425.21555/Test-Harness-3.42/t/source.t

#!/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;
}

Zerion Mini Shell 1.0