Filename | /home/s1/perl5/perlbrew/perls/perl-5.22.1/lib/site_perl/5.22.1/Role/Tiny.pm |
Statements | Executed 411 statements in 6.29ms |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
1 | 1 | 1 | 5.68ms | 24.5ms | _load_module | Role::Tiny::
1 | 1 | 1 | 295µs | 636µs | _install_methods | Role::Tiny::
40 | 6 | 1 | 146µs | 146µs | _getglob | Role::Tiny::
1 | 1 | 1 | 116µs | 120µs | _concrete_methods_of | Role::Tiny::
1 | 1 | 1 | 105µs | 157µs | _check_requires | Role::Tiny::
39 | 22 | 1 | 77µs | 77µs | __ANON__[:86] | Role::Tiny::
1 | 1 | 1 | 58µs | 81µs | _install_does | Role::Tiny::
1 | 1 | 1 | 56µs | 25.4ms | apply_single_role_to_package | Role::Tiny::
1 | 1 | 1 | 47µs | 133µs | import | Role::Tiny::
1 | 1 | 1 | 45µs | 68µs | _install_subs | Role::Tiny::
1 | 1 | 1 | 38µs | 42µs | BEGIN@6 | Role::Tiny::
34 | 2 | 1 | 19µs | 19µs | CORE:match (opcode) | Role::Tiny::
1 | 1 | 1 | 15µs | 32µs | BEGIN@379 | Role::Tiny::
1 | 1 | 1 | 15µs | 30µs | BEGIN@453 | Role::Tiny::
4 | 4 | 1 | 14µs | 14µs | is_role | Role::Tiny::
1 | 1 | 1 | 14µs | 14µs | BEGIN@20 | Role::Tiny::
4 | 4 | 1 | 13µs | 13µs | _getstash | Role::Tiny::
1 | 1 | 1 | 13µs | 43µs | BEGIN@303 | Role::Tiny::
1 | 1 | 1 | 13µs | 37µs | BEGIN@27 | Role::Tiny::
1 | 1 | 1 | 12µs | 21µs | BEGIN@7 | Role::Tiny::
1 | 1 | 1 | 8µs | 25.4ms | apply_roles_to_package | Role::Tiny::
1 | 1 | 1 | 7µs | 7µs | _copy_applied_list | Role::Tiny::
1 | 1 | 1 | 5µs | 25.4ms | apply_role_to_package | Role::Tiny::
1 | 1 | 1 | 5µs | 5µs | CORE:subst (opcode) | Role::Tiny::
1 | 1 | 1 | 4µs | 4µs | _install_modifiers | Role::Tiny::
1 | 1 | 1 | 4µs | 4µs | role_application_steps | Role::Tiny::
0 | 0 | 0 | 0s | 0s | __ANON__[:434] | Role::Tiny::
0 | 0 | 0 | 0s | 0s | __ANON__[:452] | Role::Tiny::
0 | 0 | 0 | 0s | 0s | __ANON__[:81] | Role::Tiny::
0 | 0 | 0 | 0s | 0s | __ANON__[:90] | Role::Tiny::
0 | 0 | 0 | 0s | 0s | DESTROY | Role::Tiny::__GUARD__::
0 | 0 | 0 | 0s | 0s | _composable_package_for | Role::Tiny::
0 | 0 | 0 | 0s | 0s | _composite_info_for | Role::Tiny::
0 | 0 | 0 | 0s | 0s | _composite_name | Role::Tiny::
0 | 0 | 0 | 0s | 0s | _install_single_modifier | Role::Tiny::
0 | 0 | 0 | 0s | 0s | apply_roles_to_object | Role::Tiny::
0 | 0 | 0 | 0s | 0s | create_class_with_roles | Role::Tiny::
0 | 0 | 0 | 0s | 0s | croak | Role::Tiny::
0 | 0 | 0 | 0s | 0s | does_role | Role::Tiny::
0 | 0 | 0 | 0s | 0s | methods_provided_by | Role::Tiny::
Line | State ments |
Time on line |
Calls | Time in subs |
Code |
---|---|---|---|---|---|
1 | package Role::Tiny; | ||||
2 | |||||
3 | 40 | 198µs | # spent 146µs within Role::Tiny::_getglob which was called 40 times, avg 4µs/call:
# 33 times (121µs+0s) by Role::Tiny::_install_methods at line 380, avg 4µs/call
# 3 times (13µs+0s) by Role::Tiny::_install_subs at line 81, avg 4µs/call
# once (3µs+0s) by Role::Tiny::_install_subs at line 90
# once (3µs+0s) by Role::Tiny::_install_subs at line 86
# once (3µs+0s) by Role::Tiny::_install_does at line 443
# once (2µs+0s) by Role::Tiny::_install_does at line 454 | ||
4 | 4 | 24µs | # spent 13µs within Role::Tiny::_getstash which was called 4 times, avg 3µs/call:
# once (4µs+0s) by Role::Tiny::_concrete_methods_of at line 342
# once (4µs+0s) by Role::Tiny::_load_module at line 42
# once (3µs+0s) by Role::Tiny::_install_methods at line 369
# once (3µs+0s) by Role::Tiny::import at line 59 | ||
5 | |||||
6 | 2 | 44µs | 2 | 47µs | # spent 42µs (38+5) within Role::Tiny::BEGIN@6 which was called:
# once (38µs+5µs) by Role::Tiny::With::BEGIN@9 at line 6 # spent 42µs making 1 call to Role::Tiny::BEGIN@6
# spent 5µs making 1 call to strict::import |
7 | 2 | 230µs | 2 | 30µs | # spent 21µs (12+9) within Role::Tiny::BEGIN@7 which was called:
# once (12µs+9µs) by Role::Tiny::With::BEGIN@9 at line 7 # spent 21µs making 1 call to Role::Tiny::BEGIN@7
# spent 9µs making 1 call to warnings::import |
8 | |||||
9 | 1 | 700ns | our $VERSION = '2.000003'; | ||
10 | 1 | 23µs | $VERSION = eval $VERSION; # spent 4µs executing statements in string eval | ||
11 | |||||
12 | our %INFO; | ||||
13 | our %APPLIED_TO; | ||||
14 | our %COMPOSED; | ||||
15 | our %COMPOSITE_INFO; | ||||
16 | our @ON_ROLE_CREATE; | ||||
17 | |||||
18 | # Module state workaround totally stolen from Zefram's Module::Runtime. | ||||
19 | |||||
20 | # spent 14µs within Role::Tiny::BEGIN@20 which was called:
# once (14µs+0s) by Role::Tiny::With::BEGIN@9 at line 23 | ||||
21 | 1 | 6µs | *_WORK_AROUND_BROKEN_MODULE_STATE = "$]" < 5.009 ? sub(){1} : sub(){0}; | ||
22 | 1 | 8µs | *_MRO_MODULE = "$]" < 5.010 ? sub(){"MRO/Compat.pm"} : sub(){"mro.pm"}; | ||
23 | 1 | 50µs | 1 | 14µs | } # spent 14µs making 1 call to Role::Tiny::BEGIN@20 |
24 | |||||
25 | sub croak { | ||||
26 | require Carp; | ||||
27 | 2 | 2.54ms | 2 | 62µs | # spent 37µs (13+25) within Role::Tiny::BEGIN@27 which was called:
# once (13µs+25µs) by Role::Tiny::With::BEGIN@9 at line 27 # spent 37µs making 1 call to Role::Tiny::BEGIN@27
# spent 24µs making 1 call to warnings::unimport |
28 | *croak = \&Carp::croak; | ||||
29 | goto &Carp::croak; | ||||
30 | } | ||||
31 | |||||
32 | sub Role::Tiny::__GUARD__::DESTROY { | ||||
33 | delete $INC{$_[0]->[0]} if @{$_[0]}; | ||||
34 | } | ||||
35 | |||||
36 | # spent 24.5ms (5.68+18.8) within Role::Tiny::_load_module which was called:
# once (5.68ms+18.8ms) by Role::Tiny::apply_single_role_to_package at line 100 | ||||
37 | 1 | 14µs | 1 | 5µs | (my $proto = $_[0]) =~ s/::/\//g; # spent 5µs making 1 call to Role::Tiny::CORE:subst |
38 | 1 | 700ns | $proto .= '.pm'; | ||
39 | 1 | 600ns | return 1 if $INC{$proto}; | ||
40 | # can't just ->can('can') because a sub-package Foo::Bar::Baz | ||||
41 | # creates a 'Baz::' key in Foo::Bar's symbol table | ||||
42 | 1 | 16µs | 2 | 7µs | return 1 if grep !/::$/, keys %{_getstash($_[0])||{}}; # spent 4µs making 1 call to Role::Tiny::CORE:match
# spent 4µs making 1 call to Role::Tiny::_getstash |
43 | 1 | 400ns | my $guard = _WORK_AROUND_BROKEN_MODULE_STATE | ||
44 | && bless([ $proto ], 'Role::Tiny::__GUARD__'); | ||||
45 | 1 | 361µs | require $proto; | ||
46 | pop @$guard if _WORK_AROUND_BROKEN_MODULE_STATE; | ||||
47 | 1 | 6µs | return 1; | ||
48 | } | ||||
49 | |||||
50 | # spent 133µs (47+86) within Role::Tiny::import which was called:
# once (47µs+86µs) by DateTime::Format::Alami::BEGIN@11 at line 11 of DateTime/Format/Alami.pm | ||||
51 | 1 | 900ns | my $target = caller; | ||
52 | 1 | 400ns | my $me = shift; | ||
53 | 1 | 1µs | 1 | 3µs | strict->import; # spent 3µs making 1 call to strict::import |
54 | 1 | 2µs | 1 | 11µs | warnings->import; # spent 11µs making 1 call to warnings::import |
55 | 1 | 2µs | 1 | 68µs | $me->_install_subs($target); # spent 68µs making 1 call to Role::Tiny::_install_subs |
56 | 1 | 2µs | 1 | 2µs | return if $me->is_role($target); # already exported into this package # spent 2µs making 1 call to Role::Tiny::is_role |
57 | 1 | 1µs | $INFO{$target}{is_role} = 1; | ||
58 | # get symbol table reference | ||||
59 | 1 | 2µs | 1 | 3µs | my $stash = _getstash($target); # spent 3µs making 1 call to Role::Tiny::_getstash |
60 | # grab all *non-constant* (stash slot is not a scalarref) subs present | ||||
61 | # in the symbol table and store their refaddrs (no need to forcibly | ||||
62 | # inflate constant subs into real subs) with a map to the coderefs in | ||||
63 | # case of copying or re-use | ||||
64 | 1 | 9µs | my @not_methods = (map { *$_{CODE}||() } grep !ref($_), values %$stash); | ||
65 | 1 | 6µs | @{$INFO{$target}{not_methods}={}}{@not_methods} = @not_methods; | ||
66 | # a role does itself | ||||
67 | 1 | 1µs | $APPLIED_TO{$target} = { $target => undef }; | ||
68 | 1 | 7µs | foreach my $hook (@ON_ROLE_CREATE) { | ||
69 | $hook->($target); | ||||
70 | } | ||||
71 | } | ||||
72 | |||||
73 | # spent 68µs (45+23) within Role::Tiny::_install_subs which was called:
# once (45µs+23µs) by Role::Tiny::import at line 55 | ||||
74 | 1 | 1µs | my ($me, $target) = @_; | ||
75 | 1 | 2µs | 1 | 3µs | return if $me->is_role($target); # spent 3µs making 1 call to Role::Tiny::is_role |
76 | # install before/after/around subs | ||||
77 | 1 | 1µs | foreach my $type (qw(before after around)) { | ||
78 | *{_getglob "${target}::${type}"} = sub { | ||||
79 | push @{$INFO{$target}{modifiers}||=[]}, [ $type => @_ ]; | ||||
80 | return; | ||||
81 | 3 | 17µs | 3 | 13µs | }; # spent 13µs making 3 calls to Role::Tiny::_getglob, avg 4µs/call |
82 | } | ||||
83 | # spent 77µs within Role::Tiny::__ANON__[/home/s1/perl5/perlbrew/perls/perl-5.22.1/lib/site_perl/5.22.1/Role/Tiny.pm:86] which was called 39 times, avg 2µs/call:
# 12 times (25µs+0s) by Role::Tiny::_load_module at line 27 of DateTime/Format/Alami.pm, avg 2µs/call
# 7 times (13µs+0s) by Role::Tiny::_load_module at line 28 of DateTime/Format/Alami.pm, avg 2µs/call
# once (7µs+0s) by Role::Tiny::_load_module at line 16 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 35 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 17 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 23 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 19 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 22 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 21 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 25 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 31 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 30 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 38 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 33 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 36 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 37 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 34 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 32 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 39 of DateTime/Format/Alami.pm
# once (2µs+0s) by Role::Tiny::_load_module at line 20 of DateTime/Format/Alami.pm
# once (1µs+0s) by Role::Tiny::_load_module at line 40 of DateTime/Format/Alami.pm
# once (1µs+0s) by Role::Tiny::_load_module at line 24 of DateTime/Format/Alami.pm | ||||
84 | 39 | 35µs | push @{$INFO{$target}{requires}||=[]}, @_; | ||
85 | 39 | 138µs | return; | ||
86 | 1 | 4µs | 1 | 3µs | }; # spent 3µs making 1 call to Role::Tiny::_getglob |
87 | *{_getglob "${target}::with"} = sub { | ||||
88 | $me->apply_roles_to_package($target, @_); | ||||
89 | return; | ||||
90 | 1 | 8µs | 1 | 3µs | }; # spent 3µs making 1 call to Role::Tiny::_getglob |
91 | } | ||||
92 | |||||
93 | # spent 4µs within Role::Tiny::role_application_steps which was called:
# once (4µs+0s) by Role::Tiny::apply_single_role_to_package at line 105 | ||||
94 | 1 | 6µs | qw(_install_methods _check_requires _install_modifiers _copy_applied_list); | ||
95 | } | ||||
96 | |||||
97 | # spent 25.4ms (56µs+25.3) within Role::Tiny::apply_single_role_to_package which was called:
# once (56µs+25.3ms) by Role::Tiny::apply_role_to_package at line 209 | ||||
98 | 1 | 700ns | my ($me, $to, $role) = @_; | ||
99 | |||||
100 | 1 | 2µs | 1 | 24.5ms | _load_module($role); # spent 24.5ms making 1 call to Role::Tiny::_load_module |
101 | |||||
102 | 1 | 600ns | croak "This is apply_role_to_package" if ref($to); | ||
103 | 1 | 7µs | 1 | 6µs | croak "${role} is not a Role::Tiny" unless $me->is_role($role); # spent 6µs making 1 call to Role::Tiny::is_role |
104 | |||||
105 | 1 | 8µs | 1 | 4µs | foreach my $step ($me->role_application_steps) { # spent 4µs making 1 call to Role::Tiny::role_application_steps |
106 | 4 | 23µs | 4 | 804µs | $me->$step($to, $role); # spent 636µs making 1 call to Role::Tiny::_install_methods
# spent 157µs making 1 call to Role::Tiny::_check_requires
# spent 7µs making 1 call to Role::Tiny::_copy_applied_list
# spent 4µs making 1 call to Role::Tiny::_install_modifiers |
107 | } | ||||
108 | } | ||||
109 | |||||
110 | # spent 7µs within Role::Tiny::_copy_applied_list which was called:
# once (7µs+0s) by Role::Tiny::apply_single_role_to_package at line 106 | ||||
111 | 1 | 700ns | my ($me, $to, $role) = @_; | ||
112 | # copy our role list into the target's | ||||
113 | 1 | 9µs | @{$APPLIED_TO{$to}||={}}{keys %{$APPLIED_TO{$role}}} = (); | ||
114 | } | ||||
115 | |||||
116 | sub apply_roles_to_object { | ||||
117 | my ($me, $object, @roles) = @_; | ||||
118 | croak "No roles supplied!" unless @roles; | ||||
119 | my $class = ref($object); | ||||
120 | # on perl < 5.8.9, magic isn't copied to all ref copies. bless the parameter | ||||
121 | # directly, so at least the variable passed to us will get any magic applied | ||||
122 | bless($_[1], $me->create_class_with_roles($class, @roles)); | ||||
123 | } | ||||
124 | |||||
125 | 1 | 500ns | my $role_suffix = 'A000'; | ||
126 | sub _composite_name { | ||||
127 | my ($me, $superclass, @roles) = @_; | ||||
128 | |||||
129 | my $new_name = join( | ||||
130 | '__WITH__', $superclass, my $compose_name = join '__AND__', @roles | ||||
131 | ); | ||||
132 | |||||
133 | if (length($new_name) > 252) { | ||||
134 | $new_name = $COMPOSED{abbrev}{$new_name} ||= do { | ||||
135 | my $abbrev = substr $new_name, 0, 250 - length $role_suffix; | ||||
136 | $abbrev =~ s/(?<!:):$//; | ||||
137 | $abbrev.'__'.$role_suffix++; | ||||
138 | }; | ||||
139 | } | ||||
140 | return wantarray ? ($new_name, $compose_name) : $new_name; | ||||
141 | } | ||||
142 | |||||
143 | sub create_class_with_roles { | ||||
144 | my ($me, $superclass, @roles) = @_; | ||||
145 | |||||
146 | croak "No roles supplied!" unless @roles; | ||||
147 | |||||
148 | _load_module($superclass); | ||||
149 | { | ||||
150 | my %seen; | ||||
151 | if (my @dupes = grep 1 == $seen{$_}++, @roles) { | ||||
152 | croak "Duplicated roles: ".join(', ', @dupes); | ||||
153 | } | ||||
154 | } | ||||
155 | |||||
156 | my ($new_name, $compose_name) = $me->_composite_name($superclass, @roles); | ||||
157 | |||||
158 | return $new_name if $COMPOSED{class}{$new_name}; | ||||
159 | |||||
160 | foreach my $role (@roles) { | ||||
161 | _load_module($role); | ||||
162 | croak "${role} is not a Role::Tiny" unless $me->is_role($role); | ||||
163 | } | ||||
164 | |||||
165 | require(_MRO_MODULE); | ||||
166 | |||||
167 | my $composite_info = $me->_composite_info_for(@roles); | ||||
168 | my %conflicts = %{$composite_info->{conflicts}}; | ||||
169 | if (keys %conflicts) { | ||||
170 | my $fail = | ||||
171 | join "\n", | ||||
172 | map { | ||||
173 | "Method name conflict for '$_' between roles " | ||||
174 | ."'".join(' and ', sort values %{$conflicts{$_}})."'" | ||||
175 | .", cannot apply these simultaneously to an object." | ||||
176 | } keys %conflicts; | ||||
177 | croak $fail; | ||||
178 | } | ||||
179 | |||||
180 | my @composable = map $me->_composable_package_for($_), reverse @roles; | ||||
181 | |||||
182 | # some methods may not exist in the role, but get generated by | ||||
183 | # _composable_package_for (Moose accessors via Moo). filter out anything | ||||
184 | # provided by the composable packages, excluding the subs we generated to | ||||
185 | # make modifiers work. | ||||
186 | my @requires = grep { | ||||
187 | my $method = $_; | ||||
188 | !grep $_->can($method) && !$COMPOSED{role}{$_}{modifiers_only}{$method}, | ||||
189 | @composable | ||||
190 | } @{$composite_info->{requires}}; | ||||
191 | |||||
192 | $me->_check_requires( | ||||
193 | $superclass, $compose_name, \@requires | ||||
194 | ); | ||||
195 | |||||
196 | *{_getglob("${new_name}::ISA")} = [ @composable, $superclass ]; | ||||
197 | |||||
198 | @{$APPLIED_TO{$new_name}||={}}{ | ||||
199 | map keys %{$APPLIED_TO{$_}}, @roles | ||||
200 | } = (); | ||||
201 | |||||
202 | $COMPOSED{class}{$new_name} = 1; | ||||
203 | return $new_name; | ||||
204 | } | ||||
205 | |||||
206 | # preserved for compat, and apply_roles_to_package calls it to allow an | ||||
207 | # updated Role::Tiny to use a non-updated Moo::Role | ||||
208 | |||||
209 | 1 | 5µs | 1 | 25.4ms | # spent 25.4ms (5µs+25.4) within Role::Tiny::apply_role_to_package which was called:
# once (5µs+25.4ms) by Role::Tiny::apply_roles_to_package at line 214 # spent 25.4ms making 1 call to Role::Tiny::apply_single_role_to_package |
210 | |||||
211 | # spent 25.4ms (8µs+25.4) within Role::Tiny::apply_roles_to_package which was called:
# once (8µs+25.4ms) by Role::Tiny::With::with at line 16 of Role/Tiny/With.pm | ||||
212 | 1 | 2µs | my ($me, $to, @roles) = @_; | ||
213 | |||||
214 | 1 | 7µs | 1 | 25.4ms | return $me->apply_role_to_package($to, $roles[0]) if @roles == 1; # spent 25.4ms making 1 call to Role::Tiny::apply_role_to_package |
215 | |||||
216 | my %conflicts = %{$me->_composite_info_for(@roles)->{conflicts}}; | ||||
217 | my @have = grep $to->can($_), keys %conflicts; | ||||
218 | delete @conflicts{@have}; | ||||
219 | |||||
220 | if (keys %conflicts) { | ||||
221 | my $fail = | ||||
222 | join "\n", | ||||
223 | map { | ||||
224 | "Due to a method name conflict between roles " | ||||
225 | ."'".join(' and ', sort values %{$conflicts{$_}})."'" | ||||
226 | .", the method '$_' must be implemented by '${to}'" | ||||
227 | } keys %conflicts; | ||||
228 | croak $fail; | ||||
229 | } | ||||
230 | |||||
231 | # conflicting methods are supposed to be treated as required by the | ||||
232 | # composed role. we don't have an actual composed role, but because | ||||
233 | # we know the target class already provides them, we can instead | ||||
234 | # pretend that the roles don't do for the duration of application. | ||||
235 | my @role_methods = map $me->_concrete_methods_of($_), @roles; | ||||
236 | # separate loops, since local ..., delete ... for ...; creates a scope | ||||
237 | local @{$_}{@have} for @role_methods; | ||||
238 | delete @{$_}{@have} for @role_methods; | ||||
239 | |||||
240 | # the if guard here is essential since otherwise we accidentally create | ||||
241 | # a $INFO for something that isn't a Role::Tiny (or Moo::Role) because | ||||
242 | # autovivification hates us and wants us to die() | ||||
243 | if ($INFO{$to}) { | ||||
244 | delete $INFO{$to}{methods}; # reset since we're about to add methods | ||||
245 | } | ||||
246 | |||||
247 | # backcompat: allow subclasses to use apply_single_role_to_package | ||||
248 | # to apply changes. set a local var so ours does nothing. | ||||
249 | our %BACKCOMPAT_HACK; | ||||
250 | if($me ne __PACKAGE__ | ||||
251 | and exists $BACKCOMPAT_HACK{$me} ? $BACKCOMPAT_HACK{$me} : | ||||
252 | $BACKCOMPAT_HACK{$me} = | ||||
253 | $me->can('role_application_steps') | ||||
254 | == \&role_application_steps | ||||
255 | && $me->can('apply_single_role_to_package') | ||||
256 | != \&apply_single_role_to_package | ||||
257 | ) { | ||||
258 | foreach my $role (@roles) { | ||||
259 | $me->apply_single_role_to_package($to, $role); | ||||
260 | } | ||||
261 | } | ||||
262 | else { | ||||
263 | foreach my $step ($me->role_application_steps) { | ||||
264 | foreach my $role (@roles) { | ||||
265 | $me->$step($to, $role); | ||||
266 | } | ||||
267 | } | ||||
268 | } | ||||
269 | $APPLIED_TO{$to}{join('|',@roles)} = 1; | ||||
270 | } | ||||
271 | |||||
272 | sub _composite_info_for { | ||||
273 | my ($me, @roles) = @_; | ||||
274 | $COMPOSITE_INFO{join('|', sort @roles)} ||= do { | ||||
275 | foreach my $role (@roles) { | ||||
276 | _load_module($role); | ||||
277 | } | ||||
278 | my %methods; | ||||
279 | foreach my $role (@roles) { | ||||
280 | my $this_methods = $me->_concrete_methods_of($role); | ||||
281 | $methods{$_}{$this_methods->{$_}} = $role for keys %$this_methods; | ||||
282 | } | ||||
283 | my %requires; | ||||
284 | @requires{map @{$INFO{$_}{requires}||[]}, @roles} = (); | ||||
285 | delete $requires{$_} for keys %methods; | ||||
286 | delete $methods{$_} for grep keys(%{$methods{$_}}) == 1, keys %methods; | ||||
287 | +{ conflicts => \%methods, requires => [keys %requires] } | ||||
288 | }; | ||||
289 | } | ||||
290 | |||||
291 | sub _composable_package_for { | ||||
292 | my ($me, $role) = @_; | ||||
293 | my $composed_name = 'Role::Tiny::_COMPOSABLE::'.$role; | ||||
294 | return $composed_name if $COMPOSED{role}{$composed_name}; | ||||
295 | $me->_install_methods($composed_name, $role); | ||||
296 | my $base_name = $composed_name.'::_BASE'; | ||||
297 | # force stash to exist so ->can doesn't complain | ||||
298 | _getstash($base_name); | ||||
299 | # Not using _getglob, since setting @ISA via the typeglob breaks | ||||
300 | # inheritance on 5.10.0 if the stash has previously been accessed an | ||||
301 | # then a method called on the class (in that order!), which | ||||
302 | # ->_install_methods (with the help of ->_install_does) ends up doing. | ||||
303 | 2 | 823µs | 2 | 74µs | # spent 43µs (13+30) within Role::Tiny::BEGIN@303 which was called:
# once (13µs+30µs) by Role::Tiny::With::BEGIN@9 at line 303 # spent 43µs making 1 call to Role::Tiny::BEGIN@303
# spent 30µs making 1 call to strict::unimport |
304 | my $modifiers = $INFO{$role}{modifiers}||[]; | ||||
305 | my @mod_base; | ||||
306 | my @modifiers = grep !$composed_name->can($_), | ||||
307 | do { my %h; @h{map @{$_}[1..$#$_-1], @$modifiers} = (); keys %h }; | ||||
308 | foreach my $modified (@modifiers) { | ||||
309 | push @mod_base, "sub ${modified} { shift->next::method(\@_) }"; | ||||
310 | } | ||||
311 | my $e; | ||||
312 | { | ||||
313 | local $@; | ||||
314 | eval(my $code = join "\n", "package ${base_name};", @mod_base); | ||||
315 | $e = "Evaling failed: $@\nTrying to eval:\n${code}" if $@; | ||||
316 | } | ||||
317 | die $e if $e; | ||||
318 | $me->_install_modifiers($composed_name, $role); | ||||
319 | $COMPOSED{role}{$composed_name} = { | ||||
320 | modifiers_only => { map { $_ => 1 } @modifiers }, | ||||
321 | }; | ||||
322 | return $composed_name; | ||||
323 | } | ||||
324 | |||||
325 | # spent 157µs (105+51) within Role::Tiny::_check_requires which was called:
# once (105µs+51µs) by Role::Tiny::apply_single_role_to_package at line 106 | ||||
326 | 1 | 1µs | my ($me, $to, $name, $requires) = @_; | ||
327 | 1 | 8µs | return unless my @requires = @{$requires||$INFO{$name}{requires}||[]}; | ||
328 | 1 | 150µs | 39 | 51µs | if (my @requires_fail = grep !$to->can($_), @requires) { # spent 51µs making 39 calls to UNIVERSAL::can, avg 1µs/call |
329 | # role -> role, add to requires, role -> class, error out | ||||
330 | if (my $to_info = $INFO{$to}) { | ||||
331 | push @{$to_info->{requires}||=[]}, @requires_fail; | ||||
332 | } else { | ||||
333 | croak "Can't apply ${name} to ${to} - missing ".join(', ', @requires_fail); | ||||
334 | } | ||||
335 | } | ||||
336 | } | ||||
337 | |||||
338 | # spent 120µs (116+4) within Role::Tiny::_concrete_methods_of which was called:
# once (116µs+4µs) by Role::Tiny::_install_methods at line 366 | ||||
339 | 1 | 700ns | my ($me, $role) = @_; | ||
340 | 1 | 700ns | my $info = $INFO{$role}; | ||
341 | # grab role symbol table | ||||
342 | 1 | 2µs | 1 | 4µs | my $stash = _getstash($role); # spent 4µs making 1 call to Role::Tiny::_getstash |
343 | # reverse so our keys become the values (captured coderefs) in case | ||||
344 | # they got copied or re-used since | ||||
345 | 1 | 14µs | my $not_methods = { reverse %{$info->{not_methods}||{}} }; | ||
346 | $info->{methods} ||= +{ | ||||
347 | # grab all code entries that aren't in the not_methods list | ||||
348 | map { | ||||
349 | 47 | 20µs | my $code = *{$stash->{$_}}{CODE}; | ||
350 | 47 | 34µs | ( ! $code or exists $not_methods->{$code} ) ? () : ($_ => $code) | ||
351 | 1 | 45µs | } grep !ref($stash->{$_}), keys %$stash | ||
352 | }; | ||||
353 | } | ||||
354 | |||||
355 | sub methods_provided_by { | ||||
356 | my ($me, $role) = @_; | ||||
357 | croak "${role} is not a Role::Tiny" unless $me->is_role($role); | ||||
358 | (keys %{$me->_concrete_methods_of($role)}, @{$INFO{$role}->{requires}||[]}); | ||||
359 | } | ||||
360 | |||||
361 | # spent 636µs (295+341) within Role::Tiny::_install_methods which was called:
# once (295µs+341µs) by Role::Tiny::apply_single_role_to_package at line 106 | ||||
362 | 1 | 1µs | my ($me, $to, $role) = @_; | ||
363 | |||||
364 | 1 | 1µs | my $info = $INFO{$role}; | ||
365 | |||||
366 | 1 | 7µs | 1 | 120µs | my $methods = $me->_concrete_methods_of($role); # spent 120µs making 1 call to Role::Tiny::_concrete_methods_of |
367 | |||||
368 | # grab target symbol table | ||||
369 | 1 | 2µs | 1 | 3µs | my $stash = _getstash($to); # spent 3µs making 1 call to Role::Tiny::_getstash |
370 | |||||
371 | # determine already extant methods of target | ||||
372 | 1 | 300ns | my %has_methods; | ||
373 | @has_methods{grep | ||||
374 | 1 | 42µs | +(ref($stash->{$_}) || *{$stash->{$_}}{CODE}), | ||
375 | keys %$stash | ||||
376 | } = (); | ||||
377 | |||||
378 | 1 | 21µs | foreach my $i (grep !exists $has_methods{$_}, keys %$methods) { | ||
379 | 2 | 703µs | 2 | 48µs | # spent 32µs (15+16) within Role::Tiny::BEGIN@379 which was called:
# once (15µs+16µs) by Role::Tiny::With::BEGIN@9 at line 379 # spent 32µs making 1 call to Role::Tiny::BEGIN@379
# spent 16µs making 1 call to warnings::unimport |
380 | 33 | 67µs | 33 | 121µs | my $glob = _getglob "${to}::${i}"; # spent 121µs making 33 calls to Role::Tiny::_getglob, avg 4µs/call |
381 | 33 | 20µs | *$glob = $methods->{$i}; | ||
382 | |||||
383 | # overloads using method names have the method stored in the scalar slot | ||||
384 | # and &overload::nil in the code slot. | ||||
385 | next | ||||
386 | unless $i =~ /^\(/ | ||||
387 | && ((defined &overload::nil && $methods->{$i} == \&overload::nil) | ||||
388 | 33 | 96µs | 33 | 15µs | || (defined &overload::_nil && $methods->{$i} == \&overload::_nil)); # spent 15µs making 33 calls to Role::Tiny::CORE:match, avg 464ns/call |
389 | |||||
390 | my $overload = ${ *{_getglob "${role}::${i}"}{SCALAR} }; | ||||
391 | next | ||||
392 | unless defined $overload; | ||||
393 | |||||
394 | *$glob = \$overload; | ||||
395 | } | ||||
396 | |||||
397 | 1 | 11µs | 1 | 81µs | $me->_install_does($to); # spent 81µs making 1 call to Role::Tiny::_install_does |
398 | } | ||||
399 | |||||
400 | # spent 4µs within Role::Tiny::_install_modifiers which was called:
# once (4µs+0s) by Role::Tiny::apply_single_role_to_package at line 106 | ||||
401 | 1 | 1µs | my ($me, $to, $name) = @_; | ||
402 | 1 | 6µs | return unless my $modifiers = $INFO{$name}{modifiers}; | ||
403 | my $info = $INFO{$to}; | ||||
404 | my $existing = ($info ? $info->{modifiers} : $COMPOSED{modifiers}{$to}) ||= []; | ||||
405 | my @modifiers = grep { | ||||
406 | my $modifier = $_; | ||||
407 | !grep $_ == $modifier, @$existing; | ||||
408 | } @{$modifiers||[]}; | ||||
409 | push @$existing, @modifiers; | ||||
410 | |||||
411 | if (!$info) { | ||||
412 | foreach my $modifier (@modifiers) { | ||||
413 | $me->_install_single_modifier($to, @$modifier); | ||||
414 | } | ||||
415 | } | ||||
416 | } | ||||
417 | |||||
418 | 1 | 200ns | my $vcheck_error; | ||
419 | |||||
420 | sub _install_single_modifier { | ||||
421 | my ($me, @args) = @_; | ||||
422 | defined($vcheck_error) or $vcheck_error = do { | ||||
423 | local $@; | ||||
424 | eval { | ||||
425 | require Class::Method::Modifiers; | ||||
426 | Class::Method::Modifiers->VERSION(1.05); | ||||
427 | 1; | ||||
428 | } ? 0 : $@; | ||||
429 | }; | ||||
430 | $vcheck_error and die $vcheck_error; | ||||
431 | Class::Method::Modifiers::install_modifier(@args); | ||||
432 | } | ||||
433 | |||||
434 | 1 | 3µs | my $FALLBACK = sub { 0 }; | ||
435 | # spent 81µs (58+23) within Role::Tiny::_install_does which was called:
# once (58µs+23µs) by Role::Tiny::_install_methods at line 397 | ||||
436 | 1 | 1µs | my ($me, $to) = @_; | ||
437 | |||||
438 | # only add does() method to classes | ||||
439 | 1 | 2µs | 1 | 3µs | return if $me->is_role($to); # spent 3µs making 1 call to Role::Tiny::is_role |
440 | |||||
441 | 1 | 16µs | 1 | 3µs | my $does = $me->can('does_role'); # spent 3µs making 1 call to UNIVERSAL::can |
442 | # add does() only if they don't have one | ||||
443 | 1 | 14µs | 2 | 7µs | *{_getglob "${to}::does"} = $does unless $to->can('does'); # spent 4µs making 1 call to UNIVERSAL::can
# spent 3µs making 1 call to Role::Tiny::_getglob |
444 | |||||
445 | return | ||||
446 | 1 | 16µs | 3 | 6µs | if $to->can('DOES') and $to->can('DOES') != (UNIVERSAL->can('DOES') || 0); # spent 6µs making 3 calls to UNIVERSAL::can, avg 2µs/call |
447 | |||||
448 | 1 | 6µs | 1 | 2µs | my $existing = $to->can('DOES') || $to->can('isa') || $FALLBACK; # spent 2µs making 1 call to UNIVERSAL::can |
449 | my $new_sub = sub { | ||||
450 | my ($proto, $role) = @_; | ||||
451 | $proto->$does($role) or $proto->$existing($role); | ||||
452 | 1 | 4µs | }; | ||
453 | 2 | 282µs | 2 | 45µs | # spent 30µs (15+15) within Role::Tiny::BEGIN@453 which was called:
# once (15µs+15µs) by Role::Tiny::With::BEGIN@9 at line 453 # spent 30µs making 1 call to Role::Tiny::BEGIN@453
# spent 15µs making 1 call to warnings::unimport |
454 | 1 | 8µs | 1 | 2µs | return *{_getglob "${to}::DOES"} = $new_sub; # spent 2µs making 1 call to Role::Tiny::_getglob |
455 | } | ||||
456 | |||||
457 | sub does_role { | ||||
458 | my ($proto, $role) = @_; | ||||
459 | require(_MRO_MODULE); | ||||
460 | foreach my $class (@{mro::get_linear_isa(ref($proto)||$proto)}) { | ||||
461 | return 1 if exists $APPLIED_TO{$class}{$role}; | ||||
462 | } | ||||
463 | return 0; | ||||
464 | } | ||||
465 | |||||
466 | # spent 14µs within Role::Tiny::is_role which was called 4 times, avg 4µs/call:
# once (6µs+0s) by Role::Tiny::apply_single_role_to_package at line 103
# once (3µs+0s) by Role::Tiny::_install_subs at line 75
# once (3µs+0s) by Role::Tiny::_install_does at line 439
# once (2µs+0s) by Role::Tiny::import at line 56 | ||||
467 | 4 | 3µs | my ($me, $role) = @_; | ||
468 | 4 | 22µs | return !!($INFO{$role} && ($INFO{$role}{is_role} || $INFO{$role}{not_methods})); | ||
469 | } | ||||
470 | |||||
471 | 1 | 7µs | 1; | ||
472 | __END__ | ||||
sub Role::Tiny::CORE:match; # opcode | |||||
# spent 5µs within Role::Tiny::CORE:subst which was called:
# once (5µs+0s) by Role::Tiny::_load_module at line 37 |