Commit | Line | Data |
d245e471 |
1 | package Moo::Role; |
2 | |
3 | use strictures 1; |
4 | use Moo::_Utils; |
5 | use base qw(Role::Tiny); |
6 | |
7 | BEGIN { *INFO = \%Role::Tiny::INFO } |
8 | |
9 | our %INFO; |
10 | |
11 | sub import { |
12 | my $target = caller; |
13 | strictures->import; |
14 | # get symbol table reference |
15 | my $stash = do { no strict 'refs'; \%{"${target}::"} }; |
16 | *{_getglob "${target}::has"} = sub { |
17 | my ($name, %spec) = @_; |
18 | ($INFO{$target}{accessor_maker} ||= do { |
19 | require Method::Generate::Accessor; |
20 | Method::Generate::Accessor->new |
21 | })->generate_method($target, $name, \%spec); |
22 | $INFO{$target}{attributes}{$name} = \%spec; |
23 | }; |
24 | goto &Role::Tiny::import; |
25 | } |
26 | |
27 | sub apply_role_to_package { |
28 | my ($me, $role, $to) = @_; |
29 | $me->SUPER::apply_role_to_package($role, $to); |
30 | $me->_handle_constructor($to, $INFO{$role}{attributes}); |
31 | } |
32 | |
33 | sub create_class_with_roles { |
34 | my ($me, $superclass, @roles) = @_; |
35 | |
36 | my $new_name = join('+', $superclass, my $compose_name = join '+', @roles); |
37 | return $new_name if $Role::Tiny::COMPOSED{class}{$new_name}; |
38 | |
39 | require Sub::Quote; |
40 | |
41 | $me->SUPER::create_class_with_roles($superclass, @roles); |
42 | |
43 | foreach my $role (@roles) { |
44 | die "${role} is not a Role::Tiny" unless my $info = $INFO{$role}; |
45 | } |
46 | |
47 | $me->_handle_constructor( |
48 | $new_name, { map %{$INFO{$_}{attributes}||{}}, @roles } |
49 | ); |
50 | |
51 | return $new_name; |
52 | } |
53 | |
54 | sub _install_modifiers { |
55 | my ($me, $to, $modifiers) = @_; |
56 | foreach my $modifier (@{$modifiers||[]}) { |
57 | _install_modifier($to, @{$modifier}); |
58 | } |
59 | } |
60 | |
61 | sub _handle_constructor { |
62 | my ($me, $to, $attr_info) = @_; |
63 | return unless $attr_info && keys %$attr_info; |
64 | if ($INFO{$to}) { |
65 | @{$INFO{$to}{attributes}||={}}{keys %$attr_info} = values %$attr_info; |
66 | } else { |
67 | # only fiddle with the constructor if the target is a Moo class |
68 | if ($INC{"Moo.pm"} |
69 | and my $con = Moo->_constructor_maker_for($to)) { |
70 | $con->register_attribute_specs(%$attr_info); |
71 | } |
72 | } |
73 | } |
74 | |
75 | 1; |