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     _unimport_coderefs _in_global_destruction
  21 );
  22
  23 sub _in_global_destruction ();
  24 *_in_global_destruction = \&Devel::GlobalDestruction::in_global_destruction;
  25
  26 sub _install_modifier {
  27   my ($into, $type, $name, $code) = @_;
  28
  29   if (my $to_modify = $into->can($name)) { # CMM will throw for us if not
  30     require Sub::Defer;
  31     Sub::Defer::undefer_sub($to_modify);
  32   }
  33
  34   Class::Method::Modifiers::install_modifier(@_);
  35 }
  36
  37 our %MAYBE_LOADED;
  38
  39 sub _load_module {
  40   (my $proto = $_[0]) =~ s/::/\//g;
  41   return 1 if $INC{"${proto}.pm"};
  42   # can't just ->can('can') because a sub-package Foo::Bar::Baz
  43   # creates a 'Baz::' key in Foo::Bar's symbol table
  44   my $stash = _getstash($_[0])||{};
  45   return 1 if grep +(!ref($_) and *$_{CODE}), values %$stash;
  46   require_module($_[0]);
  47   return 1;
  48 }
  49
  50 sub _maybe_load_module {
  51   return $MAYBE_LOADED{$_[0]} if exists $MAYBE_LOADED{$_[0]};
  52   (my $proto = $_[0]) =~ s/::/\//g;
  53   local $@;
  54   if (eval { require "${proto}.pm"; 1 }) {
  55     $MAYBE_LOADED{$_[0]} = 1;
  56   } else {
  57     if (exists $INC{"${proto}.pm"}) {
  58       warn "$_[0] exists but failed to load with error: $@";
  59     }
  60     $MAYBE_LOADED{$_[0]} = 0;
  61   }
  62   return $MAYBE_LOADED{$_[0]};
  63 }
  64
  65 sub _get_linear_isa {
  66   return mro::get_linear_isa($_[0]);
  67 }
  68
  69 sub _install_coderef {
  70   no warnings 'redefine';
  71   *{_getglob($_[0])} = _name_coderef(@_);
  72 }
  73
  74 sub _name_coderef {
  75   shift if @_ > 2; # three args is (target, name, sub)
  76   can_haz_subname ? Sub::Name::subname(@_) : $_[1];
  77 }
  78
  79 sub _unimport_coderefs {
  80   my ($target, $info) = @_;
  81   return unless $info and my $exports = $info->{exports};
  82   my %rev = reverse %$exports;
  83   my $stash = _getstash($target);
  84   foreach my $name (keys %$exports) {
  85     if ($stash->{$name} and defined(&{$stash->{$name}})) {
  86       if ($rev{$target->can($name)}) {
  87         delete $stash->{$name};
  88       }
  89     }
  90   }
  91 }
  92
  93 sub STANDARD_DESTROY {
  94   my $self = shift;
  95
  96   my $e = do {
  97     local $?;
  98     local $@;
  99     eval {
 100       $self->DEMOLISHALL(_in_global_destruction);
 101     };
 102     $@;
 103   };
 104
 105   no warnings 'misc';
 106   die $e if $e; # rethrow
 107 }
 108
 109 1;