use slow path for role create_class_with_roles under custom accessor generator
[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 Devel::GlobalDestruction;
14 use base qw(Exporter);
15 use Moo::_mro;
16
17 our @EXPORT = qw(
18     _getglob _install_modifier _load_module _maybe_load_module
19     _get_linear_isa _getstash _install_coderef _name_coderef
20 );
21
22 sub _install_modifier {
23   my ($into, $type, $name, $code) = @_;
24
25   if (my $to_modify = $into->can($name)) { # CMM will throw for us if not
26     require Sub::Defer;
27     Sub::Defer::undefer_sub($to_modify);
28   }
29
30   Class::Method::Modifiers::install_modifier(@_);
31 }
32
33 our %MAYBE_LOADED;
34
35 sub _load_module {
36   (my $proto = $_[0]) =~ s/::/\//g;
37   return 1 if $INC{"${proto}.pm"};
38   # can't just ->can('can') because a sub-package Foo::Bar::Baz
39   # creates a 'Baz::' key in Foo::Bar's symbol table
40   my $stash = _getstash($_[0])||{};
41   return 1 if grep +(!ref($_) and *$_{CODE}), values %$stash;
42   require_module($_[0]);
43   return 1;
44 }
45
46 sub _maybe_load_module {
47   return $MAYBE_LOADED{$_[0]} if exists $MAYBE_LOADED{$_[0]};
48   (my $proto = $_[0]) =~ s/::/\//g;
49   local $@;
50   if (eval { require "${proto}.pm"; 1 }) {
51     $MAYBE_LOADED{$_[0]} = 1;
52   } else {
53     if (exists $INC{"${proto}.pm"}) {
54       warn "$_[0] exists but failed to load with error: $@";
55     }
56     $MAYBE_LOADED{$_[0]} = 0;
57   }
58   return $MAYBE_LOADED{$_[0]};
59 }
60
61 sub _get_linear_isa {
62   return mro::get_linear_isa($_[0]);
63 }
64
65 sub _install_coderef {
66   *{_getglob($_[0])} = _name_coderef(@_);
67 }
68
69 sub _name_coderef {
70   can_haz_subname ? Sub::Name::subname(@_) : $_[1];
71 }
72
73 sub STANDARD_DESTROY {
74   my $self = shift;
75
76   my $e = do {
77     local $?;
78     local $@;
79     eval {
80       $self->DEMOLISHALL(in_global_destruction);
81     };
82     $@;
83   };
84
85   no warnings 'misc';
86   die $e if $e; # rethrow
87 }
88
89 1;