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); |
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)}) { | |
87 | delete $stash->{$name}; | |
88 | } | |
89 | } | |
90 | } | |
91 | } | |
92 | ||
59812c87 | 93 | sub STANDARD_DESTROY { |
94 | my $self = shift; | |
95 | ||
96 | my $e = do { | |
97 | local $?; | |
98 | local $@; | |
99 | eval { | |
19e0e749 | 100 | $self->DEMOLISHALL(_in_global_destruction); |
59812c87 | 101 | }; |
102 | $@; | |
103 | }; | |
104 | ||
105 | no warnings 'misc'; | |
106 | die $e if $e; # rethrow | |
107 | } | |
108 | ||
6c74d087 | 109 | 1; |