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