#!/usr/bin/perl

use strict;
use warnings;
use Test::More;

BEGIN {

	# Don't run tests for installs
	unless ( $ENV{AUTOMATED_TESTING} or $ENV{RELEASE_TESTING} ) {
		plan( skip_all => "Author tests not required for installation" );
	}

	unless ( $ENV{DISPLAY} or $^O eq 'MSWin32' ) {
		plan( skip_all => 'Needs DISPLAY' );
		exit(0);
	}
}

use Params::Util ':ALL';
use File::Find::Rule;
use PPI::Document;

# Calculate the plan
my %modules = map {
	my $class = $_;
	$class =~ s/\//::/g;
	$class =~ s/\.pm$//;
	$class => "lib/$_"
} File::Find::Rule->relative->name('*.pm')->file->in('lib');
my @t_files = glob "t/*.t";

#map {"t/$_"} File::Find::Rule->relative->name('*.t')->file->in('t');
plan( tests => scalar( keys %modules ) * 12 + scalar(@t_files) );

my %SKIP = map { ( "t/$_" => 1 ) } qw(
	01_compile.t
	06_utils.t
	07_version.t
	08_style.t
	14_warnings.t
	21_task_thread.t
	22_task_worker.t
	23_task_chain.t
	24_task_master.t
	25_task_handle.t
	26_task_eval.t
	41_perl_project.t
	42_perl_project_temp.t
	61_directory_path.t
	62_directory_task.t
	63_directory_project.t
	83_autosave.t
	85_commandline.t
	92_padre_file.t
	93_padre_filename_win.t
	94_padre_file_remote.t
);

# A pathetic way to try to avoid tests that would use the real ~/.padre of the user
# that would be especially problematic if ran under root
foreach my $t_file (@t_files) {
	if ( $SKIP{$t_file} ) {
		my $Test = Test::Builder->new;
		$Test->skip($t_file);
	} else {
		my $content = read_file($t_file);
		ok $content =~ qr/PADRE_HOME|use\s+t::lib::Padre/, "Having PADRE_HOME or use t::lib::Padre $t_file";
	}
}

# Compile all of Padre
use File::Temp;
use POSIX qw(locale_h);
$ENV{PADRE_HOME} = File::Temp::tempdir( CLEANUP => 1 );
foreach my $module ( sort keys %modules ) {
	require_ok($module);

	ok( $module->VERSION, "$module: Found \$VERSION" );
}

# List of non-Wx modules still having Wx code.
# This list is way-the-hell too long, stop putting stuff in here just
# to prevent failing the test. It should be an absolute last resort.
# Go away and try to find a way to not have Wx stuff in your code first.
my %TODO = map { $_ => 1 } qw(
	Padre::CPAN
	Padre::Document
	Padre::File::FTP
	Padre::Locale
	Padre::MIME
	Padre::Plugin
	Padre::Plugin::Devel
	Padre::Plugin::My
	Padre::PluginManager
	Padre::Task::LaunchDefaultBrowser
	Padre::TaskHandle
);

foreach my $module ( sort keys %modules ) {
	my $content = read_file( $modules{$module} );

	# Checking if only modules with Wx in their name depend on Wx
	if ( $module =~ /^Padre::Wx/ or $module =~ /^Wx::/ ) {
		my $Test = Test::Builder->new;
		$Test->skip("$module is a Wx module");
	} elsif ( $module =~ /^Padre::Plugin::/ ) {

		# Plugins are exempt from this rule.
		my $Test = Test::Builder->new;
		$Test->skip("$module is a Wx module");
	} else {
		my ($error) = $content =~ m/^use\s+.*Wx.*;/gmx;
		my $Test = Test::Builder->new;
		if ( $TODO{$module} ) {
			$Test->todo_start("$module should not contain Wx but it still does");
		}
		ok( !$error, "'$module' does not use Wx" ) or diag $error;
		if ( $TODO{$module} ) {
			$Test->todo_end;
		}
	}

	ok( $content !~ /\$DB\:\:single/,
		$module . ' uses $DB::single - please remove before release',
	);

	# Load the document
	my $document = PPI::Document->new(
		$modules{$module},
		readonly => 1,
	);
	ok( $document, "$module: Parsable by PPI" );
	unless ($document) {
		diag( PPI::Document->errstr );
	}

	# If a class has a current method, never use Padre::Current directly
	SKIP: {
		unless (eval { $module->can('current') }
			and $module ne 'Padre::Current'
			and $module ne 'Padre::Wx::Role::Main' )
		{
			skip( "No ->current method", 1 );
		}
		my $good = !$document->find_any(
			sub {
				$_[1]->isa('PPI::Token::Word') or return '';
				$_[1]->content eq 'Padre::Current' or return '';
				my $arrow = $_[1]->snext_sibling or return '';
				$arrow->isa('PPI::Token::Operator') or return '';
				$arrow->content eq '->' or return '';
				my $method = $arrow->snext_sibling or return '';
				$method->isa('PPI::Token::Word') or return '';
				$method->content ne 'new' or return '';
				return 1;
			}
		);
		ok( $good, "$module: Don't use Padre::Current when ->current is possible" );
	}

	# If a class has an ide or main method, never use Padre->ide directly
	SKIP: {
		unless (
			eval { $module->can('ide') or $module->can('main') }

			# and $module ne 'Padre::Wx::Dialog::RegexEditor'
			and $module ne 'Padre::Current'
			)
		{
			skip( "$module: No ->ide or ->main method", 1 );
		}
		my $good = !$document->find_any(
			sub {
				$_[1]->isa('PPI::Token::Word') or return '';
				$_[1]->content eq 'Padre' or return '';
				my $arrow = $_[1]->snext_sibling or return '';
				$arrow->isa('PPI::Token::Operator') or return '';
				$arrow->content eq '->' or return '';
				my $method = $arrow->snext_sibling or return '';
				$method->isa('PPI::Token::Word') or return '';
				$method->content eq 'ide' or return '';
				return 1;
			}
		);
		ok( $good, "$module: Don't use Padre->ide when ->ide or ->main is possible" );
	}

	# Method names with :: in them can only be to SUPER::method
	SCOPE: {
		my $good = !$document->find_any(
			sub {
				$_[1]->isa('PPI::Token::Operator') or return '';
				$_[1]->content eq '->' or return '';

				# Get the method name
				my $name = $_[1]->snext_sibling or return '';
				$name->isa('PPI::Token::Word') or return '';
				$name->content =~ /::/ or return '';
				$name->content !~ /^SUPER::\w+$/ or return '';

				# Naughty naughty
				diag(
					"$module: Evil method name '$name', it should probably be a function call... maybe. Change it, but be careful."
				);
				return 1;
			}
		);
		ok( $good, "$module: Don't use extended Method::name other than SUPER::name" );
	}

	# Avoid expensive regexp result variables
	SKIP: {
		if ( $module eq 'Padre::Wx::Dialog::RegexEditor' ) {
			skip( 'Ignoring RegexEditor', 1 );
		}
		my $good = !$document->find_any(
			sub {
				$_[1]->isa('PPI::Token') or return '';
				$_[1]->significant or return '';
				$_[1]->content =~ /[^\$\'\"]\$[\&\'\`]/ or return '';
				return 1;
			}
		);
		ok( $good, "$module: Uses expensive regexp-variable \$&, \$\' or \$`" );
	}

	# Check for method calls that don't exist
	SKIP: {
		if ( $module =~ /\bRole\b/ ) {
			skip( "Ignoring module $module", 1 );
		}
		if ( $module eq 'Padre::Autosave' ) {
			skip( 'Ignoring flaky ORLite usage in Padre::Autosave', 1 );
		}

		my $tokens = $document->find(
			sub {
				$_[1]->isa('PPI::Token::Word') or return '';
				_IDENTIFIER( $_[1]->content )  or return '';

				# Is it a method
				my $operator = $_[1]->sprevious_sibling or return '';
				$operator->isa('PPI::Token::Operator') or return '';
				$operator->content eq '->' or return '';

				# Get the method name
				my $object = $operator->sprevious_sibling or return '';
				$object->isa('PPI::Token::Symbol') or return '';
				$object->content eq '$self' or return '';

				return 1;
			}
		);

		# Filter the tokens to get the method list
		my %seen = ();
		my @bad  = ();
		if ($tokens) {
			@bad = grep { not $module->can($_) } grep { not $seen{$_} } map { $_->content } @$tokens;
		}

		# There should be no missing methods
		is( scalar(@bad), 0, 'No missing methods' );
		foreach my $method (@bad) {
			diag("$module: Cannot resolve method \$self->$method");
		}
	}

	# Check for superfluous $self->current->foo that could be $self->foo
	SKIP: {
		my %seen   = ();
		my $tokens = $document->find(
			sub {

				# Start with a candidate foo method name
				$_[1]->isa('PPI::Token::Word') or return '';
				my $method = $_[1]->content or return '';
				_IDENTIFIER($method) or return '';
				$seen{$method}++ and return '';
				Padre::Current->can($method) or return '';
				$module->can($method) or return '';

				# First method to the left
				my $rightop = $_[1]->sprevious_sibling or return '';
				$rightop->isa('PPI::Token::Operator') or return '';
				$rightop->content eq '->' or return '';

				# The ->current method call
				my $current = $rightop->sprevious_sibling or return '';
				$current->isa('PPI::Token::Word') or return '';
				$current->content eq 'current' or return '';

				# Second method to the left
				my $leftop = $current->sprevious_sibling or return '';
				$leftop->isa('PPI::Token::Operator') or return '';
				$leftop->content eq '->' or return '';

				# $self on the far left
				my $variable = $leftop->sprevious_sibling or return '';
				if ( $variable->isa('PPI::Token::Symbol') ) {
					$variable->content eq '$self' and return 1;
				}

				# Alternatively, $_[0] on the far left
				$variable->isa('PPI::Structure::Subscript') or return '';
				my $subscript = $variable;
				$subscript->content eq '[0]' or return '';
				$variable = $subscript->sprevious_sibling or return '';
				$variable->isa('PPI::Token::Magic') or return '';
				$variable->content eq '$_' or return '';
				$variable->sprevious_sibling and return '';

				# In the form sub foo { $_[0]...
				my $statement = $variable->parent or return '';
				$statement->isa('PPI::Statement') or return '';
				my $block = $statement->parent or return '';
				$block->isa('PPI::Structure::Block') or return '';
				my $sub = $block->parent or return '';
				$sub->isa('PPI::Statement::Sub') or return '';

				return 1;
			}
		);

		# Filter the tokens to get the method list
		my @bad = ();
		if ($tokens) {
			@bad = map { $_->content } @$tokens;
		}

		# There should be no superfluous methods
		is( scalar(@bad), 0, 'No ->current->superfluous methods' );
		foreach my $method (@bad) {
			diag("$module: Superfluous ->current->$method, use ->$method");
		}
	}

	# Check for Wx::wxFOO constants that should be Wx::FOO
	SKIP: {
		if ( $module eq 'Padre::Wx::Constant' ) {
			skip( "Ignoring module $module", 1 );
		}
		if ( $module eq 'Padre::Startup' ) {
			skip( "Ignoring module $module", 1 );
		}

		my %seen   = ();
		my $tokens = $document->find(
			sub {
				$_[1]->isa('PPI::Token::Word') or return '';
				$_[1]->content =~ /^Wx::wx([A-Z].+)/ or return '';

				# Is this a new one?
				my $name = $1;
				return '' if $seen{$name}++;

				# Does the original and shortened forms of the
				# constant actually exist?
				Wx->can("wx$name") or return '';
				Wx->can($name) or return '';

				# wxVERSION is a special case
				$name eq 'VERSION' and return '';

				return 1;
			}
		);

		# Filter for the constant list
		my @bad = ();
		if ($tokens) {
			@bad = map { $_->content } @$tokens;
		}

		# There should be no unconverted wxCONSTANTS
		is( scalar(@bad), 0, 'No uncoverted wxCONSTANTS' );
		foreach my $name (@bad) {
			diag("$module: Unconverted constant $name");
		}
	}

	# Don't make direct system calls, use a Padre API instead
	# SKIP: {
	# my $good = !$document->find_any('PPI::Token::QuoteLike::Command');
	# ok( $good, "$module: Makes direct system calls with qx" );
	# }
}

sub read_file {
	my $file = shift;
	open my $fh, '<', $file or die "Could not read '$file': $!";
	local $/ = undef;
	return <$fh>;
}

1;
