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