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