#!/usr/bin/perl

# Load ALL of the PPI files, and look for a collection
# of known problems, implemented using PPI itself.

# Using PPI to analyse its own code at install-time? Fuck yeah! :)

use strict;
BEGIN {
	no warnings 'once';
	$| = 1;
	$PPI::XS_DISABLE = 1;
	$PPI::Lexer::X_TOKENIZER ||= $ENV{X_TOKENIZER};
}

use Test::More; # Plan comes later
use Test::NoWarnings;
use Test::Object;
use File::Spec::Functions ':ALL';
use Params::Util qw{_CLASS _ARRAY _INSTANCE _IDENTIFIER};
use Class::Inspector;
use PPI;
use t::lib::PPI;

use constant CI => 'Class::Inspector';





#####################################################################
# Prepare

# Find all of the files to be checked
my %tests = map { $_ => $INC{$_} } grep { ! /\bXS\.pm/ } grep { /^PPI\b/ } keys %INC;
unless ( %tests ) {
	Test::More::plan( tests => 2 );
	ok( undef, "Failed to find any files to test" );
	exit();
}
my @files = sort values %tests;

# Find all the testable perl files in t/data
foreach my $dir ( '05_lexer', '08_regression', '11_util', '13_data', '15_transform' ) {
	my @perl = find_files( $dir );
	push @files, @perl;
}

# Declare our plan
Test::More::plan( tests => scalar(@files) * 14 + 4 );





#####################################################################
# Self-test the search functions before we use them

# Check this actually finds something bad
my $sample = PPI::Document->new(\<<'END_PERL');
isa($foo, 'Bad::Class1');
isa($foo, 'PPI::Document');
$foo->isa('Bad::Class2');
$foo->isa("Bad::Class3");
isa($foo, 'ARRAY'); # Not bad
isa($foo->thing, qq <Bad::Class4> # ok?
);
END_PERL
isa_ok( $sample, 'PPI::Document' );

my $bad = $sample->find( \&bug_bad_isa_class_name );
ok( _ARRAY($bad), 'Found bad things' );
@$bad = map { $_->string } @$bad;
is_deeply( $bad, [ 'Bad::Class1', 'Bad::Class2', 'Bad::Class3', 'Bad::Class4' ],
	'Found all found known bad things' );





#####################################################################
# Run the Tests

foreach my $file ( @files ) {
	# MD5 the raw file
	my $md5a = PPI::Util::md5hex_file($file);
	like( $md5a, qr/^[0-9a-f]{32}\z/, 'md5hex_file ok' );

	# Load the file
	my $Document = PPI::Document->new($file);
	ok( _INSTANCE($Document, 'PPI::Document'), "$file: Parsed ok" );

	# Compare the preload signature to the post-load value
	my $md5b = $Document->hex_id;
	is( $md5b, $md5a, '->hex_id matches md5hex' );

	# By this point, everything should have parsed properly at least
	# once, so no need to skip.
	SCOPE: {
		my $rv = $Document->find( \&bug_bad_isa_class_name );
		if ( $rv ) {
			$Document->index_locations;
			foreach ( @$rv ) {
				print "# $file: Found bad class "
					. $_->content
					. "\n";
			}
		}
		is_deeply( $rv, '', "$file: All class names in ->isa calls exist" );
	}
	SCOPE: {
		my $rv = $Document->find( \&bad_static_method );
		if ( $rv ) {
			$Document->index_locations;
			foreach ( @$rv ) {
				my $c = $_->sprevious_sibling->content;
				my $m = $_->snext_sibling->content;
				my $l = $_->location;
				print "# $file: Found bad call ${c}->${m} at line $l->[0], col $l->[1]\n";
			}
		}
		is_deeply( $rv, '', "$file: All class names in static method calls" );
	}

	# Test with Test::Object stuff
	object_ok( $Document );
}





#####################################################################
# Test Functions

# Find file names in named t/data dirs
sub find_files {
	my $dir  = shift;
	my $testdir = catdir( 't', 'data', $dir );
	
	# Does the test directory exist?
	-e $testdir and -d $testdir and -r $testdir or die "Failed to find test directory $testdir";
	
	# Find the .code test files
	opendir( TESTDIR, $testdir ) or die "opendir: $!";
	my @perl = map { catfile( $testdir, $_ ) } sort grep { /\.(?:code|pm)$/ } readdir(TESTDIR);
	closedir( TESTDIR ) or die "closedir: $!";
	return @perl;
}

# Check for accidental use of illegal or non-existant classes in
# ->isa calls. This has happened at least once, presumably because
# PPI has a LOT of classes and it can get confusing.
sub bug_bad_isa_class_name {
	my ($Document, $Element) = @_;

	# Find a quote containing a class name
	$Element->isa('PPI::Token::Quote')             or return '';
	_CLASS($Element->string)                       or return '';
	if ( $Element->string =~ /^(?:ARRAY|HASH|CODE|SCALAR|REF|GLOB)$/ ) {
		return '';
	}

	# It should be the last thing in an expression in a list
	my $Expression = $Element->parent              or return '';
	$Expression->isa('PPI::Statement::Expression') or return '';
	$Element == $Expression->schild(-1)            or return '';

	my $List = $Expression->parent                 or return '';
	$List->isa('PPI::Structure::List')             or return '';
	$List->schildren == 1                          or return '';

	# The list should be the params list for an isa call
	my $Word = $List->sprevious_sibling            or return '';
	$Word->isa('PPI::Token::Word')                 or return '';
	$Word->content =~ /^(?:UNIVERSAL::)?isa\z/s    or return '';

	# Is the class real and loaded?
	CI->loaded($Element->string)                  and return '';

	# Looks like we found a class that doesn't exist in
	# an isa call.
	return 1;
}

# Check for the use of a method that doesn't exist
sub bad_static_method {
	my ($document, $element) = @_;

	# Find a quote containing a class name
	$element->isa('PPI::Token::Operator')   or return '';
	$element->content eq '->'               or return '';

	# Check the method
	my $method = $element->snext_sibling    or return '';
	$method->isa('PPI::Token::Word')        or return '';
	_IDENTIFIER($method->content)           or return '';

	# Check the class
	my $class = $element->sprevious_sibling or return '';
	$class->isa('PPI::Token::Word')         or return '';
	_CLASS($class->content)                 or return '';

	# It's usually a deep class
	$class  = $class->content;
	$method = $method->content;
	$class =~ /::/                          or return '';

	# Check the method exists
	$class->can($method)                   and return '';

	return 1;
}

1;