inline Devel::GlobalDestruction pure perl code temporarily
[gitmo/Moo.git] / 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     _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   *{_getglob($_[0])} = _name_coderef(@_);
69 }
70
71 sub _name_coderef {
72   shift if @_ > 2; # three args is (target, name, sub)
73   can_haz_subname ? Sub::Name::subname(@_) : $_[1];
74 }
75
76 sub STANDARD_DESTROY {
77   my $self = shift;
78
79   my $e = do {
80     local $?;
81     local $@;
82     eval {
83       $self->DEMOLISHALL(_in_global_destruction);
84     };
85     $@;
86   };
87
88   no warnings 'misc';
89   die $e if $e; # rethrow
90 }
91
92 if (defined ${^GLOBAL_PHASE}) {
93     eval 'sub _in_global_destruction () { ${^GLOBAL_PHASE} eq q[DESTRUCT] }';
94 } else {
95   eval <<'PP_IGD' or die $@;
96
97 my ($in_global_destruction, $before_is_installed);
98
99 sub _in_global_destruction { $in_global_destruction }
100
101 END {
102   # SpeedyCGI runs END blocks every cycle but somehow keeps object instances
103   # hence lying about it seems reasonable...ish
104   $in_global_destruction = 1 unless $CGI::SpeedyCGI::i_am_speedy;
105 }
106
107 # threads do not execute the global ENDs (it would be stupid). However
108 # one can register a new END via simple string eval within a thread, and
109 # achieve the same result. A logical place to do this would be CLONE, which
110 # is claimed to run in the context of the new thread. However this does
111 # not really seem to be the case - any END evaled in a CLONE is ignored :(
112 # Hence blatantly hooking threads::create
113
114 if ($INC{'threads.pm'}) {
115   my $orig_create = threads->can('create');
116   no warnings 'redefine';
117   *threads::create = sub {
118     { local $@; eval 'END { $in_global_destruction = 1 }' };
119     goto $orig_create;
120   };
121   $before_is_installed = 1;
122 }
123
124 # just in case threads got loaded after us (silly)
125 sub CLONE {
126   unless ($before_is_installed) {
127     require Carp;
128     Carp::croak("You must load the 'threads' module before @{[ __PACKAGE__ ]}");
129   }
130 }
131
132 1;  # keep eval happy
133
134 PP_IGD
135
136 }
137
138 1;