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 | |
e25e8acf |
8 | use constant lt_5_8_3 => ( $] < 5.008003 or $ENV{MOO_TEST_PRE_583} ) ? 1 : 0; |
575ba24c |
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); |
7d0a35fa |
13 | use Devel::GlobalDestruction (); |
6c74d087 |
14 | use base qw(Exporter); |
3c739397 |
15 | use Moo::_mro; |
6c74d087 |
16 | |
3c739397 |
17 | our @EXPORT = qw( |
18 | _getglob _install_modifier _load_module _maybe_load_module |
575ba24c |
19 | _get_linear_isa _getstash _install_coderef _name_coderef |
108f8ddc |
20 | _unimport_coderefs _in_global_destruction |
3c739397 |
21 | ); |
6c74d087 |
22 | |
f57f1133 |
23 | sub _in_global_destruction (); |
7d0a35fa |
24 | *_in_global_destruction = \&Devel::GlobalDestruction::in_global_destruction; |
19e0e749 |
25 | |
6c74d087 |
26 | sub _install_modifier { |
6c74d087 |
27 | my ($into, $type, $name, $code) = @_; |
a165a07f |
28 | |
dccea57d |
29 | if (my $to_modify = $into->can($name)) { # CMM will throw for us if not |
7568ba55 |
30 | require Sub::Defer; |
dccea57d |
31 | Sub::Defer::undefer_sub($to_modify); |
32 | } |
a165a07f |
33 | |
6c74d087 |
34 | Class::Method::Modifiers::install_modifier(@_); |
35 | } |
36 | |
daa05b62 |
37 | our %MAYBE_LOADED; |
38 | |
fb5074f6 |
39 | sub _load_module { |
fb5074f6 |
40 | (my $proto = $_[0]) =~ s/::/\//g; |
5ed7d68a |
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 |
2a577e53 |
44 | my $stash = _getstash($_[0])||{}; |
45 | return 1 if grep +(!ref($_) and *$_{CODE}), values %$stash; |
cf62c989 |
46 | require_module($_[0]); |
fb5074f6 |
47 | return 1; |
48 | } |
49 | |
daa05b62 |
50 | sub _maybe_load_module { |
51 | return $MAYBE_LOADED{$_[0]} if exists $MAYBE_LOADED{$_[0]}; |
52 | (my $proto = $_[0]) =~ s/::/\//g; |
59812c87 |
53 | local $@; |
daa05b62 |
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 | |
3c739397 |
65 | sub _get_linear_isa { |
575ba24c |
66 | return mro::get_linear_isa($_[0]); |
67 | } |
68 | |
69 | sub _install_coderef { |
eda5c714 |
70 | no warnings 'redefine'; |
575ba24c |
71 | *{_getglob($_[0])} = _name_coderef(@_); |
72 | } |
73 | |
74 | sub _name_coderef { |
67a95e30 |
75 | shift if @_ > 2; # three args is (target, name, sub) |
575ba24c |
76 | can_haz_subname ? Sub::Name::subname(@_) : $_[1]; |
3c739397 |
77 | } |
78 | |
108f8ddc |
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)}) { |
f2434ccb |
87 | my $old = delete $stash->{$name}; |
88 | my $full_name = join('::',$target,$name); |
89 | # Copy everything except the code slot back into place (e.g. $has) |
90 | foreach my $type (qw(SCALAR HASH ARRAY IO)) { |
91 | next unless defined(*{$old}{$type}); |
92 | no strict 'refs'; |
93 | *$full_name = *{$old}{$type}; |
94 | } |
108f8ddc |
95 | } |
96 | } |
97 | } |
98 | } |
99 | |
59812c87 |
100 | sub STANDARD_DESTROY { |
101 | my $self = shift; |
102 | |
103 | my $e = do { |
104 | local $?; |
105 | local $@; |
106 | eval { |
19e0e749 |
107 | $self->DEMOLISHALL(_in_global_destruction); |
59812c87 |
108 | }; |
109 | $@; |
110 | }; |
111 | |
112 | no warnings 'misc'; |
113 | die $e if $e; # rethrow |
114 | } |
115 | |
6c74d087 |
116 | 1; |