The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
#!/usr/bin/perl

use strict;

BEGIN {
	$^W = 1;
}

use Test::More;
use Test::Differences;
use PPI;

BEGIN {
	if ( $PPI::VERSION =~ /_/ ) {
		plan skip_all => "Need released version of PPI. You have $PPI::VERSION";
		exit 0;
	}
}

my @cases = (
	{   code => <<'END_CODE',
use strict; use warnings;
use Abc;

my $global = 42;

sub qwer {
}

END_CODE
		expected => [
			[ 'keyword',    1, 1,  3 ],
			[ 'Whitespace', 1, 4,  1 ],
			[ 'pragma',     1, 5,  6 ],
			[ 'Structure',  1, 11, 1 ],
			[ 'Whitespace', 1, 12, 1 ],
			[ 'keyword',    1, 13, 3 ],
			[ 'Whitespace', 1, 16, 1 ],
			[ 'pragma',     1, 17, 8 ],
			[ 'Structure',  1, 25, 1 ],
			[ 'Whitespace', 1, 26, 1 ],
			[ 'keyword',    2, 1,  3 ],
			[ 'Whitespace', 2, 4,  1 ],
			[ 'Word',       2, 5,  3 ],
			[ 'Structure',  2, 8,  1 ],
			[ 'Whitespace', 2, 9,  1 ],
			[ 'Whitespace', 3, 1,  1 ],
			[ 'keyword',    4, 1,  2 ],
			[ 'Whitespace', 4, 3,  1 ],
			[ 'Symbol',     4, 4,  7 ],
			[ 'Whitespace', 4, 11, 1 ],
			[ 'Operator',   4, 12, 1 ],
			[ 'Whitespace', 4, 13, 1 ],
			[ 'Number',     4, 14, 2 ],
			[ 'Structure',  4, 16, 1 ],
			[ 'Whitespace', 4, 17, 1 ],
			[ 'Whitespace', 5, 1,  1 ],
			[ 'keyword',    6, 1,  3 ],
			[ 'Whitespace', 6, 4,  1 ],
			[ 'Word',       6, 5,  4 ],
			[ 'Whitespace', 6, 9,  1 ],
			[ 'Structure',  6, 10, 1 ],
			[ 'Whitespace', 6, 11, 1 ],
			[ 'Structure',  7, 1,  1 ],
			[ 'Whitespace', 7, 2,  1 ],
			[ 'Whitespace', 8, 1,  1 ],
		],
	},
	{   code => <<'END_CODE',
sub return func method before after around override augment
END_CODE
		expected => [
			[ 'keyword',    1, 1,  3 ],
			[ 'Whitespace', 1, 4,  1 ],
			[ 'keyword',    1, 5,  6 ],
			[ 'Whitespace', 1, 11, 1 ],
			[ 'Word',       1, 12, 4 ],
			[ 'Whitespace', 1, 16, 1 ],
			[ 'Word',       1, 17, 6 ],
			[ 'Whitespace', 1, 23, 1 ],
			[ 'Word',       1, 24, 6 ],
			[ 'Whitespace', 1, 30, 1 ],
			[ 'Word',       1, 31, 5 ],
			[ 'Whitespace', 1, 36, 1 ],
			[ 'Word',       1, 37, 6 ],
			[ 'Whitespace', 1, 43, 1 ],
			[ 'Word',       1, 44, 8 ],
			[ 'Whitespace', 1, 52, 1 ],
			[ 'Word',       1, 53, 7 ],
			[ 'Whitespace', 1, 60, 1 ],

		],
	},
	{   code => <<'END_CODE',
undef shift defined bless
END_CODE
		expected => [
			[ 'core',       1, 1,  5 ],
			[ 'Whitespace', 1, 6,  1 ],
			[ 'core',       1, 7,  5 ],
			[ 'Whitespace', 1, 12, 1 ],
			[ 'core',       1, 13, 7 ],
			[ 'Whitespace', 1, 20, 1 ],
			[ 'core',       1, 21, 5 ],
			[ 'Whitespace', 1, 26, 1 ],
		],
	},
	{   code => <<'END_CODE',
new
END_CODE
		expected => [ [ 'Word', 1, 1, 3 ], [ 'Whitespace', 1, 4, 1 ], ],
	},
	{   code => <<'END_CODE',
use no
END_CODE
		expected => [
			[ 'keyword',    1, 1, 3 ],
			[ 'Whitespace', 1, 4, 1 ],
			[ 'keyword',    1, 5, 2 ],
			[ 'Whitespace', 1, 7, 1 ],
		],
	},
	{   code => <<'END_CODE',
my local our
END_CODE
		expected => [
			[ 'keyword',    1, 1,  2 ],
			[ 'Whitespace', 1, 3,  1 ],
			[ 'keyword',    1, 4,  5 ],
			[ 'Whitespace', 1, 9,  1 ],
			[ 'keyword',    1, 10, 3 ],
			[ 'Whitespace', 1, 13, 1 ],

		],
	},

	{   code => <<'END_CODE',
if else elsif unless for foreach while my
END_CODE
		expected => [
			[ 'keyword',    1, 1,  2 ],
			[ 'Whitespace', 1, 3,  1 ],
			[ 'keyword',    1, 4,  4 ],
			[ 'Whitespace', 1, 8,  1 ],
			[ 'keyword',    1, 9,  5 ],
			[ 'Whitespace', 1, 14, 1 ],
			[ 'keyword',    1, 15, 6 ],
			[ 'Whitespace', 1, 21, 1 ],
			[ 'keyword',    1, 22, 3 ],
			[ 'Whitespace', 1, 25, 1 ],
			[ 'keyword',    1, 26, 7 ],
			[ 'Whitespace', 1, 33, 1 ],
			[ 'keyword',    1, 34, 5 ],
			[ 'Whitespace', 1, 39, 1 ],
			[ 'keyword',    1, 40, 2 ],
			[ 'Whitespace', 1, 42, 1 ],

		],
	},
	{   code => <<'END_CODE',
package
END_CODE
		expected => [ [ 'keyword', 1, 1, 7 ], [ 'Whitespace', 1, 8, 1 ], ],
	},
);

plan tests => @cases * 1;

use PPIx::EditorTools::Lexer;

my @result;
foreach my $c (@cases) {
	@result = ();
	PPIx::EditorTools::Lexer->new->lexer(
		code        => $c->{code},
		highlighter => \&highlighter
	);

	#diag explain @result;
	is_deeply \@result, $c->{expected} or diag explain @result;
}

sub highlighter {
	push @result, [@_];
}