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     _unimport_coderefs _in_global_destruction
  20 );
  21
  22 sub _in_global_destruction ();
  23
  24 sub _install_modifier {
  25   my ($into, $type, $name, $code) = @_;
  26
  27   if (my $to_modify = $into->can($name)) { # CMM will throw for us if not
  28     require Sub::Defer;
  29     Sub::Defer::undefer_sub($to_modify);
  30   }
  31
  32   Class::Method::Modifiers::install_modifier(@_);
  33 }
  34
  35 our %MAYBE_LOADED;
  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   my $stash = _getstash($_[0])||{};
  43   return 1 if grep +(!ref($_) and *$_{CODE}), values %$stash;
  44   require_module($_[0]);
  45   return 1;
  46 }
  47
  48 sub _maybe_load_module {
  49   return $MAYBE_LOADED{$_[0]} if exists $MAYBE_LOADED{$_[0]};
  50   (my $proto = $_[0]) =~ s/::/\//g;
  51   local $@;
  52   if (eval { require "${proto}.pm"; 1 }) {
  53     $MAYBE_LOADED{$_[0]} = 1;
  54   } else {
  55     if (exists $INC{"${proto}.pm"}) {
  56       warn "$_[0] exists but failed to load with error: $@";
  57     }
  58     $MAYBE_LOADED{$_[0]} = 0;
  59   }
  60   return $MAYBE_LOADED{$_[0]};
  61 }
  62
  63 sub _get_linear_isa {
  64   return mro::get_linear_isa($_[0]);
  65 }
  66
  67 sub _install_coderef {
  68   no warnings 'redefine';
  69   *{_getglob($_[0])} = _name_coderef(@_);
  70 }
  71
  72 sub _name_coderef {
  73   shift if @_ > 2; # three args is (target, name, sub)
  74   can_haz_subname ? Sub::Name::subname(@_) : $_[1];
  75 }
  76
  77 sub _unimport_coderefs {
  78   my ($target, $info) = @_;
  79   return unless $info and my $exports = $info->{exports};
  80   my %rev = reverse %$exports;
  81   my $stash = _getstash($target);
  82   foreach my $name (keys %$exports) {
  83     if ($stash->{$name} and defined(&{$stash->{$name}})) {
  84       if ($rev{$target->can($name)}) {
  85         delete $stash->{$name};
  86       }
  87     }
  88   }
  89 }
  90
  91
  92 sub STANDARD_DESTROY {
  93   my $self = shift;
  94
  95   my $e = do {
  96     local $?;
  97     local $@;
  98     eval {
  99       $self->DEMOLISHALL(_in_global_destruction);
 100     };
 101     $@;
 102   };
 103
 104   no warnings 'misc';
 105   die $e if $e; # rethrow
 106 }
 107
 108 if (eval { use_module('Devel::GlobalDestruction', 0.07) }) {
 109   *_in_global_destruction = \&Devel::GlobalDestruction::in_global_destruction;
 110 } elsif (defined ${^GLOBAL_PHASE}) {
 111   eval 'sub _in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }';
 112 } else {
 113   eval <<'PP_IGD' or die $@;
 114
 115 my ($in_global_destruction, $before_is_installed);
 116
 117 sub _in_global_destruction () { $in_global_destruction }
 118
 119 END {
 120   # SpeedyCGI runs END blocks every cycle but somehow keeps object instances
 121   # hence lying about it seems reasonable...ish
 122   $in_global_destruction = 1 unless $CGI::SpeedyCGI::i_am_speedy;
 123 }
 124
 125 # threads do not execute the global ENDs (it would be stupid). However
 126 # one can register a new END via simple string eval within a thread, and
 127 # achieve the same result. A logical place to do this would be CLONE, which
 128 # is claimed to run in the context of the new thread. However this does
 129 # not really seem to be the case - any END evaled in a CLONE is ignored :(
 130 # Hence blatantly hooking threads::create
 131
 132 if ($INC{'threads.pm'}) {
 133   my $orig_create = threads->can('create');
 134   no warnings 'redefine';
 135   *threads::create = sub {
 136     { local $@; eval 'END { $in_global_destruction = 1 }' };
 137     goto $orig_create;
 138   };
 139   $before_is_installed = 1;
 140 }
 141
 142 # just in case threads got loaded after us (silly)
 143 sub CLONE {
 144   unless ($before_is_installed) {
 145     require Carp;
 146     Carp::croak("You must load the 'threads' module before @{[ __PACKAGE__ ]}");
 147   }
 148 }
 149
 150 1;  # keep eval happy
 151
 152 PP_IGD
 153
 154 }
 155
 156 1;