lib/Moo/_Utils.pm

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