Profile of namespace/clean.pm

Filename	/usr/share/perl5/namespace/clean.pm
Statements	Executed 0 statements in 0s

Line	Calls	Time in subs	Code
1			package namespace::clean;
2
3			use warnings;
4			use strict;
5
6			use Package::Stash;
7
8			our $VERSION = '0.25';
9			our $STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
10
11			use B::Hooks::EndOfScope 'on_scope_end';
12
13			=head1 NAME
14
15			namespace::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
52			When you define a function, or import one, into a Perl package, it will
53			naturally also be available as a method. This does not per se cause
54			problems, but it can complicate subclassing and, for example, plugin
55			classes that are included via multiple inheritance by loading them as
56			base classes.
57
58			The C<namespace::clean> pragma will remove all previously declared or
59			imported symbols at the end of the current package's compile cycle.
60			Functions called in the package itself will still be bound by their
61			name, but they won't show up as methods on your class or instances.
62
63			By unimporting via C<no> you can tell C<namespace::clean> to start
64			collecting functions for the next C<use namespace::clean;> specification.
65
66			You can use the C<-except> flag to tell C<namespace::clean> that you
67			don't want it to remove a certain function or method. A common use would
68			be a module exporting an C<import> method along with some functions:
69
70			use ModuleExportingImport;
71			use namespace::clean -except => [qw( import )];
72
73			If you just want to C<-except> a single sub, you can pass it directly.
74			For more than one value you have to use an array reference.
75
76			=head2 Explicitly removing functions when your scope is compiled
77
78			It is also possible to explicitly tell C<namespace::clean> what packages
79			to remove when the surrounding scope has finished compiling. Here is an
80			example:
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
99			When using C<namespace::clean> together with L<Moose> you want to keep
100			the 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
107			Same goes for L<Moose::Role>.
108
109			=head2 Cleaning other packages
110
111			You can tell C<namespace::clean> that you want to clean up another package
112			instead of the one importing. To do this you have to pass in the C<-cleanee>
113			option 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
127			If you don't care about C<namespace::clean>s discover-and-C<-except> logic, and
128			just want to remove subroutines, try L</clean_subroutines>.
129
130			=head1 METHODS
131
132			=head2 clean_subroutines
133
134			This exposes the actual subroutine-removal logic.
135
136			namespace::clean->clean_subroutines($cleanee, qw( subA subB ));
137
138			will remove C<subA> and C<subB> from C<$cleanee>. Note that this will remove the
139			subroutines B<immediately> and not wait for scope end. If you want to have this
140			effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
141			it is your responsibility to make sure it runs at that time.
142
143			=cut
144
145			# Constant to optimise away the unused code branches
146			use constant FIXUP_NEEDED => $] < 5.015_005_1;
147			use 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.
168			my $sub_utils_loaded;
169			my $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
201			my $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
213	190	1.25ms	my $sub = $cleanee_stash->get_symbol("&$f") # spent 1.02ms making 165 calls to Package::Stash::XS::namespace, avg 6µs/call # spent 236µs making 25 calls to Package::Stash::XS::name, avg 9µ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;
237	660	585µs	my $def = $cleanee_stash->get_symbol($name); # spent 585µs making 660 calls to Package::Stash::XS::namespace, avg 886ns/call
238			defined($def) ? [$name, $def] : ()
239			} '$', '@', '%', '';
240
241	165	96µs	$cleanee_stash->remove_glob($f); # spent 96µs making 165 calls to Package::Stash::XS::namespace, avg 579ns/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
250	1	500ns	$cleanee_stash->add_symbol(@$_) for @symbols; # spent 500ns making 1 call to Package::Stash::XS::namespace
251			}
252			};
253
254			sub clean_subroutines {
255			my ($nc, $cleanee, @subs) = @_;
256			$RemoveSubs->($cleanee, {}, @subs);
257			}
258
259			=head2 import
260
261			Makes a snapshot of the current defined functions and installs a
262			L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
263
264			=cut
265
266			sub 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 };
308	190	176µs	next unless $stash->has_symbol("&$f"); # spent 164µs making 165 calls to Package::Stash::XS::namespace, avg 996ns/call # spent 11µs making 25 calls to Package::Stash::XS::name, avg 448ns/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
326			This method will be called when you do a
327
328			no namespace::clean;
329
330			It will start a new section of code that defines functions to clean up.
331
332			=cut
333
334			sub 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
354			This returns a reference to a hash in a passed package containing
355			information about function names included and excluded from removal.
356
357			=cut
358
359			sub get_class_store {
360			my ($pragma, $class) = @_;
361			my $stash = Package::Stash->new($class);
362			my $var = "%$STORAGE_VAR";
363	78	133µs	$stash->add_symbol($var, {}) # spent 120µs making 52 calls to Package::Stash::XS::namespace, avg 2µs/call # spent 13µs making 26 calls to Package::Stash::XS::name, avg 488ns/call
364			unless $stash->has_symbol($var);
365	26	14µs	return $stash->get_symbol($var); # spent 14µs making 26 calls to Package::Stash::XS::namespace, avg 519ns/call
366			}
367
368			=head2 get_functions
369
370			Takes a class as argument and returns all currently defined functions
371			in it as a hash reference with the function name as key and a typeglob
372			reference to the symbol as value.
373
374			=cut
375
376			sub get_functions {
377			my ($pragma, $class) = @_;
378
379			my $stash = Package::Stash->new($class);
380			return {
381	217	323µs	map { $_ => $stash->get_symbol("&$_") } # spent 292µs making 191 calls to Package::Stash::XS::namespace, avg 2µs/call # spent 30µs making 26 calls to Package::Stash::XS::name, avg 1µs/call
382			$stash->list_all_symbols('CODE')
383			};
384			}
385
386			=head1 IMPLEMENTATION DETAILS
387
388			This module works through the effect that a
389
390			delete $SomePackage::{foo};
391
392			will 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
394			already resolved names in the package itself. C<namespace::clean> will
395			restore and therefor in effect keep all glob slots that aren't C<CODE>.
396
397			A test file has been added to the perl core to ensure that this behaviour
398			will be stable in future releases.
399
400			Just for completeness sake, if you want to remove the symbol completely,
401			use C<undef> instead.
402
403			=head1 SEE ALSO
404
405			L<B::Hooks::EndOfScope>
406
407			=head1 THANKS
408
409			Many thanks to Matt S Trout for the inspiration on the whole idea.
410
411			=head1 AUTHORS
412
413			=over
414
415			=item *
416
417			Robert 'phaylon' Sedlacek <rs@474.at>
418
419			=item *
420
421			Florian Ragwitz <rafl@debian.org>
422
423			=item *
424
425			Jesse Luehrs <doy@tozt.net>
426
427			=item *
428
429			Peter Rabbitson <ribasushi@cpan.org>
430
431			=item *
432
433			Father Chrysostomos <sprout@cpan.org>
434
435			=back
436
437			=head1 COPYRIGHT AND LICENSE
438
439			This software is copyright (c) 2011 by L</AUTHORS>
440
441			This 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
445			no warnings;
446			'Danger! Laws of Thermodynamics may not apply.'