X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMoo%2F_Utils.pm;h=a228805d785bddae0f3b9a2eec36ce1147586fb3;hb=2a577e534860775e35e35410075a38acc91f8fb0;hp=6bf8f2272ce61ef675a19d868c8b87dac0c90d33;hpb=dccea57d17d218806e5770d0044c85e30c38e8da;p=gitmo%2FMoo.git diff --git a/lib/Moo/_Utils.pm b/lib/Moo/_Utils.pm index 6bf8f22..a228805 100644 --- a/lib/Moo/_Utils.pm +++ b/lib/Moo/_Utils.pm @@ -1,11 +1,26 @@ package Moo::_Utils; +no warnings 'once'; # guard against -w + +sub _getglob { \*{$_[0]} } +sub _getstash { \%{"$_[0]::"} } + +BEGIN { + *lt_5_8_3 = $] < 5.008003 + ? sub () { 1 } + : sub () { 0 } + ; +} + use strictures 1; +use Module::Runtime qw(require_module); use base qw(Exporter); +use Moo::_mro; -our @EXPORT = qw(_getglob _install_modifier _load_module _maybe_load_module); - -sub _getglob { no strict 'refs'; \*{$_[0]} } +our @EXPORT = qw( + _getglob _install_modifier _load_module _maybe_load_module + _get_linear_isa _getstash +); sub _install_modifier { my ($into, $type, $name, $code) = @_; @@ -21,15 +36,20 @@ sub _install_modifier { our %MAYBE_LOADED; sub _load_module { - return 1 if $_[0]->can('can'); (my $proto = $_[0]) =~ s/::/\//g; - require "${proto}.pm"; + return 1 if $INC{"${proto}.pm"}; + # can't just ->can('can') because a sub-package Foo::Bar::Baz + # creates a 'Baz::' key in Foo::Bar's symbol table + my $stash = _getstash($_[0])||{}; + return 1 if grep +(!ref($_) and *$_{CODE}), values %$stash; + require_module($_[0]); return 1; } sub _maybe_load_module { return $MAYBE_LOADED{$_[0]} if exists $MAYBE_LOADED{$_[0]}; (my $proto = $_[0]) =~ s/::/\//g; + local $@; if (eval { require "${proto}.pm"; 1 }) { $MAYBE_LOADED{$_[0]} = 1; } else { @@ -41,4 +61,27 @@ sub _maybe_load_module { return $MAYBE_LOADED{$_[0]}; } +sub _get_linear_isa { + return mro::get_linear_isa($_[0]); +} + +our $_in_global_destruction = 0; +END { $_in_global_destruction = 1 } + +sub STANDARD_DESTROY { + my $self = shift; + + my $e = do { + local $?; + local $@; + eval { + $self->DEMOLISHALL($_in_global_destruction); + }; + $@; + }; + + no warnings 'misc'; + die $e if $e; # rethrow +} + 1;