view release on metacpan or  search on metacpan

t/ppi_statement_sub.t  view on Meta::CPAN

		[ '()',       '' ],
		[ '( $*Z@ )', '$*Z@' ],
	) {
		my ( $proto_text, $expected ) = @$test;

		my $Document = safe_new \"sub foo $proto_text {}";

		my ( $sub_statement, $dummy ) = $Document->schildren();
		isa_ok( $sub_statement, 'PPI::Statement::Sub', "$proto_text document child is a sub" );
		is( $dummy, undef, "$proto_text document has exactly one child" );
		is( $sub_statement->prototype, $expected, "$proto_text: prototype matches" );
	}
}

PROTOTYPE_LEXSUB: {
	# Doesn't have to be as thorough as ppi_token_prototype.t, since
	# we're just making sure PPI::Token::Prototype->prototype gets
	# passed through correctly.
	for my $test (
		[ '',         undef ],
		[ '()',       '' ],
		[ '( $*Z@ )', '$*Z@' ],
	) {
		my ( $proto_text, $expected ) = @$test;

		my $Document = safe_new \"my sub foo $proto_text {}";

		my ( $sub_statement, $dummy ) = $Document->schildren();
		isa_ok( $sub_statement, 'PPI::Statement::Sub', "$proto_text document child is a sub" );
		is( $dummy, undef, "$proto_text document has exactly one child" );
		is( $sub_statement->prototype, $expected, "$proto_text: prototype matches" );
	}
}

BLOCK_AND_FORWARD: {
	for my $test (
		{ code => 'sub foo {1;}', block => '{1;}' },
		{ code => 'sub foo{2;};', block => '{2;}' },
		{ code => "sub foo\n{3;};", block => '{3;}' },
		{ code => 'sub foo;', block => '' },
		{ code => 'sub foo', block => '' },
	) {
		my $code = $test->{code};
		my $block = $test->{block};

		my $Document = safe_new \$code;

		my ( $sub_statement, $dummy ) = $Document->schildren();
		isa_ok( $sub_statement, 'PPI::Statement::Sub', "$code: document child is a sub" );
		is( $dummy, undef, "$code: document has exactly one child" );
		is( $sub_statement->block, $block, "$code: block matches" );

		is( !$sub_statement->block, !!$sub_statement->forward, "$code: block and forward are opposites" );
	}
}

RESERVED: {
	for my $test (
		{ code => 'sub BEGIN {}', reserved => 1 },
		{ code => 'sub CHECK {}', reserved => 1 },
		{ code => 'sub UNITCHECK {}', reserved => 1 },
		{ code => 'sub INIT {}', reserved => 1 },
		{ code => 'sub END {}', reserved => 1 },
		{ code => 'sub AUTOLOAD {}', reserved => 1 },
		{ code => 'sub CLONE_SKIP {}', reserved => 1 },
		{ code => 'sub __SUB__ {}', reserved => 1 },
		{ code => 'sub _FOO {}', reserved => 1 },
		{ code => 'sub FOO9 {}', reserved => 1 },
		{ code => 'sub FO9O {}', reserved => 1 },
		{ code => 'sub FOo {}', reserved => 0 },
	) {
		my $code = $test->{code};
		my $reserved = $test->{reserved};

		my $Document = safe_new \$code;

		my ( $sub_statement, $dummy ) = $Document->schildren();
		isa_ok( $sub_statement, 'PPI::Statement::Sub', "$code: document child is a sub" );
		is( $dummy, undef, "$code: document has exactly one child" );
		is( !!$sub_statement->reserved, !!$reserved, "$code: reserved matches" );
	}
}

sub test_sub_as {
	my ( $sub, $name, $followed_by ) = @_;

	my $code     = "$sub$name$followed_by";
	my $Document = safe_new \$code;

	my ( $sub_statement, $dummy ) = $Document->schildren;
	isa_ok( $sub_statement, 'PPI::Statement::Sub', "$code: document child is a sub" );
	isnt( ref $sub_statement, 'PPI::Statement::Scheduled', "$code: not a PPI::Statement::Scheduled" );
	is( $dummy, undef, "$code: document has exactly one child" );
	ok( $sub_statement->reserved, "$code: is reserved" );
	is( $sub_statement->name, $name, "$code: name() correct" );

	if ( $followed_by =~ /}/ ) {
		isa_ok( $sub_statement->block, 'PPI::Structure::Block', "$code: has a block" );
	}
	else {
		ok( !$sub_statement->block, "$code: has no block" );
	}

	return;
}

KEYWORDS_AS_SUB_NAMES: {
	my @names = (
		# normal name
		'foo',
		# Keywords must parse as Word and not influence lexing
		# of subsequent curly braces.
		keys %KEYWORDS,
		# regression: misparsed as version string
		'v10',
		# Other weird and/or special words, just in case
		'__PACKAGE__',
		'__FILE__',
		'__LINE__',
		'__SUB__',
		'AUTOLOAD',