File Coverage

lib/Module/Notify.pm

Criterion	Covered	Total	%
statement	65	65	100.0
branch	11	18	61.1
condition	4	4	100.0
subroutine	16	16	100.0
pod	2	2	100.0
total	98	105	93.3

package Module::Notify;

use 5.008;
use strict;
use warnings;
no warnings qw( void once uninitialized numeric );

BEGIN {
	$Module::Notify::AUTHORITY = 'cpan:TOBYINK';
	$Module::Notify::VERSION   = '0.001';
}

use Carp qw(croak);
sub _refaddr { 0+$_[0] };

sub _module_notional_filename
{
	my $module = $_[0];
	$module =~ s{::}{/}g;
	return "$module\.pm";
}

sub _unmodule_notional_filename
{
	my $module = $_[0];
	$module =~ s{\.pmc?$}{};
	$module =~ s{/}{::}g;
	return $module;
}

sub _clean_err
{
	chomp(my $err = shift);
	$err =~ s/ at \(eval [0-9]+\) line [0-9]+\.?$//g;
	return "$err";
}

our %NOTIFICATIONS;

sub new
{
	my $class = shift;
	my ($module, $callback) = @_;

	# Make sure hook is installed
	my $H = $class->_inc_hook;
	@INC = ($H, grep $_ != $H, @INC) unless $INC[0]==$H;

	push @{$NOTIFICATIONS{$module} ||= []}, $callback;

	return $class->_run_notifications(module => $module)
		if $INC{_module_notional_filename($module)};

	bless [ $module, _refaddr($callback) ], $class;
}

sub cancel
{
	my $self = shift;
	my ($module, $refaddr) = @$self;
	$NOTIFICATIONS{$module} = [
		grep _refaddr($_)!=$refaddr, @{$NOTIFICATIONS{$module} || []}
	];
	return;
}

sub _run_notifications
{
	my $class = shift;
	my ($type, $module) = @_;
	$module = _unmodule_notional_filename($module) if $type eq "filename";

	while (my $code = shift @{$NOTIFICATIONS{$module} || []})
	{
		$code->($module);
	}

	return;
}

sub _has_notifications
{
	my $class = shift;
	my ($type, $module) = @_;
	$module = _unmodule_notional_filename($module) if $type eq "filename";

	!!@{$NOTIFICATIONS{$module} || []};
}

{
	my $hook;
	sub _inc_hook
	{
		my $class = shift;
		$hook ||= sub {
			my $self = shift;
			return unless $class->_has_notifications(filename => $_[0]);
			@INC = grep $_ != $self, @INC;
			my $r = eval "require '$_[0]'";
			unshift @INC, $self;
			$r ? $class->_run_notifications(filename => $_[0]) : croak(_clean_err $@);
			my @lines = ($r, undef);
			return sub { $_ = shift @lines; !!@lines };
		};
	}
}

1;

__END__