Commit | Line | Data |
b1eebd55 |
1 | package Moo::_Utils; |
6c74d087 |
2 | |
0fe2ad8c |
3 | no warnings 'once'; # guard against -w |
4 | |
119014a7 |
5 | sub _getglob { \*{$_[0]} } |
5ed7d68a |
6 | sub _getstash { \%{"$_[0]::"} } |
119014a7 |
7 | |
575ba24c |
8 | use constant lt_5_8_3 => ( $] < 5.008003 ) ? 1 : 0; |
9 | use constant can_haz_subname => eval { require Sub::Name }; |
2215d4b9 |
10 | |
6c74d087 |
11 | use strictures 1; |
cf62c989 |
12 | use Module::Runtime qw(require_module); |
6c74d087 |
13 | use base qw(Exporter); |
3c739397 |
14 | use Moo::_mro; |
6c74d087 |
15 | |
3c739397 |
16 | our @EXPORT = qw( |
17 | _getglob _install_modifier _load_module _maybe_load_module |
575ba24c |
18 | _get_linear_isa _getstash _install_coderef _name_coderef |
108f8ddc |
19 | _unimport_coderefs _in_global_destruction |
3c739397 |
20 | ); |
6c74d087 |
21 | |
f57f1133 |
22 | sub _in_global_destruction (); |
19e0e749 |
23 | |
6c74d087 |
24 | sub _install_modifier { |
6c74d087 |
25 | my ($into, $type, $name, $code) = @_; |
a165a07f |
26 | |
dccea57d |
27 | if (my $to_modify = $into->can($name)) { # CMM will throw for us if not |
7568ba55 |
28 | require Sub::Defer; |
dccea57d |
29 | Sub::Defer::undefer_sub($to_modify); |
30 | } |
a165a07f |
31 | |
6c74d087 |
32 | Class::Method::Modifiers::install_modifier(@_); |
33 | } |
34 | |
daa05b62 |
35 | our %MAYBE_LOADED; |
36 | |
fb5074f6 |
37 | sub _load_module { |
fb5074f6 |
38 | (my $proto = $_[0]) =~ s/::/\//g; |
5ed7d68a |
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 |
2a577e53 |
42 | my $stash = _getstash($_[0])||{}; |
43 | return 1 if grep +(!ref($_) and *$_{CODE}), values %$stash; |
cf62c989 |
44 | require_module($_[0]); |
fb5074f6 |
45 | return 1; |
46 | } |
47 | |
daa05b62 |
48 | sub _maybe_load_module { |
49 | return $MAYBE_LOADED{$_[0]} if exists $MAYBE_LOADED{$_[0]}; |
50 | (my $proto = $_[0]) =~ s/::/\//g; |
59812c87 |
51 | local $@; |
daa05b62 |
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 | |
3c739397 |
63 | sub _get_linear_isa { |
575ba24c |
64 | return mro::get_linear_isa($_[0]); |
65 | } |
66 | |
67 | sub _install_coderef { |
eda5c714 |
68 | no warnings 'redefine'; |
575ba24c |
69 | *{_getglob($_[0])} = _name_coderef(@_); |
70 | } |
71 | |
72 | sub _name_coderef { |
67a95e30 |
73 | shift if @_ > 2; # three args is (target, name, sub) |
575ba24c |
74 | can_haz_subname ? Sub::Name::subname(@_) : $_[1]; |
3c739397 |
75 | } |
76 | |
108f8ddc |
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 | |
59812c87 |
92 | sub STANDARD_DESTROY { |
93 | my $self = shift; |
94 | |
95 | my $e = do { |
96 | local $?; |
97 | local $@; |
98 | eval { |
19e0e749 |
99 | $self->DEMOLISHALL(_in_global_destruction); |
59812c87 |
100 | }; |
101 | $@; |
102 | }; |
103 | |
104 | no warnings 'misc'; |
105 | die $e if $e; # rethrow |
106 | } |
107 | |
094ba1f3 |
108 | if (eval { use_module('Devel::GlobalDestruction', 0.07) }) { |
f57f1133 |
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] }'; |
19e0e749 |
112 | } else { |
113 | eval <<'PP_IGD' or die $@; |
114 | |
115 | my ($in_global_destruction, $before_is_installed); |
116 | |
f57f1133 |
117 | sub _in_global_destruction () { $in_global_destruction } |
19e0e749 |
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 | |
6c74d087 |
156 | 1; |