lib/Moo/_Utils.pm

   1 package Moo::_Utils;
   2
   3 sub _getglob { \*{$_[0]} }
   4 sub _getstash { \%{"$_[0]::"} }
   5
   6 BEGIN {
   7   *lt_5_8_3 = $] < 5.008003
   8     ? sub () { 1 }
   9     : sub () { 0 }
  10   ;
  11 }
  12
  13 use strictures 1;
  14 use Module::Runtime qw(require_module);
  15 use base qw(Exporter);
  16 use Moo::_mro;
  17
  18 our @EXPORT = qw(
  19     _getglob _install_modifier _load_module _maybe_load_module
  20     _get_linear_isa
  21 );
  22
  23 sub _install_modifier {
  24   my ($into, $type, $name, $code) = @_;
  25
  26   if (my $to_modify = $into->can($name)) { # CMM will throw for us if not
  27     require Sub::Defer;
  28     Sub::Defer::undefer_sub($to_modify);
  29   }
  30
  31   Class::Method::Modifiers::install_modifier(@_);
  32 }
  33
  34 our %MAYBE_LOADED;
  35
  36 sub _load_module {
  37   (my $proto = $_[0]) =~ s/::/\//g;
  38   return 1 if $INC{"${proto}.pm"};
  39   # can't just ->can('can') because a sub-package Foo::Bar::Baz
  40   # creates a 'Baz::' key in Foo::Bar's symbol table
  41   return 1 if grep !/::$/, keys %{_getstash($_[0])||{}};
  42   require_module($_[0]);
  43   return 1;
  44 }
  45
  46 sub _maybe_load_module {
  47   return $MAYBE_LOADED{$_[0]} if exists $MAYBE_LOADED{$_[0]};
  48   (my $proto = $_[0]) =~ s/::/\//g;
  49   local $@;
  50   if (eval { require "${proto}.pm"; 1 }) {
  51     $MAYBE_LOADED{$_[0]} = 1;
  52   } else {
  53     if (exists $INC{"${proto}.pm"}) {
  54       warn "$_[0] exists but failed to load with error: $@";
  55     }
  56     $MAYBE_LOADED{$_[0]} = 0;
  57   }
  58   return $MAYBE_LOADED{$_[0]};
  59 }
  60
  61 sub _get_linear_isa {
  62     return mro::get_linear_isa($_[0]);
  63 }
  64
  65 our $_in_global_destruction = 0;
  66 END { $_in_global_destruction = 1 }
  67
  68 sub STANDARD_DESTROY {
  69   my $self = shift;
  70
  71   my $e = do {
  72     local $?;
  73     local $@;
  74     eval {
  75       $self->DEMOLISHALL($_in_global_destruction);
  76     };
  77     $@;
  78   };
  79
  80   no warnings 'misc';
  81   die $e if $e; # rethrow
  82 }
  83
  84 1;