[perl5.git] / cpan / Test-Harness / t / source.t

#!/usr/bin/perl -w

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

use strict;

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

my $dir = File::Spec->catdir(
    '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 };
    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;
}
Commit	Line	Data
b965d173 NC	1	#!/usr/bin/perl -w
	2
	3	BEGIN {
686add28	4	unshift @INC, 't/lib';
b965d173 NC	5	}
	6
	7	use strict;
b965d173	8
6d313664	9	use Test::More tests => 45;
b965d173 NC	10	use File::Spec;
b965d173 NC	11
6d313664	12	my $dir = File::Spec->catdir(
27fc0087	13	't',
6d313664	14	'source_tests'
5e2a19fc	15	);
b965d173	16
6d313664 CBW	17	use_ok('TAP::Parser::Source');
6d313664 CBW	18
686add28 CBW	19	sub ct($) {
	20	my $hash = shift;
	21	if ( $ENV{PERL_CORE} ) {
	22	delete $hash->{is_symlink};
	23	delete $hash->{lstat};
	24	}
	25	return $hash;
	26	}
	27
6d313664 CBW	28	# Basic tests
	29	{
	30	my $source = TAP::Parser::Source->new;
	31	isa_ok( $source, 'TAP::Parser::Source', 'new source' );
	32	can_ok(
	33	$source,
	34	qw( raw meta config merge switches test_args assemble_meta )
	35	);
	36
	37	is_deeply( $source->config, {}, 'config empty by default' );
	38	$source->config->{Foo} = { bar => 'baz' };
	39	is_deeply(
	40	$source->config_for('Foo'), { bar => 'baz' },
	41	'config_for( Foo )'
	42	);
	43	is_deeply(
	44	$source->config_for('TAP::Parser::SourceHandler::Foo'),
	45	{ bar => 'baz' }, 'config_for( ...::SourceHandler::Foo )'
	46	);
	47
	48	ok( !$source->merge, 'merge not set by default' );
	49	$source->merge(1);
	50	ok( $source->merge, '... merge now set' );
	51
	52	is( $source->switches, undef, 'switches not set by default' );
	53	$source->switches( ['-Ilib'] );
	54	is_deeply( $source->switches, ['-Ilib'], '... switches now set' );
	55
	56	is( $source->test_args, undef, 'test_args not set by default' );
	57	$source->test_args( ['foo'] );
	58	is_deeply( $source->test_args, ['foo'], '... test_args now set' );
b965d173	59
6d313664 CBW	60	$source->raw( \'hello world' );
	61	my $meta = $source->assemble_meta;
	62	is_deeply(
	63	$meta,
	64	{ is_scalar => 1,
	65	is_object => 0,
	66	has_newlines => 0,
	67	length => 11,
	68	},
	69	'assemble_meta for scalar that isnt a file'
	70	);
	71
	72	is( $source->meta, $meta, '... and caches meta' );
	73	}
	74
	75	# array check
	76	{
	77	my $source = TAP::Parser::Source->new;
	78	$source->raw( [ 'hello', 'world' ] );
	79	my $meta = $source->assemble_meta;
	80	is_deeply(
	81	$meta,
	82	{ is_array => 1,
	83	is_object => 0,
	84	size => 2,
	85	},
	86	'assemble_meta for array'
	87	);
	88	}
	89
	90	# hash check
	91	{
	92	my $source = TAP::Parser::Source->new;
	93	$source->raw( { hello => 'world' } );
	94	my $meta = $source->assemble_meta;
	95	is_deeply(
	96	$meta,
	97	{ is_hash => 1,
	98	is_object => 0,
	99	},
	100	'assemble_meta for array'
	101	);
	102	}
b965d173	103
6d313664	104	# glob check
b965d173	105	{
6d313664 CBW	106	my $source = TAP::Parser::Source->new;
	107	$source->raw( \*__DATA__ );
	108	my $meta = $source->assemble_meta;
	109	is_deeply(
	110	$meta,
	111	{ is_glob => 1,
	112	is_object => 0,
	113	},
	114	'assemble_meta for array'
	115	);
	116	}
	117
	118	# object check
	119	{
	120	my $source = TAP::Parser::Source->new;
	121	$source->raw( bless {}, 'Foo::Bar' );
	122	my $meta = $source->assemble_meta;
	123	is_deeply(
	124	$meta,
	125	{ is_object => 1,
	126	class => 'Foo::Bar',
	127	},
	128	'assemble_meta for array'
	129	);
	130	}
	131
	132	# file test
	133	{
	134	my $test = File::Spec->catfile( $dir, 'source.t' );
	135	my $source = TAP::Parser::Source->new;
	136
	137	$source->raw( \$test );
	138	my $meta = $source->assemble_meta;
	139
	140	# separate meta->file to break up the test
	141	my $file = delete $meta->{file};
	142	is_deeply(
686add28 CBW	143	ct $meta,
686add28 CBW	144	ct {is_scalar => 1,
6d313664 CBW	145	has_newlines => 0,
	146	length => length($test),
	147	is_object => 0,
	148	is_file => 1,
	149	is_dir => 0,
	150	is_symlink => 0,
	151	},
	152	'assemble_meta for file'
	153	);
	154
	155	# now check file meta - remove things that will vary between platforms
	156	my $stat = delete $file->{stat};
	157	is( @$stat, 13, '... file->stat set' );
	158	ok( delete $file->{size}, '... file->size set' );
	159	ok( delete $file->{dir}, '... file->dir set' );
	160	isnt( delete $file->{read}, undef, '... file->read set' );
	161	isnt( delete $file->{write}, undef, '... file->write set' );
	162	isnt( delete $file->{execute}, undef, '... file->execute set' );
	163	is_deeply(
686add28 CBW	164	ct $file,
686add28 CBW	165	ct {basename => 'source.t',
6d313664 CBW	166	ext => '.t',
	167	lc_ext => '.t',
	168	shebang => '#!/usr/bin/perl',
	169	binary => 0,
	170	text => 1,
	171	empty => 0,
	172	exists => 1,
	173	is_dir => 0,
	174	is_file => 1,
	175	is_symlink => 0,
686add28 CBW	176	# Fix for bizarre -k bug in Strawberry Perl
	177	sticky => ( -k $test )[-1] ? 1 : 0,
	178	setgid => -g $test ? 1 : 0,
	179	setuid => -u $test ? 1 : 0,
6d313664 CBW	180	},
	181	'... file->* set'
	182	);
	183	}
	184
	185	# dir test
	186	{
686add28	187	my $test = $dir;
6d313664 CBW	188	my $source = TAP::Parser::Source->new;
	189
	190	$source->raw( \$test );
	191	my $meta = $source->assemble_meta;
	192
	193	# separate meta->file to break up the test
	194	my $file = delete $meta->{file};
	195	is_deeply(
686add28 CBW	196	ct $meta,
686add28 CBW	197	ct {is_scalar => 1,
6d313664 CBW	198	has_newlines => 0,
	199	length => length($test),
	200	is_object => 0,
	201	is_file => 0,
	202	is_dir => 1,
	203	is_symlink => 0,
	204	},
	205	'assemble_meta for directory'
	206	);
	207
	208	# now check file meta - remove things that will vary between platforms
	209	my $stat = delete $file->{stat};
	210	is( @$stat, 13, '... file->stat set' );
	211	ok( delete $file->{dir}, '... file->dir set' );
	212	isnt( delete $file->{size}, undef, '... file->size set' );
	213	isnt( delete $file->{binary}, undef, '... file->binary set' );
	214	isnt( delete $file->{empty}, undef, '... file->empty set' );
	215	isnt( delete $file->{read}, undef, '... file->read set' );
	216	isnt( delete $file->{write}, undef, '... file->write set' );
	217	isnt( delete $file->{execute}, undef, '... file->execute set' );
	218	is_deeply(
686add28 CBW	219	ct $file,
686add28 CBW	220	ct {basename => 'source_tests',
6d313664 CBW	221	ext => '',
	222	lc_ext => '',
	223	text => 0,
	224	exists => 1,
	225	is_dir => 1,
	226	is_file => 0,
	227	is_symlink => 0,
686add28 CBW	228	sticky => ( -k $test )[-1] ? 1 : 0,
	229	setgid => -g $test ? 1 : 0,
	230	setuid => -u $test ? 1 : 0,
6d313664 CBW	231	},
	232	'... file->* set'
	233	);
	234	}
b965d173	235
6d313664 CBW	236	# symlink test
	237	SKIP: {
	238	my $symlink_exists = eval { symlink( '', '' ); 1 };
	239	skip 'symlink not supported on this platform', 9 unless $symlink_exists;
b965d173	240
6d313664 CBW	241	my $test = File::Spec->catfile( $dir, 'source.t' );
	242	my $symlink = File::Spec->catfile( $dir, 'source_link.T' );
	243	my $source = TAP::Parser::Source->new;
b965d173	244
6d313664 CBW	245	eval { symlink( File::Spec->rel2abs($test), $symlink ) };
	246	if ( my $e = $@ ) {
	247	diag($@);
	248	die "aborting test";
	249	}
b965d173	250
6d313664 CBW	251	$source->raw( \$symlink );
6d313664 CBW	252	my $meta = $source->assemble_meta;
b965d173	253
6d313664 CBW	254	# separate meta->file to break up the test
	255	my $file = delete $meta->{file};
	256	is_deeply(
686add28 CBW	257	ct $meta,
686add28 CBW	258	ct {is_scalar => 1,
6d313664 CBW	259	has_newlines => 0,
	260	length => length($symlink),
	261	is_object => 0,
	262	is_file => 1,
	263	is_dir => 0,
	264	is_symlink => 1,
	265	},
	266	'assemble_meta for symlink'
	267	);
b965d173	268
6d313664 CBW	269	# now check file meta - remove things that will vary between platforms
	270	my $stat = delete $file->{stat};
	271	is( @$stat, 13, '... file->stat set' );
	272	my $lstat = delete $file->{lstat};
	273	is( @$lstat, 13, '... file->lstat set' );
	274	ok( delete $file->{size}, '... file->size set' );
	275	ok( delete $file->{dir}, '... file->dir set' );
	276	isnt( delete $file->{read}, undef, '... file->read set' );
	277	isnt( delete $file->{write}, undef, '... file->write set' );
	278	isnt( delete $file->{execute}, undef, '... file->execute set' );
	279	is_deeply(
686add28 CBW	280	ct $file,
686add28 CBW	281	ct {basename => 'source_link.T',
6d313664 CBW	282	ext => '.T',
	283	lc_ext => '.t',
	284	shebang => '#!/usr/bin/perl',
	285	binary => 0,
	286	text => 1,
	287	empty => 0,
	288	exists => 1,
	289	is_dir => 0,
	290	is_file => 1,
	291	is_symlink => 1,
686add28 CBW	292	sticky => ( -k $symlink )[-1] ? 1 : 0,
	293	setgid => -g $symlink ? 1 : 0,
	294	setuid => -u $symlink ? 1 : 0,
6d313664 CBW	295	},
	296	'... file->* set'
	297	);
b965d173	298
6d313664	299	unlink $symlink;
b965d173 NC	300	}
b965d173 NC	301