[p5sagit/namespace-clean.git] / lib / namespace / clean.pm

package namespace::clean;

=head1 NAME

namespace::clean - Keep imports and functions out of your namespace

=cut

use warnings;
use strict;

use vars        qw( $VERSION $STORAGE_VAR $SCOPE_HOOK_KEY $SCOPE_EXPLICIT );
use Symbol      qw( qualify_to_ref gensym );
use B::Hooks::EndOfScope;
use Sub::Identify qw(sub_fullname);
use Sub::Name qw(subname);

=head1 VERSION

0.11

=cut

$VERSION         = '0.11';
$STORAGE_VAR     = '__NAMESPACE_CLEAN_STORAGE';

=head1 SYNOPSIS

  package Foo;
  use warnings;
  use strict;

  use Carp qw(croak);   # 'croak' will be removed

  sub bar { 23 }        # 'bar' will be removed

  # remove all previously defined functions
  use namespace::clean;

  sub baz { bar() }     # 'baz' still defined, 'bar' still bound

  # begin to collection function names from here again
  no namespace::clean;

  sub quux { baz() }    # 'quux' will be removed

  # remove all functions defined after the 'no' unimport
  use namespace::clean;

  # Will print: 'No', 'No', 'Yes' and 'No'
  print +(__PACKAGE__->can('croak') ? 'Yes' : 'No'), "\n";
  print +(__PACKAGE__->can('bar')   ? 'Yes' : 'No'), "\n";
  print +(__PACKAGE__->can('baz')   ? 'Yes' : 'No'), "\n";
  print +(__PACKAGE__->can('quux')  ? 'Yes' : 'No'), "\n";

  1;

=head1 DESCRIPTION

=head2 Keeping packages clean

When you define a function, or import one, into a Perl package, it will
naturally also be available as a method. This does not per se cause
problems, but it can complicate subclassing and, for example, plugin
classes that are included via multiple inheritance by loading them as 
base classes.

The C<namespace::clean> pragma will remove all previously declared or
imported symbols at the end of the current package's compile cycle.
Functions called in the package itself will still be bound by their
name, but they won't show up as methods on your class or instances.

By unimporting via C<no> you can tell C<namespace::clean> to start
collecting functions for the next C<use namespace::clean;> specification.

You can use the C<-except> flag to tell C<namespace::clean> that you
don't want it to remove a certain function or method. A common use would
be a module exporting an C<import> method along with some functions:

  use ModuleExportingImport;
  use namespace::clean -except => [qw( import )];

If you just want to C<-except> a single sub, you can pass it directly.
For more than one value you have to use an array reference.

=head2 Explicitely removing functions when your scope is compiled

It is also possible to explicitely tell C<namespace::clean> what packages
to remove when the surrounding scope has finished compiling. Here is an
example:

  package Foo;
  use strict;

  # blessed NOT available

  sub my_class {
      use Scalar::Util qw( blessed );
      use namespace::clean qw( blessed );

      # blessed available
      return blessed shift;
  }

  # blessed NOT available

=head2 Moose

When using C<namespace::clean> together with L<Moose> you want to keep
the installed C<meta> method. So your classes should look like:

  package Foo;
  use Moose;
  use namespace::clean -except => 'meta';
  ...

Same goes for L<Moose::Role>.

=head2 Cleaning other packages

You can tell C<namespace::clean> that you want to clean up another package
instead of the one importing. To do this you have to pass in the C<-cleanee>
option like this:

  package My::MooseX::namespace::clean;
  use strict;

  use namespace::clean (); # no cleanup, just load

  sub import {
      namespace::clean->import(
        -cleanee => scalar(caller),
        -except  => 'meta',
      );
  }

If you don't care about C<namespace::clean>s discover-and-C<-except> logic, and
just want to remove subroutines, try L</clean_subroutines>.

=head1 METHODS

You shouldn't need to call any of these. Just C<use> the package at the
appropriate place.

=cut

=head2 clean_subroutines

This exposes the actual subroutine-removal logic.

  namespace::clean->clean_subroutines($cleanee, qw( subA subB ));

will remove C<subA> and C<subB> from C<$cleanee>. Note that this will remove the
subroutines B<immediately> and not wait for scope end. If you want to have this
effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
it is your responsibility to make sure it runs at that time.

=cut

my $RemoveSubs = sub {

    my $cleanee = shift;
    my $store   = shift;
  SYMBOL:
    for my $f (@_) {
        my $fq = "${cleanee}::$f";

        # ignore already removed symbols
        next SYMBOL if $store->{exclude}{ $f };
        no strict 'refs';

        next SYMBOL unless exists ${ "${cleanee}::" }{ $f };

        if (ref(\${ "${cleanee}::" }{ $f }) eq 'GLOB') {
            # convince the Perl debugger to work
            # it assumes that sub_fullname($sub) can always be used to find the CV again
            # since we are deleting the glob where the subroutine was originally
            # defined, that assumption no longer holds, so we need to move it
            # elsewhere and point the CV's name to the new glob.
            my $sub = \&$fq;
            if ( sub_fullname($sub) eq $fq ) {
                my $new_fq = "namespace::clean::deleted::$fq";
                subname($new_fq, $sub);
                *{$new_fq} = $sub;
            }

            local *__tmp;

            # keep original value to restore non-code slots
            {   no warnings 'uninitialized';    # fix possible unimports
                *__tmp = *{ ${ "${cleanee}::" }{ $f } };
                delete ${ "${cleanee}::" }{ $f };
            }

          SLOT:
            # restore non-code slots to symbol.
            # omit the FORMAT slot, since perl erroneously puts it into the
            # SCALAR slot of the new glob.
            for my $t (qw( SCALAR ARRAY HASH IO )) {
                next SLOT unless defined *__tmp{ $t };
                *{ "${cleanee}::$f" } = *__tmp{ $t };
            }
        }
        else {
            # A non-glob in the stash is assumed to stand for some kind
            # of function.  So far they all do, but the core might change
            # this some day.  Watch perl5-porters.
            delete ${ "${cleanee}::" }{ $f };
        }
    }
};

sub clean_subroutines {
    my ($nc, $cleanee, @subs) = @_;
    $RemoveSubs->($cleanee, {}, @subs);
}

=head2 import

Makes a snapshot of the current defined functions and installs a
L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.

=cut

sub import {
    my ($pragma, @args) = @_;

    my (%args, $is_explicit);

  ARG:
    while (@args) {

        if ($args[0] =~ /^\-/) {
            my $key = shift @args;
            my $value = shift @args;
            $args{ $key } = $value;
        }
        else {
            $is_explicit++;
            last ARG;
        }
    }

    my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
    if ($is_explicit) {
        on_scope_end {
            $RemoveSubs->($cleanee, {}, @args);
        };
    }
    else {

        # calling class, all current functions and our storage
        my $functions = $pragma->get_functions($cleanee);
        my $store     = $pragma->get_class_store($cleanee);

        # except parameter can be array ref or single value
        my %except = map {( $_ => 1 )} (
            $args{ -except }
            ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
            : ()
        );

        # register symbols for removal, if they have a CODE entry
        for my $f (keys %$functions) {
            next if     $except{ $f };
            next unless    $functions->{ $f } 
                    and *{ $functions->{ $f } }{CODE};
            $store->{remove}{ $f } = 1;
        }

        # register EOF handler on first call to import
        unless ($store->{handler_is_installed}) {
            on_scope_end {
                $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
            };
            $store->{handler_is_installed} = 1;
        }

        return 1;
    }
}

=head2 unimport

This method will be called when you do a

  no namespace::clean;

It will start a new section of code that defines functions to clean up.

=cut

sub unimport {
    my ($pragma, %args) = @_;

    # the calling class, the current functions and our storage
    my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
    my $functions = $pragma->get_functions($cleanee);
    my $store     = $pragma->get_class_store($cleanee);

    # register all unknown previous functions as excluded
    for my $f (keys %$functions) {
        next if $store->{remove}{ $f }
             or $store->{exclude}{ $f };
        $store->{exclude}{ $f } = 1;
    }

    return 1;
}

=head2 get_class_store

This returns a reference to a hash in a passed package containing 
information about function names included and excluded from removal.

=cut

sub get_class_store {
    my ($pragma, $class) = @_;
    no strict 'refs';
    return \%{ "${class}::${STORAGE_VAR}" };
}

=head2 get_functions

Takes a class as argument and returns all currently defined functions
in it as a hash reference with the function name as key and a typeglob
reference to the symbol as value.

=cut

sub get_functions {
    my ($pragma, $class) = @_;

    return {
        map  { @$_ }                                        # key => value
        grep { *{ $_->[1] }{CODE} }                         # only functions
        map  { [$_, qualify_to_ref( $_, $class )] }         # get globref
        grep { $_ !~ /::$/ }                                # no packages
        do   { no strict 'refs'; keys %{ "${class}::" } }   # symbol entries
    };
}

=head1 BUGS

C<namespace::clean> will clobber any formats that have the same name as
a deleted sub. This is due to a bug in perl that makes it impossible to
re-assign the FORMAT ref into a new glob.

=head1 IMPLEMENTATION DETAILS

This module works through the effect that a 

  delete $SomePackage::{foo};

will remove the C<foo> symbol from C<$SomePackage> for run time lookups
(e.g., method calls) but will leave the entry alive to be called by
already resolved names in the package itself. C<namespace::clean> will
restore and therefor in effect keep all glob slots that aren't C<CODE>.

A test file has been added to the perl core to ensure that this behaviour
will be stable in future releases.

Just for completeness sake, if you want to remove the symbol completely,
use C<undef> instead.

=head1 SEE ALSO

L<B::Hooks::EndOfScope>

=head1 AUTHOR AND COPYRIGHT

Robert 'phaylon' Sedlacek C<E<lt>rs@474.atE<gt>>, with many thanks to
Matt S Trout for the inspiration on the whole idea.

=head1 LICENSE

This program is free software; you can redistribute it and/or modify 
it under the same terms as perl itself.

=cut

no warnings;
'Danger! Laws of Thermodynamics may not apply.'
Commit	Line	Data
40aef9d6	1	package namespace::clean;
	2
	3	=head1 NAME
	4
6c0ece9b	5	namespace::clean - Keep imports and functions out of your namespace
40aef9d6	6
	7	=cut
	8
	9	use warnings;
	10	use strict;
	11
de673bbf	12	use vars qw( $VERSION $STORAGE_VAR $SCOPE_HOOK_KEY $SCOPE_EXPLICIT );
07fbef3d	13	use Symbol qw( qualify_to_ref gensym );
aa2aafae	14	use B::Hooks::EndOfScope;
07fbef3d	15	use Sub::Identify qw(sub_fullname);
07fbef3d	16	use Sub::Name qw(subname);
40aef9d6	17
	18	=head1 VERSION
	19
fcfe7810	20	0.11
40aef9d6	21
	22	=cut
	23
fcfe7810	24	$VERSION = '0.11';
de673bbf	25	$STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
40aef9d6	26
	27	=head1 SYNOPSIS
	28
	29	package Foo;
	30	use warnings;
	31	use strict;
	32
6c0ece9b	33	use Carp qw(croak); # 'croak' will be removed
40aef9d6	34
6c0ece9b	35	sub bar { 23 } # 'bar' will be removed
40aef9d6	36
6c0ece9b	37	# remove all previously defined functions
40aef9d6	38	use namespace::clean;
40aef9d6	39
6c0ece9b	40	sub baz { bar() } # 'baz' still defined, 'bar' still bound
40aef9d6	41
6c0ece9b	42	# begin to collection function names from here again
9b680ffe	43	no namespace::clean;
9b680ffe	44
6c0ece9b	45	sub quux { baz() } # 'quux' will be removed
9b680ffe	46
6c0ece9b	47	# remove all functions defined after the 'no' unimport
9b680ffe	48	use namespace::clean;
9b680ffe	49
6c0ece9b	50	# Will print: 'No', 'No', 'Yes' and 'No'
40aef9d6	51	print +(__PACKAGE__->can('croak') ? 'Yes' : 'No'), "\n";
	52	print +(__PACKAGE__->can('bar') ? 'Yes' : 'No'), "\n";
	53	print +(__PACKAGE__->can('baz') ? 'Yes' : 'No'), "\n";
9b680ffe	54	print +(__PACKAGE__->can('quux') ? 'Yes' : 'No'), "\n";
40aef9d6	55
	56	1;
	57
	58	=head1 DESCRIPTION
	59
de673bbf	60	=head2 Keeping packages clean
de673bbf	61
40aef9d6	62	When you define a function, or import one, into a Perl package, it will
	63	naturally also be available as a method. This does not per se cause
	64	problems, but it can complicate subclassing and, for example, plugin
6c0ece9b	65	classes that are included via multiple inheritance by loading them as
6c0ece9b	66	base classes.
40aef9d6	67
	68	The C<namespace::clean> pragma will remove all previously declared or
	69	imported symbols at the end of the current package's compile cycle.
6c0ece9b	70	Functions called in the package itself will still be bound by their
	71	name, but they won't show up as methods on your class or instances.
	72
	73	By unimporting via C<no> you can tell C<namespace::clean> to start
	74	collecting functions for the next C<use namespace::clean;> specification.
40aef9d6	75
53e92ec5	76	You can use the C<-except> flag to tell C<namespace::clean> that you
472d4b1e	77	don't want it to remove a certain function or method. A common use would
472d4b1e	78	be a module exporting an C<import> method along with some functions:
53e92ec5	79
	80	use ModuleExportingImport;
	81	use namespace::clean -except => [qw( import )];
	82
472d4b1e	83	If you just want to C<-except> a single sub, you can pass it directly.
	84	For more than one value you have to use an array reference.
	85
de673bbf	86	=head2 Explicitely removing functions when your scope is compiled
	87
	88	It is also possible to explicitely tell C<namespace::clean> what packages
	89	to remove when the surrounding scope has finished compiling. Here is an
	90	example:
	91
	92	package Foo;
	93	use strict;
	94
	95	# blessed NOT available
	96
	97	sub my_class {
	98	use Scalar::Util qw( blessed );
	99	use namespace::clean qw( blessed );
	100
	101	# blessed available
	102	return blessed shift;
	103	}
	104
	105	# blessed NOT available
	106
1a1be5dc	107	=head2 Moose
	108
	109	When using C<namespace::clean> together with L<Moose> you want to keep
	110	the installed C<meta> method. So your classes should look like:
	111
	112	package Foo;
	113	use Moose;
	114	use namespace::clean -except => 'meta';
	115	...
	116
	117	Same goes for L<Moose::Role>.
	118
fcfe7810	119	=head2 Cleaning other packages
	120
	121	You can tell C<namespace::clean> that you want to clean up another package
	122	instead of the one importing. To do this you have to pass in the C<-cleanee>
	123	option like this:
	124
	125	package My::MooseX::namespace::clean;
	126	use strict;
	127
	128	use namespace::clean (); # no cleanup, just load
	129
	130	sub import {
	131	namespace::clean->import(
	132	-cleanee => scalar(caller),
	133	-except => 'meta',
	134	);
	135	}
	136
	137	If you don't care about C<namespace::clean>s discover-and-C<-except> logic, and
	138	just want to remove subroutines, try L</clean_subroutines>.
	139
40aef9d6	140	=head1 METHODS
	141
	142	You shouldn't need to call any of these. Just C<use> the package at the
	143	appropriate place.
	144
6c0ece9b	145	=cut
6c0ece9b	146
fcfe7810	147	=head2 clean_subroutines
40aef9d6	148
fcfe7810	149	This exposes the actual subroutine-removal logic.
	150
	151	namespace::clean->clean_subroutines($cleanee, qw( subA subB ));
	152
	153	will remove C<subA> and C<subB> from C<$cleanee>. Note that this will remove the
	154	subroutines B<immediately> and not wait for scope end. If you want to have this
	155	effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
	156	it is your responsibility to make sure it runs at that time.
40aef9d6	157
	158	=cut
	159
de673bbf	160	my $RemoveSubs = sub {
fcfe7810	161
de673bbf	162	my $cleanee = shift;
	163	my $store = shift;
	164	SYMBOL:
	165	for my $f (@_) {
07fbef3d	166	my $fq = "${cleanee}::$f";
de673bbf	167
	168	# ignore already removed symbols
	169	next SYMBOL if $store->{exclude}{ $f };
	170	no strict 'refs';
	171
226432f6	172	next SYMBOL unless exists ${ "${cleanee}::" }{ $f };
	173
	174	if (ref(\${ "${cleanee}::" }{ $f }) eq 'GLOB') {
	175	# convince the Perl debugger to work
	176	# it assumes that sub_fullname($sub) can always be used to find the CV again
	177	# since we are deleting the glob where the subroutine was originally
	178	# defined, that assumption no longer holds, so we need to move it
	179	# elsewhere and point the CV's name to the new glob.
	180	my $sub = \&$fq;
	181	if ( sub_fullname($sub) eq $fq ) {
	182	my $new_fq = "namespace::clean::deleted::$fq";
	183	subname($new_fq, $sub);
	184	*{$new_fq} = $sub;
	185	}
	186
	187	local *__tmp;
	188
	189	# keep original value to restore non-code slots
	190	{ no warnings 'uninitialized'; # fix possible unimports
	191	__tmp = { ${ "${cleanee}::" }{ $f } };
	192	delete ${ "${cleanee}::" }{ $f };
	193	}
	194
	195	SLOT:
	196	# restore non-code slots to symbol.
	197	# omit the FORMAT slot, since perl erroneously puts it into the
	198	# SCALAR slot of the new glob.
	199	for my $t (qw( SCALAR ARRAY HASH IO )) {
	200	next SLOT unless defined *__tmp{ $t };
	201	{ "${cleanee}::$f" } = __tmp{ $t };
	202	}
07fbef3d	203	}
226432f6	204	else {
	205	# A non-glob in the stash is assumed to stand for some kind
	206	# of function. So far they all do, but the core might change
	207	# this some day. Watch perl5-porters.
de673bbf	208	delete ${ "${cleanee}::" }{ $f };
de673bbf	209	}
de673bbf	210	}
de673bbf	211	};
53e92ec5	212
fcfe7810	213	sub clean_subroutines {
	214	my ($nc, $cleanee, @subs) = @_;
	215	$RemoveSubs->($cleanee, {}, @subs);
	216	}
	217
	218	=head2 import
	219
	220	Makes a snapshot of the current defined functions and installs a
	221	L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
	222
	223	=cut
	224
de673bbf	225	sub import {
de673bbf	226	my ($pragma, @args) = @_;
53e92ec5	227
de673bbf	228	my (%args, $is_explicit);
fcfe7810	229
	230	ARG:
	231	while (@args) {
	232
	233	if ($args[0] =~ /^\-/) {
	234	my $key = shift @args;
	235	my $value = shift @args;
	236	$args{ $key } = $value;
	237	}
	238	else {
	239	$is_explicit++;
	240	last ARG;
	241	}
9b680ffe	242	}
9b680ffe	243
fcfe7810	244	my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
de673bbf	245	if ($is_explicit) {
aa2aafae	246	on_scope_end {
de673bbf	247	$RemoveSubs->($cleanee, {}, @args);
aa2aafae	248	};
9b680ffe	249	}
de673bbf	250	else {
	251
	252	# calling class, all current functions and our storage
	253	my $functions = $pragma->get_functions($cleanee);
	254	my $store = $pragma->get_class_store($cleanee);
	255
	256	# except parameter can be array ref or single value
	257	my %except = map {( $_ => 1 )} (
	258	$args{ -except }
	259	? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
	260	: ()
	261	);
	262
	263	# register symbols for removal, if they have a CODE entry
	264	for my $f (keys %$functions) {
	265	next if $except{ $f };
	266	next unless $functions->{ $f }
	267	and *{ $functions->{ $f } }{CODE};
	268	$store->{remove}{ $f } = 1;
	269	}
	270
	271	# register EOF handler on first call to import
	272	unless ($store->{handler_is_installed}) {
aa2aafae	273	on_scope_end {
de673bbf	274	$RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
aa2aafae	275	};
de673bbf	276	$store->{handler_is_installed} = 1;
	277	}
	278
	279	return 1;
	280	}
9b680ffe	281	}
	282
	283	=head2 unimport
	284
	285	This method will be called when you do a
	286
	287	no namespace::clean;
	288
	289	It will start a new section of code that defines functions to clean up.
	290
	291	=cut
	292
	293	sub unimport {
fcfe7810	294	my ($pragma, %args) = @_;
9b680ffe	295
6c0ece9b	296	# the calling class, the current functions and our storage
fcfe7810	297	my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
9b680ffe	298	my $functions = $pragma->get_functions($cleanee);
	299	my $store = $pragma->get_class_store($cleanee);
	300
6c0ece9b	301	# register all unknown previous functions as excluded
9b680ffe	302	for my $f (keys %$functions) {
	303	next if $store->{remove}{ $f }
	304	or $store->{exclude}{ $f };
	305	$store->{exclude}{ $f } = 1;
	306	}
	307
	308	return 1;
	309	}
	310
	311	=head2 get_class_store
	312
6c0ece9b	313	This returns a reference to a hash in a passed package containing
6c0ece9b	314	information about function names included and excluded from removal.
9b680ffe	315
	316	=cut
	317
	318	sub get_class_store {
	319	my ($pragma, $class) = @_;
	320	no strict 'refs';
	321	return \%{ "${class}::${STORAGE_VAR}" };
40aef9d6	322	}
	323
	324	=head2 get_functions
	325
	326	Takes a class as argument and returns all currently defined functions
	327	in it as a hash reference with the function name as key and a typeglob
	328	reference to the symbol as value.
	329
	330	=cut
	331
	332	sub get_functions {
	333	my ($pragma, $class) = @_;
	334
	335	return {
6c0ece9b	336	map { @$_ } # key => value
	337	grep { *{ $_->[1] }{CODE} } # only functions
	338	map { [$_, qualify_to_ref( $_, $class )] } # get globref
	339	grep { $_ !~ /::$/ } # no packages
	340	do { no strict 'refs'; keys %{ "${class}::" } } # symbol entries
40aef9d6	341	};
	342	}
	343
61c4bce7	344	=head1 BUGS
	345
	346	C<namespace::clean> will clobber any formats that have the same name as
	347	a deleted sub. This is due to a bug in perl that makes it impossible to
	348	re-assign the FORMAT ref into a new glob.
	349
6c0ece9b	350	=head1 IMPLEMENTATION DETAILS
	351
	352	This module works through the effect that a
	353
	354	delete $SomePackage::{foo};
	355
	356	will remove the C<foo> symbol from C<$SomePackage> for run time lookups
	357	(e.g., method calls) but will leave the entry alive to be called by
472d4b1e	358	already resolved names in the package itself. C<namespace::clean> will
472d4b1e	359	restore and therefor in effect keep all glob slots that aren't C<CODE>.
6c0ece9b	360
	361	A test file has been added to the perl core to ensure that this behaviour
	362	will be stable in future releases.
	363
	364	Just for completeness sake, if you want to remove the symbol completely,
	365	use C<undef> instead.
	366
40aef9d6	367	=head1 SEE ALSO
40aef9d6	368
705fe1b1	369	L<B::Hooks::EndOfScope>
40aef9d6	370
	371	=head1 AUTHOR AND COPYRIGHT
	372
	373	Robert 'phaylon' Sedlacek C<E<lt>rs@474.atE<gt>>, with many thanks to
	374	Matt S Trout for the inspiration on the whole idea.
	375
	376	=head1 LICENSE
	377
	378	This program is free software; you can redistribute it and/or modify
	379	it under the same terms as perl itself.
	380
	381	=cut
	382
de673bbf	383	no warnings;
de673bbf	384	'Danger! Laws of Thermodynamics may not apply.'