File | /usr/local/share/perl/5.10.0/Sub/Install.pm |
Statements Executed | 1932 |
Total Time | 0.00831869999999999 seconds |
Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
---|---|---|---|---|---|
116 | 1 | 1 | 2.60ms | 4.00ms | __ANON__[:175] | Sub::Install::
116 | 4 | 2 | 2.02ms | 6.85ms | __ANON__[:132] | Sub::Install::
116 | 1 | 1 | 1.39ms | 1.39ms | __ANON__[:187] | Sub::Install::
116 | 1 | 1 | 530µs | 840µs | _CODELIKE | Sub::Install::
2 | 2 | 2 | 51µs | 51µs | exporter | Sub::Install::
4 | 4 | 4 | 48µs | 48µs | __ANON__[:284] | Sub::Install::
3 | 3 | 1 | 42µs | 49µs | _do_with_warn | Sub::Install::
3 | 3 | 1 | 31µs | 31µs | _installer | Sub::Install::
2 | 2 | 1 | 28µs | 28µs | _build_public_installer | Sub::Install::
3 | 3 | 1 | 21µs | 21µs | __ANON__[:176] | Sub::Install::
0 | 0 | 0 | 0s | 0s | BEGIN | Sub::Install::
0 | 0 | 0 | 0s | 0s | __ANON__[:156] | Sub::Install::
0 | 0 | 0 | 0s | 0s | __ANON__[:173] | Sub::Install::
0 | 0 | 0 | 0s | 0s | __ANON__[:250] | Sub::Install::
0 | 0 | 0 | 0s | 0s | _name_of_code | Sub::Install::
0 | 0 | 0 | 0s | 0s | install_installers | Sub::Install::
Line | Stmts. | Exclusive Time | Avg. | Code |
---|---|---|---|---|
1 | package Sub::Install; | |||
2 | ||||
3 | 3 | 31µs | 10µs | use warnings; # spent 24µs making 1 call to warnings::import |
4 | 3 | 27µs | 9µs | use strict; # spent 12µs making 1 call to strict::import |
5 | ||||
6 | 3 | 22µs | 7µs | use Carp; # spent 53µs making 1 call to Exporter::import |
7 | 3 | 494µs | 165µs | use Scalar::Util (); |
8 | ||||
9 | =head1 NAME | |||
10 | ||||
11 | Sub::Install - install subroutines into packages easily | |||
12 | ||||
13 | =head1 VERSION | |||
14 | ||||
15 | version 0.925 | |||
16 | ||||
17 | =cut | |||
18 | ||||
19 | 1 | 700ns | 700ns | our $VERSION = '0.925'; |
20 | ||||
21 | =head1 SYNOPSIS | |||
22 | ||||
23 | use Sub::Install; | |||
24 | ||||
25 | Sub::Install::install_sub({ | |||
26 | code => sub { ... }, | |||
27 | into => $package, | |||
28 | as => $subname | |||
29 | }); | |||
30 | ||||
31 | =head1 DESCRIPTION | |||
32 | ||||
33 | This module makes it easy to install subroutines into packages without the | |||
34 | unslightly mess of C<no strict> or typeglobs lying about where just anyone can | |||
35 | see them. | |||
36 | ||||
37 | =head1 FUNCTIONS | |||
38 | ||||
39 | =head2 install_sub | |||
40 | ||||
41 | Sub::Install::install_sub({ | |||
42 | code => \&subroutine, | |||
43 | into => "Finance::Shady", | |||
44 | as => 'launder', | |||
45 | }); | |||
46 | ||||
47 | This routine installs a given code reference into a package as a normal | |||
48 | subroutine. The above is equivalent to: | |||
49 | ||||
50 | no strict 'refs'; | |||
51 | *{"Finance::Shady" . '::' . "launder"} = \&subroutine; | |||
52 | ||||
53 | If C<into> is not given, the sub is installed into the calling package. | |||
54 | ||||
55 | If C<code> is not a code reference, it is looked for as an existing sub in the | |||
56 | package named in the C<from> parameter. If C<from> is not given, it will look | |||
57 | in the calling package. | |||
58 | ||||
59 | If C<as> is not given, and if C<code> is a name, C<as> will default to C<code>. | |||
60 | If C<as> is not given, but if C<code> is a code ref, Sub::Install will try to | |||
61 | find the name of the given code ref and use that as C<as>. | |||
62 | ||||
63 | That means that this code: | |||
64 | ||||
65 | Sub::Install::install_sub({ | |||
66 | code => 'twitch', | |||
67 | from => 'Person::InPain', | |||
68 | into => 'Person::Teenager', | |||
69 | as => 'dance', | |||
70 | }); | |||
71 | ||||
72 | is the same as: | |||
73 | ||||
74 | package Person::Teenager; | |||
75 | ||||
76 | Sub::Install::install_sub({ | |||
77 | code => Person::InPain->can('twitch'), | |||
78 | as => 'dance', | |||
79 | }); | |||
80 | ||||
81 | =head2 reinstall_sub | |||
82 | ||||
83 | This routine behaves exactly like C<L</install_sub>>, but does not emit a | |||
84 | warning if warnings are on and the destination is already defined. | |||
85 | ||||
86 | =cut | |||
87 | ||||
88 | sub _name_of_code { | |||
89 | my ($code) = @_; | |||
90 | require B; | |||
91 | my $name = B::svref_2object($code)->GV->NAME; | |||
92 | return $name unless $name =~ /\A__ANON__/; | |||
93 | return; | |||
94 | } | |||
95 | ||||
96 | # See also Params::Util, to which this code was donated. | |||
97 | # spent 840µs (530+310) within Sub::Install::_CODELIKE which was called 116 times, avg 7µs/call:
# 116 times (530µs+310µs) by Sub::Install::_build_public_installer or Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:132] at line 117, avg 7µs/call | |||
98 | 116 | 620µs | 5µs | (Scalar::Util::reftype($_[0])||'') eq 'CODE' # spent 310µs making 116 calls to Scalar::Util::reftype, avg 3µs/call |
99 | || Scalar::Util::blessed($_[0]) | |||
100 | && (overload::Method($_[0],'&{}') ? $_[0] : undef); | |||
101 | } | |||
102 | ||||
103 | # do the heavy lifting | |||
104 | sub _build_public_installer { | |||
105 | 4 | 21µs | 5µs | my ($installer) = @_; |
106 | ||||
107 | # spent 6.85ms (2.02+4.84) within Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:132] which was called 116 times, avg 59µs/call:
# 110 times (1.87ms+4.50ms) by Sub::Exporter::default_installer at line 896 of /usr/local/share/perl/5.10.0/Sub/Exporter.pm, avg 58µs/call
# 2 times (58µs+135µs) by Sub::Exporter::setup_exporter at line 607 of /usr/local/share/perl/5.10.0/Sub/Exporter.pm, avg 97µs/call
# 2 times (50µs+108µs) by Package::DeprecationManager::import at line 29 of /usr/local/share/perl/5.10.0/Package/DeprecationManager.pm, avg 79µs/call
# 2 times (40µs+98µs) by Package::DeprecationManager::import at line 37 of /usr/local/share/perl/5.10.0/Package/DeprecationManager.pm, avg 69µs/call | |||
108 | 812 | 1.86ms | 2µs | my ($arg) = @_; |
109 | my ($calling_pkg) = caller(0); | |||
110 | ||||
111 | # I'd rather use ||= but I'm whoring for Devel::Cover. | |||
112 | 232 | 298µs | 1µs | for (qw(into from)) { $arg->{$_} = $calling_pkg unless $arg->{$_} } |
113 | ||||
114 | # This is the only absolutely required argument, in many cases. | |||
115 | Carp::croak "named argument 'code' is not optional" unless $arg->{code}; | |||
116 | ||||
117 | if (_CODELIKE($arg->{code})) { # spent 840µs making 116 calls to Sub::Install::_CODELIKE, avg 7µs/call | |||
118 | $arg->{as} ||= _name_of_code($arg->{code}); | |||
119 | } else { | |||
120 | Carp::croak | |||
121 | "couldn't find subroutine named $arg->{code} in package $arg->{from}" | |||
122 | unless my $code = $arg->{from}->can($arg->{code}); | |||
123 | ||||
124 | $arg->{as} = $arg->{code} unless $arg->{as}; | |||
125 | $arg->{code} = $code; | |||
126 | } | |||
127 | ||||
128 | Carp::croak "couldn't determine name under which to install subroutine" | |||
129 | unless $arg->{as}; | |||
130 | ||||
131 | $installer->(@$arg{qw(into as code) }); # spent 4.00ms making 116 calls to Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:175], avg 34µs/call | |||
132 | } | |||
133 | } | |||
134 | ||||
135 | # do the ugly work | |||
136 | ||||
137 | 1 | 300ns | 300ns | my $_misc_warn_re; |
138 | 1 | 200ns | 200ns | my $_redef_warn_re; |
139 | BEGIN { | |||
140 | 2 | 15µs | 7µs | $_misc_warn_re = qr/ |
141 | Prototype\ mismatch:\ sub\ .+? | | |||
142 | Constant subroutine \S+ redefined | |||
143 | /x; | |||
144 | $_redef_warn_re = qr/Subroutine\ \S+\ redefined/x; | |||
145 | 1 | 38µs | 38µs | } |
146 | ||||
147 | 1 | 200ns | 200ns | my $eow_re; |
148 | 1 | 416µs | 416µs | BEGIN { $eow_re = qr/ at .+? line \d+\.\Z/ }; |
149 | ||||
150 | sub _do_with_warn { | |||
151 | 14 | 32µs | 2µs | my ($arg) = @_; |
152 | my $code = delete $arg->{code}; | |||
153 | my $wants_code = sub { | |||
154 | 6 | 11µs | 2µs | my $code = shift; |
155 | # spent 4.00ms (2.60+1.39) within Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:175] which was called 116 times, avg 34µs/call:
# 116 times (2.60ms+1.39ms) by Sub::Install::_build_public_installer or Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:132] at line 131, avg 34µs/call | |||
156 | 348 | 2.65ms | 8µs | my $warn = $SIG{__WARN__} ? $SIG{__WARN__} : sub { warn @_ }; ## no critic |
157 | local $SIG{__WARN__} = sub { | |||
158 | my ($error) = @_; | |||
159 | for (@{ $arg->{suppress} }) { | |||
160 | return if $error =~ $_; | |||
161 | } | |||
162 | for (@{ $arg->{croak} }) { | |||
163 | if (my ($base_error) = $error =~ /\A($_) $eow_re/x) { | |||
164 | Carp::croak $base_error; | |||
165 | } | |||
166 | } | |||
167 | for (@{ $arg->{carp} }) { | |||
168 | if (my ($base_error) = $error =~ /\A($_) $eow_re/x) { | |||
169 | return $warn->(Carp::shortmess $base_error); | |||
170 | } | |||
171 | } | |||
172 | ($arg->{default} || $warn)->($error); | |||
173 | }; | |||
174 | $code->(@_); # spent 1.39ms making 116 calls to Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:187], avg 12µs/call | |||
175 | }; | |||
176 | }; | |||
177 | return $wants_code->($code) if $code; # spent 7µs making 1 call to Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:176] | |||
178 | return $wants_code; | |||
179 | } | |||
180 | ||||
181 | sub _installer { | |||
182 | # spent 1.39ms within Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:187] which was called 116 times, avg 12µs/call:
# 116 times (1.39ms+0s) by Sub::Install::_do_with_warn or Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:175] or Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:176] at line 174, avg 12µs/call | |||
183 | 348 | 1.07ms | 3µs | my ($pkg, $name, $code) = @_; |
184 | 3 | 164µs | 55µs | no strict 'refs'; ## no critic ProhibitNoStrict # spent 28µs making 1 call to strict::unimport |
185 | *{"$pkg\::$name"} = $code; | |||
186 | return $code; | |||
187 | } | |||
188 | 3 | 15µs | 5µs | } |
189 | ||||
190 | BEGIN { | |||
191 | 5 | 75µs | 15µs | *_ignore_warnings = _do_with_warn({ # spent 15µs making 1 call to Sub::Install::_do_with_warn |
192 | carp => [ $_misc_warn_re, $_redef_warn_re ] | |||
193 | }); | |||
194 | ||||
195 | *install_sub = _build_public_installer(_ignore_warnings(_installer)); # spent 13µs making 1 call to Sub::Install::_installer
# spent 10µs making 1 call to Sub::Install::_build_public_installer
# spent 8µs making 1 call to Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:176] | |||
196 | ||||
197 | *_carp_warnings = _do_with_warn({ # spent 11µs making 1 call to Sub::Install::_do_with_warn | |||
198 | carp => [ $_misc_warn_re ], | |||
199 | suppress => [ $_redef_warn_re ], | |||
200 | }); | |||
201 | ||||
202 | *reinstall_sub = _build_public_installer(_carp_warnings(_installer)); # spent 18µs making 1 call to Sub::Install::_build_public_installer
# spent 7µs making 1 call to Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:176]
# spent 6µs making 1 call to Sub::Install::_installer | |||
203 | ||||
204 | *_install_fatal = _do_with_warn({ # spent 23µs making 1 call to Sub::Install::_do_with_warn
# spent 12µs making 1 call to Sub::Install::_installer | |||
205 | code => _installer, | |||
206 | croak => [ $_redef_warn_re ], | |||
207 | }); | |||
208 | 1 | 320µs | 320µs | } |
209 | ||||
210 | =head2 install_installers | |||
211 | ||||
212 | This routine is provided to allow Sub::Install compatibility with | |||
213 | Sub::Installer. It installs C<install_sub> and C<reinstall_sub> methods into | |||
214 | the package named by its argument. | |||
215 | ||||
216 | Sub::Install::install_installers('Code::Builder'); # just for us, please | |||
217 | Code::Builder->install_sub({ name => $code_ref }); | |||
218 | ||||
219 | Sub::Install::install_installers('UNIVERSAL'); # feeling lucky, punk? | |||
220 | Anything::At::All->install_sub({ name => $code_ref }); | |||
221 | ||||
222 | The installed installers are similar, but not identical, to those provided by | |||
223 | Sub::Installer. They accept a single hash as an argument. The key/value pairs | |||
224 | are used as the C<as> and C<code> parameters to the C<install_sub> routine | |||
225 | detailed above. The package name on which the method is called is used as the | |||
226 | C<into> parameter. | |||
227 | ||||
228 | Unlike Sub::Installer's C<install_sub> will not eval strings into code, but | |||
229 | will look for named code in the calling package. | |||
230 | ||||
231 | =cut | |||
232 | ||||
233 | sub install_installers { | |||
234 | my ($into) = @_; | |||
235 | ||||
236 | for my $method (qw(install_sub reinstall_sub)) { | |||
237 | my $code = sub { | |||
238 | my ($package, $subs) = @_; | |||
239 | my ($caller) = caller(0); | |||
240 | my $return; | |||
241 | for (my ($name, $sub) = %$subs) { | |||
242 | $return = Sub::Install->can($method)->({ | |||
243 | code => $sub, | |||
244 | from => $caller, | |||
245 | into => $package, | |||
246 | as => $name | |||
247 | }); | |||
248 | } | |||
249 | return $return; | |||
250 | }; | |||
251 | install_sub({ code => $code, into => $into, as => $method }); | |||
252 | } | |||
253 | } | |||
254 | ||||
255 | =head1 EXPORTS | |||
256 | ||||
257 | Sub::Install exports C<install_sub> and C<reinstall_sub> only if they are | |||
258 | requested. | |||
259 | ||||
260 | =head2 exporter | |||
261 | ||||
262 | Sub::Install has a never-exported subroutine called C<exporter>, which is used | |||
263 | to implement its C<import> routine. It takes a hashref of named arguments, | |||
264 | only one of which is currently recognize: C<exports>. This must be an arrayref | |||
265 | of subroutines to offer for export. | |||
266 | ||||
267 | This routine is mainly for Sub::Install's own consumption. Instead, consider | |||
268 | L<Sub::Exporter>. | |||
269 | ||||
270 | =cut | |||
271 | ||||
272 | # spent 51µs within Sub::Install::exporter which was called 2 times, avg 26µs/call:
# once (36µs+0s) by Sub::Install::BEGIN at line 287
# once (15µs+0s) by Data::OptList::BEGIN at line 215 of /usr/local/share/perl/5.10.0/Data/OptList.pm | |||
273 | 6 | 36µs | 6µs | my ($arg) = @_; |
274 | ||||
275 | my %is_exported = map { $_ => undef } @{ $arg->{exports} }; | |||
276 | ||||
277 | # spent 48µs within Sub::Install::__ANON__[/usr/local/share/perl/5.10.0/Sub/Install.pm:284] which was called 4 times, avg 12µs/call:
# once (15µs+0s) at line 13 of /usr/local/lib/perl/5.10.0/Class/MOP.pm
# once (11µs+0s) at line 10 of /usr/local/lib/perl/5.10.0/Moose/Meta/Class.pm
# once (11µs+0s) at line 6 of /usr/local/lib/perl/5.10.0/Moose/Util.pm
# once (10µs+0s) by Package::DeprecationManager::BEGIN at line 12 of /usr/local/share/perl/5.10.0/Package/DeprecationManager.pm | |||
278 | 12 | 25µs | 2µs | my $class = shift; |
279 | my $target = caller; | |||
280 | for (@_) { | |||
281 | Carp::croak "'$_' is not exported by $class" if !exists $is_exported{$_}; | |||
282 | install_sub({ code => $_, from => $class, into => $target }); | |||
283 | } | |||
284 | } | |||
285 | } | |||
286 | ||||
287 | 1 | 55µs | 55µs | BEGIN { *import = exporter({ exports => [ qw(install_sub reinstall_sub) ] }); } # spent 36µs making 1 call to Sub::Install::exporter |
288 | ||||
289 | =head1 SEE ALSO | |||
290 | ||||
291 | =over | |||
292 | ||||
293 | =item L<Sub::Installer> | |||
294 | ||||
295 | This module is (obviously) a reaction to Damian Conway's Sub::Installer, which | |||
296 | does the same thing, but does it by getting its greasy fingers all over | |||
297 | UNIVERSAL. I was really happy about the idea of making the installation of | |||
298 | coderefs less ugly, but I couldn't bring myself to replace the ugliness of | |||
299 | typeglobs and loosened strictures with the ugliness of UNIVERSAL methods. | |||
300 | ||||
301 | =item L<Sub::Exporter> | |||
302 | ||||
303 | This is a complete Exporter.pm replacement, built atop Sub::Install. | |||
304 | ||||
305 | =back | |||
306 | ||||
307 | =head1 AUTHOR | |||
308 | ||||
309 | Ricardo Signes, C<< <rjbs@cpan.org> >> | |||
310 | ||||
311 | Several of the tests are adapted from tests that shipped with Damian Conway's | |||
312 | Sub-Installer distribution. | |||
313 | ||||
314 | =head1 BUGS | |||
315 | ||||
316 | Please report any bugs or feature requests through the web interface at | |||
317 | L<http://rt.cpan.org>. I will be notified, and then you'll automatically be | |||
318 | notified of progress on your bug as I make changes. | |||
319 | ||||
320 | =head1 COPYRIGHT | |||
321 | ||||
322 | Copyright 2005-2006 Ricardo Signes, All Rights Reserved. | |||
323 | ||||
324 | This program is free software; you can redistribute it and/or modify it | |||
325 | under the same terms as Perl itself. | |||
326 | ||||
327 | =cut | |||
328 | ||||
329 | 1 | 9µs | 9µs | 1; |