package interface;

use strict;
use warnings;

use Carp;

use abstract;

sub DEBUG { 0 };

$| ||= DEBUG;

my %packageInterfaces;
my %packageLocks;

sub debug
{
	print STDERR "DEBUG: ", @_, "\n" if (DEBUG);
}  # debug

sub import
{
	my $callerPackage = caller ();
	debug ("Caller package is $callerPackage");

	__lockPackage ($callerPackage) || return;

	$packageInterfaces{$callerPackage} = [ @_[1..$#_] ];

	eval <<EOF;
package $callerPackage;

CHECK { interface::verifyInterfaces () };
EOF

	die ($@) if ($@);

	__unlockPackage ($callerPackage);
}  # import

sub verifyInterfaces
{
	my $callerPackage = caller ();
	debug ("Caller package is $callerPackage");

	__lockPackage ($callerPackage) || return;

	return unless (exists ($packageInterfaces{$callerPackage}));
	my @implementedInterfaces = @{ $packageInterfaces{$callerPackage} };
	delete $packageInterfaces{$callerPackage};
	debug ("Implemented interfaces: ", @implementedInterfaces);

	my @failedMethods;
	foreach my $interface (@implementedInterfaces)
		{
			__loadPackageIntoNamespace ($interface, $callerPackage)
			   || croak ("Failed to load interface $interface");

			my @interfaceFailedMethods
			   = __checkImplements ($interface, $callerPackage);
			if (@interfaceFailedMethods)
				{
					push (@failedMethods, @interfaceFailedMethods);
					next;
				}

			no strict 'refs';
			push (@{ $callerPackage . "::ISA" }, $interface);
			use strict 'refs';

			debug ("Successfully implemented $interface");
		}

	croak ("$callerPackage fails to implement: "
	       . join (', ', @failedMethods)) if (@failedMethods);

  __unlockPackage ($callerPackage);
}  # verifyInterfaces

sub __loadPackageIntoNamespace
{
	my ($packageToLoad, $targetNamespace) = @_;

	debug ("Attempting to load $packageToLoad into namespace $targetNamespace");
	eval ("package $targetNamespace; use $packageToLoad");

	my $result = defined (%{ $packageToLoad . "::" });
	debug ("Loading ", (($result) ? "" : "un") . "successful");

	return $result;
}  # __loadPackageIntoNamespace

sub __checkImplements
{
	my ($interfacePackage, $implementorPackage) = @_;

	my @failedFullyQualifiedMethods;

	foreach my $package (__crawlClassHierarchy ($interfacePackage))
		{
			my @failedMethods = __findMissingMethods ($package, $implementorPackage);
			push (@failedFullyQualifiedMethods,
			      map { $package . "::$_" } @failedMethods);
		}

	return @failedFullyQualifiedMethods;
}  # __checkImplements

sub __crawlClassHierarchy
{
	my $package = shift;
	my $visitedPackages = shift || { $package => 1 };

	my @packages = ($package,);

	return @packages unless (defined (@{ $package . '::ISA' }));

	debug ("Crawling through package $package");

	no strict 'refs';
	my %ignoredPackages
	   = map { $_ => 1 } @{ "${package}::INTERFACE_IGNORED_PACKAGES" };

	foreach my $parentPackage (@{ $package . '::ISA' })
		{
			next if (exists ($ignoredPackages{$parentPackage})
			         || exists ($visitedPackages->{$parentPackage}));
			$visitedPackages->{$parentPackage} = 1;

			unless (__loadPackageIntoNamespace ($parentPackage, $package))
				{
					carp ("Missing interface $parentPackage used by interface $package");
					next;
				}

			push (@packages,
			      __crawlClassHierarchy ($parentPackage, $visitedPackages));
		}
	use strict 'refs';

	return @packages;
}  # __crawlClassHierarchy

sub __findMissingMethods
{
	my ($interfacePackage, $implementorPackage) = @_;

	my @missingMethodNames;

	no strict 'refs';
	my %ignoredMethods
	   = map { $_ => 1 } @{ "${interfacePackage}::INTERFACE_IGNORED_METHODS" };

	foreach my $methodName (grep { defined (&{ $interfacePackage . "::$_" }) }
	                             keys (%{ $interfacePackage . '::' }))
		{
			next if (exists ($ignoredMethods{$methodName}));
			# Special handling for abstract.pm.
			next if (($methodName eq "abstract")
			         && (*{ $interfacePackage . "::$methodName"}{CODE}
			             eq *abstract::abstract{CODE}));
			debug ("Checking for method $methodName");
			push (@missingMethodNames, $methodName)
			   unless (eval ("$implementorPackage->can ('$methodName')"));
		}
	use strict 'refs';

	return @missingMethodNames;
}  # __findMissingMethods

sub __lockPackage
{
	my $packageName = shift;

	debug ("Testing lock on package $packageName");
	return 0 if ($packageLocks{$packageName});

	$packageLocks{$packageName} = 1;
	debug ("Acquired lock for $packageName");
	return 1;
}  # __lockPackage

sub __unlockPackage
{
	my $packageName = shift;

	$packageLocks{$packageName} = 0;
	debug ("Released lock for $packageName");
} # __unlockPackage

1;