view release on metacpan or  search on metacpan

lib/evil.pm  view on Meta::CPAN

use strict;
use warnings;

use Carp;

my $INTERMEDIATE = __PACKAGE__.'/intermediate';
my $LAX          = __PACKAGE__.'/lax';

our $VERSION = 0.003002;

our %tainted;
our %wants_strict;

sub import {
	croak "Cannot load evil module when \"no evil ':strict'\" is in effect" if %wants_strict;

	my $hinthash = (caller 0)[10] || {};
	croak "Current module requested no evilness" if $hinthash->{$LAX};

	$hinthash = (caller 3)[10] || {};
	croak "Cannot load evil module when parent requested \"no evil ':lax'\"" if $hinthash->{$LAX};

	my $level = 4;
	my @caller;
	while (@caller = caller $level) {
		$hinthash = $caller[10] || {};
		croak "Cannot load evil module when ancestor requested \"no evil ':intermediate'\""
		  if $hinthash->{$INTERMEDIATE};
		$level++;
	}

	$tainted{caller()} = 1;
}

sub unimport {
	my $strict_arg = grep /^:strict$/i, @_;
	my $intermediate_arg = grep /^:intermediate$/i, @_;
	my $lax_arg = grep /^:lax$/i, @_;
	my $disable_arg = grep /^:disable$/i, @_;

	if (!$disable_arg && $tainted{caller()}) { # caller is evil
		croak 'Current module is evil'
	}

	if ($strict_arg) {
		$wants_strict{caller()} = 1;
		croak "Evil module already loaded. Cannot enforce \"no evil ':strict'\"" if %tainted
	} elsif ($lax_arg) {
		$^H{$LAX} = 1
	} elsif ($disable_arg) {
		delete $wants_strict{caller()};
		delete $^H{$LAX};
		delete $^H{$INTERMEDIATE};
	} else { # $intermediate_arg or no arg
		$^H{$INTERMEDIATE} = $^H{$LAX} = 1
	}
}