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 Devel::GlobalDestruction;
  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 _getstash _install_coderef _name_coderef
  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     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 sub _load_module {
  36   (my $proto = $_[0]) =~ s/::/\//g;
  37   return 1 if $INC{"${proto}.pm"};
  38   # can't just ->can('can') because a sub-package Foo::Bar::Baz
  39   # creates a 'Baz::' key in Foo::Bar's symbol table
  40   my $stash = _getstash($_[0])||{};
  41   return 1 if grep +(!ref($_) and *$_{CODE}), values %$stash;
  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 sub _install_coderef {
  66   *{_getglob($_[0])} = _name_coderef(@_);
  67 }
  68
  69 sub _name_coderef {
  70   shift if @_ > 2;
  71   can_haz_subname ? Sub::Name::subname(@_) : $_[1];
  72 }
  73
  74 sub STANDARD_DESTROY {
  75   my $self = shift;
  76
  77   my $e = do {
  78     local $?;
  79     local $@;
  80     eval {
  81       $self->DEMOLISHALL(in_global_destruction);
  82     };
  83     $@;
  84   };
  85
  86   no warnings 'misc';
  87   die $e if $e; # rethrow
  88 }
  89
  90 1;