← Index
NYTProf Performance Profile   « line view »
For starman worker -M FindBin --max-requests 50 --workers 2 --user=kohadev-koha --group kohadev-koha --pid /var/run/koha/kohadev/plack.pid --daemonize --access-log /var/log/koha/kohadev/plack.log --error-log /var/log/koha/kohadev/plack-error.log -E deployment --socket /var/run/koha/kohadev/plack.sock /etc/koha/sites/kohadev/plack.psgi
  Run on Fri Jan 8 13:50:58 2016
Reported on Fri Jan 8 13:51:26 2016

Filename/usr/share/perl5/namespace/clean.pm
StatementsExecuted 0 statements in 0s
Line State
ments
Time
on line
Calls Time
in subs
Code
1package namespace::clean;
2
3use warnings;
4use strict;
5
6use Package::Stash;
7
8our $VERSION = '0.25';
9our $STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
10
11use B::Hooks::EndOfScope 'on_scope_end';
12
13=head1 NAME
14
15namespace::clean - Keep imports and functions out of your namespace
16
17=head1 SYNOPSIS
18
19 package Foo;
20 use warnings;
21 use strict;
22
23 use Carp qw(croak); # 'croak' will be removed
24
25 sub bar { 23 } # 'bar' will be removed
26
27 # remove all previously defined functions
28 use namespace::clean;
29
30 sub baz { bar() } # 'baz' still defined, 'bar' still bound
31
32 # begin to collection function names from here again
33 no namespace::clean;
34
35 sub quux { baz() } # 'quux' will be removed
36
37 # remove all functions defined after the 'no' unimport
38 use namespace::clean;
39
40 # Will print: 'No', 'No', 'Yes' and 'No'
41 print +(__PACKAGE__->can('croak') ? 'Yes' : 'No'), "\n";
42 print +(__PACKAGE__->can('bar') ? 'Yes' : 'No'), "\n";
43 print +(__PACKAGE__->can('baz') ? 'Yes' : 'No'), "\n";
44 print +(__PACKAGE__->can('quux') ? 'Yes' : 'No'), "\n";
45
46 1;
47
48=head1 DESCRIPTION
49
50=head2 Keeping packages clean
51
52When you define a function, or import one, into a Perl package, it will
53naturally also be available as a method. This does not per se cause
54problems, but it can complicate subclassing and, for example, plugin
55classes that are included via multiple inheritance by loading them as
56base classes.
57
58The C<namespace::clean> pragma will remove all previously declared or
59imported symbols at the end of the current package's compile cycle.
60Functions called in the package itself will still be bound by their
61name, but they won't show up as methods on your class or instances.
62
63By unimporting via C<no> you can tell C<namespace::clean> to start
64collecting functions for the next C<use namespace::clean;> specification.
65
66You can use the C<-except> flag to tell C<namespace::clean> that you
67don't want it to remove a certain function or method. A common use would
68be a module exporting an C<import> method along with some functions:
69
70 use ModuleExportingImport;
71 use namespace::clean -except => [qw( import )];
72
73If you just want to C<-except> a single sub, you can pass it directly.
74For more than one value you have to use an array reference.
75
76=head2 Explicitly removing functions when your scope is compiled
77
78It is also possible to explicitly tell C<namespace::clean> what packages
79to remove when the surrounding scope has finished compiling. Here is an
80example:
81
82 package Foo;
83 use strict;
84
85 # blessed NOT available
86
87 sub my_class {
88 use Scalar::Util qw( blessed );
89 use namespace::clean qw( blessed );
90
91 # blessed available
92 return blessed shift;
93 }
94
95 # blessed NOT available
96
97=head2 Moose
98
99When using C<namespace::clean> together with L<Moose> you want to keep
100the installed C<meta> method. So your classes should look like:
101
102 package Foo;
103 use Moose;
104 use namespace::clean -except => 'meta';
105 ...
106
107Same goes for L<Moose::Role>.
108
109=head2 Cleaning other packages
110
111You can tell C<namespace::clean> that you want to clean up another package
112instead of the one importing. To do this you have to pass in the C<-cleanee>
113option like this:
114
115 package My::MooseX::namespace::clean;
116 use strict;
117
118 use namespace::clean (); # no cleanup, just load
119
120 sub import {
121 namespace::clean->import(
122 -cleanee => scalar(caller),
123 -except => 'meta',
124 );
125 }
126
127If you don't care about C<namespace::clean>s discover-and-C<-except> logic, and
128just want to remove subroutines, try L</clean_subroutines>.
129
130=head1 METHODS
131
132=head2 clean_subroutines
133
134This exposes the actual subroutine-removal logic.
135
136 namespace::clean->clean_subroutines($cleanee, qw( subA subB ));
137
138will remove C<subA> and C<subB> from C<$cleanee>. Note that this will remove the
139subroutines B<immediately> and not wait for scope end. If you want to have this
140effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
141it is your responsibility to make sure it runs at that time.
142
143=cut
144
145# Constant to optimise away the unused code branches
146use constant FIXUP_NEEDED => $] < 5.015_005_1;
147use constant FIXUP_RENAME_SUB => $] > 5.008_008_9 && $] < 5.013_005_1;
148{
149 no strict;
150 delete ${__PACKAGE__."::"}{FIXUP_NEEDED};
151 delete ${__PACKAGE__."::"}{FIXUP_RENAME_SUB};
152}
153
154# Debugger fixup necessary before perl 5.15.5
155#
156# In perl 5.8.9-5.12, it assumes that sub_fullname($sub) can
157# always be used to find the CV again.
158# In perl 5.8.8 and 5.14, it assumes that the name of the glob
159# passed to entersub can be used to find the CV.
160# since we are deleting the glob where the subroutine was originally
161# defined, those assumptions no longer hold.
162#
163# So in 5.8.9-5.12 we need to move it elsewhere and point the
164# CV's name to the new glob.
165#
166# In 5.8.8 and 5.14 we move it elsewhere and rename the
167# original glob by assigning the new glob back to it.
168my $sub_utils_loaded;
169my $DebuggerFixup = sub {
170 my ($f, $sub, $cleanee_stash, $deleted_stash) = @_;
171
172 if (FIXUP_RENAME_SUB) {
173 if (! defined $sub_utils_loaded ) {
174 $sub_utils_loaded = do {
175
176 # when changing version also change in Makefile.PL
177 my $sn_ver = 0.04;
178 eval { require Sub::Name; Sub::Name->VERSION($sn_ver) }
179 or die "Sub::Name $sn_ver required when running under -d or equivalent: $@";
180
181 # when changing version also change in Makefile.PL
182 my $si_ver = 0.04;
183 eval { require Sub::Identify; Sub::Identify->VERSION($si_ver) }
184 or die "Sub::Identify $si_ver required when running under -d or equivalent: $@";
185
186 1;
187 } ? 1 : 0;
188 }
189
190 if ( Sub::Identify::sub_fullname($sub) eq ($cleanee_stash->name . "::$f") ) {
191 my $new_fq = $deleted_stash->name . "::$f";
192 Sub::Name::subname($new_fq, $sub);
193 $deleted_stash->add_symbol("&$f", $sub);
194 }
195 }
196 else {
197 $deleted_stash->add_symbol("&$f", $sub);
198 }
199};
200
201my $RemoveSubs = sub {
202 my $cleanee = shift;
203 my $store = shift;
204 my $cleanee_stash = Package::Stash->new($cleanee);
205 my $deleted_stash;
206
207 SYMBOL:
208 for my $f (@_) {
209
210 # ignore already removed symbols
211 next SYMBOL if $store->{exclude}{ $f };
212
2131971.13ms my $sub = $cleanee_stash->get_symbol("&$f")
# spent 925µs making 170 calls to Package::Stash::XS::namespace, avg 5µs/call # spent 203µs making 27 calls to Package::Stash::XS::name, avg 8µs/call
214 or next SYMBOL;
215
216 my $need_debugger_fixup =
217 FIXUP_NEEDED
218 &&
219 $^P
220 &&
221 ref(my $globref = \$cleanee_stash->namespace->{$f}) eq 'GLOB'
222 ;
223
224 if (FIXUP_NEEDED && $need_debugger_fixup) {
225 # convince the Perl debugger to work
226 # see the comment on top of $DebuggerFixup
227 $DebuggerFixup->(
228 $f,
229 $sub,
230 $cleanee_stash,
231 $deleted_stash ||= Package::Stash->new("namespace::clean::deleted::$cleanee"),
232 );
233 }
234
235 my @symbols = map {
236 my $name = $_ . $f;
237680459µs my $def = $cleanee_stash->get_symbol($name);
# spent 459µs making 680 calls to Package::Stash::XS::namespace, avg 676ns/call
238 defined($def) ? [$name, $def] : ()
239 } '$', '@', '%', '';
240
24117083µs $cleanee_stash->remove_glob($f);
# spent 83µs making 170 calls to Package::Stash::XS::namespace, avg 488ns/call
242
243 # if this perl needs no renaming trick we need to
244 # rename the original glob after the fact
245 # (see commend of $DebuggerFixup
246 if (FIXUP_NEEDED && !FIXUP_RENAME_SUB && $need_debugger_fixup) {
247 *$globref = $deleted_stash->namespace->{$f};
248 }
249
2501500ns $cleanee_stash->add_symbol(@$_) for @symbols;
# spent 500ns making 1 call to Package::Stash::XS::namespace
251 }
252};
253
254sub clean_subroutines {
255 my ($nc, $cleanee, @subs) = @_;
256 $RemoveSubs->($cleanee, {}, @subs);
257}
258
259=head2 import
260
261Makes a snapshot of the current defined functions and installs a
262L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
263
264=cut
265
266sub import {
267 my ($pragma, @args) = @_;
268
269 my (%args, $is_explicit);
270
271 ARG:
272 while (@args) {
273
274 if ($args[0] =~ /^\-/) {
275 my $key = shift @args;
276 my $value = shift @args;
277 $args{ $key } = $value;
278 }
279 else {
280 $is_explicit++;
281 last ARG;
282 }
283 }
284
285 my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
286 if ($is_explicit) {
287 on_scope_end {
288 $RemoveSubs->($cleanee, {}, @args);
289 };
290 }
291 else {
292
293 # calling class, all current functions and our storage
294 my $functions = $pragma->get_functions($cleanee);
295 my $store = $pragma->get_class_store($cleanee);
296 my $stash = Package::Stash->new($cleanee);
297
298 # except parameter can be array ref or single value
299 my %except = map {( $_ => 1 )} (
300 $args{ -except }
301 ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
302 : ()
303 );
304
305 # register symbols for removal, if they have a CODE entry
306 for my $f (keys %$functions) {
307 next if $except{ $f };
308197181µs next unless $stash->has_symbol("&$f");
# spent 168µs making 170 calls to Package::Stash::XS::namespace, avg 986ns/call # spent 13µs making 27 calls to Package::Stash::XS::name, avg 481ns/call
309 $store->{remove}{ $f } = 1;
310 }
311
312 # register EOF handler on first call to import
313 unless ($store->{handler_is_installed}) {
314 on_scope_end {
315 $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
316 };
317 $store->{handler_is_installed} = 1;
318 }
319
320 return 1;
321 }
322}
323
324=head2 unimport
325
326This method will be called when you do a
327
328 no namespace::clean;
329
330It will start a new section of code that defines functions to clean up.
331
332=cut
333
334sub unimport {
335 my ($pragma, %args) = @_;
336
337 # the calling class, the current functions and our storage
338 my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
339 my $functions = $pragma->get_functions($cleanee);
340 my $store = $pragma->get_class_store($cleanee);
341
342 # register all unknown previous functions as excluded
343 for my $f (keys %$functions) {
344 next if $store->{remove}{ $f }
345 or $store->{exclude}{ $f };
346 $store->{exclude}{ $f } = 1;
347 }
348
349 return 1;
350}
351
352=head2 get_class_store
353
354This returns a reference to a hash in a passed package containing
355information about function names included and excluded from removal.
356
357=cut
358
359sub get_class_store {
360 my ($pragma, $class) = @_;
361 my $stash = Package::Stash->new($class);
362 my $var = "%$STORAGE_VAR";
36384154µs $stash->add_symbol($var, {})
# spent 140µs making 56 calls to Package::Stash::XS::namespace, avg 3µs/call # spent 14µs making 28 calls to Package::Stash::XS::name, avg 504ns/call
364 unless $stash->has_symbol($var);
3652816µs return $stash->get_symbol($var);
# spent 16µs making 28 calls to Package::Stash::XS::namespace, avg 554ns/call
366}
367
368=head2 get_functions
369
370Takes a class as argument and returns all currently defined functions
371in it as a hash reference with the function name as key and a typeglob
372reference to the symbol as value.
373
374=cut
375
376sub get_functions {
377 my ($pragma, $class) = @_;
378
379 my $stash = Package::Stash->new($class);
380 return {
381226338µs map { $_ => $stash->get_symbol("&$_") }
# spent 313µs making 198 calls to Package::Stash::XS::namespace, avg 2µs/call # spent 25µs making 28 calls to Package::Stash::XS::name, avg 889ns/call
382 $stash->list_all_symbols('CODE')
383 };
384}
385
386=head1 IMPLEMENTATION DETAILS
387
388This module works through the effect that a
389
390 delete $SomePackage::{foo};
391
392will remove the C<foo> symbol from C<$SomePackage> for run time lookups
393(e.g., method calls) but will leave the entry alive to be called by
394already resolved names in the package itself. C<namespace::clean> will
395restore and therefor in effect keep all glob slots that aren't C<CODE>.
396
397A test file has been added to the perl core to ensure that this behaviour
398will be stable in future releases.
399
400Just for completeness sake, if you want to remove the symbol completely,
401use C<undef> instead.
402
403=head1 SEE ALSO
404
405L<B::Hooks::EndOfScope>
406
407=head1 THANKS
408
409Many thanks to Matt S Trout for the inspiration on the whole idea.
410
411=head1 AUTHORS
412
413=over
414
415=item *
416
417Robert 'phaylon' Sedlacek <rs@474.at>
418
419=item *
420
421Florian Ragwitz <rafl@debian.org>
422
423=item *
424
425Jesse Luehrs <doy@tozt.net>
426
427=item *
428
429Peter Rabbitson <ribasushi@cpan.org>
430
431=item *
432
433Father Chrysostomos <sprout@cpan.org>
434
435=back
436
437=head1 COPYRIGHT AND LICENSE
438
439This software is copyright (c) 2011 by L</AUTHORS>
440
441This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.
442
443=cut
444
445no warnings;
446'Danger! Laws of Thermodynamics may not apply.'