← Back to branch summary

~ubuntu-branches/ubuntu/saucy/libnamespace-clean-perl/saucy

« back to all changes in this revision

Viewing changes to lib/namespace/clean.pm

  • Committer: Bazaar Package Importer
  • Author(s): Ansgar Burchardt
  • Date: 2011-08-05 11:12:15 UTC
  • mfrom: (1.1.9 upstream)
  • Revision ID: james.westby@ubuntu.com-20110805111215-3mvgb4b3dbdgp0tt
Tags: 0.21-1
* New upstream release.
* Remove patch fix-pod-spelling.patch (applied upstream).
* Add NAME section to POD documentation.
  + new patch: pod-whatis.diff
* Remove (build-)dep on libsub-name-perl, libsub-identify-perl (>= 0.04).
* Bump (build-)dep on libpackage-stash-perl to >= 0.23.
* debian/control: Convert Vcs-* fields to Git.
* Bump Standards-Version to 3.9.2 (no changes).

Show diffs side-by-side

added added

removed removed

Lines of Context:
lib/namespace/clean.pm
1
1
package namespace::clean;
2
 
BEGIN {
3
 
  $namespace::clean::AUTHORITY = 'cpan:PHAYLON';
4
 
}
5
 
BEGIN {
6
 
  $namespace::clean::VERSION = '0.20';
7
 
}
8
2
# ABSTRACT: Keep imports and functions out of your namespace
9
3
 
10
4
use warnings;
11
5
use strict;
12
6
 
13
7
use vars qw( $STORAGE_VAR );
14
 
use Sub::Name 0.04 qw(subname);
15
 
use Sub::Identify 0.04 qw(sub_fullname);
16
 
use Package::Stash 0.22;
17
 
use B::Hooks::EndOfScope 0.07;
 
8
use Package::Stash;
 
9
 
 
10
our $VERSION = '0.21';
18
11
 
19
12
$STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
20
13
 
21
 
 
22
 
my $RemoveSubs = sub {
23
 
 
24
 
    my $cleanee = shift;
25
 
    my $store   = shift;
26
 
    my $cleanee_stash = Package::Stash->new($cleanee);
27
 
    my $deleted_stash = Package::Stash->new("namespace::clean::deleted::$cleanee");
28
 
  SYMBOL:
29
 
    for my $f (@_) {
30
 
        my $variable = "&$f";
31
 
        # ignore already removed symbols
32
 
        next SYMBOL if $store->{exclude}{ $f };
33
 
 
34
 
        next SYMBOL unless $cleanee_stash->has_symbol($variable);
35
 
 
36
 
        if (ref(\$cleanee_stash->namespace->{$f}) eq 'GLOB') {
37
 
            # convince the Perl debugger to work
38
 
            # it assumes that sub_fullname($sub) can always be used to find the CV again
39
 
            # since we are deleting the glob where the subroutine was originally
40
 
            # defined, that assumption no longer holds, so we need to move it
41
 
            # elsewhere and point the CV's name to the new glob.
42
 
            my $sub = $cleanee_stash->get_symbol($variable);
43
 
            if ( sub_fullname($sub) eq ($cleanee_stash->name . "::$f") ) {
44
 
                my $new_fq = $deleted_stash->name . "::$f";
45
 
                subname($new_fq, $sub);
46
 
                $deleted_stash->add_symbol($variable, $sub);
47
 
            }
48
 
        }
49
 
 
50
 
        my ($scalar, $array, $hash, $io) = map {
51
 
            $cleanee_stash->get_symbol($_ . $f)
52
 
        } '$', '@', '%', '';
53
 
        $cleanee_stash->remove_glob($f);
54
 
        for my $var (['$', $scalar], ['@', $array], ['%', $hash], ['', $io]) {
55
 
            next unless defined $var->[1];
56
 
            $cleanee_stash->add_symbol($var->[0] . $f, $var->[1]);
57
 
        }
58
 
    }
59
 
};
60
 
 
61
 
sub clean_subroutines {
62
 
    my ($nc, $cleanee, @subs) = @_;
63
 
    $RemoveSubs->($cleanee, {}, @subs);
64
 
}
65
 
 
66
 
 
67
 
sub import {
68
 
    my ($pragma, @args) = @_;
69
 
 
70
 
    my (%args, $is_explicit);
71
 
 
72
 
  ARG:
73
 
    while (@args) {
74
 
 
75
 
        if ($args[0] =~ /^\-/) {
76
 
            my $key = shift @args;
77
 
            my $value = shift @args;
78
 
            $args{ $key } = $value;
79
 
        }
80
 
        else {
81
 
            $is_explicit++;
82
 
            last ARG;
83
 
        }
84
 
    }
85
 
 
86
 
    my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
87
 
    if ($is_explicit) {
88
 
        on_scope_end {
89
 
            $RemoveSubs->($cleanee, {}, @args);
90
 
        };
 
14
BEGIN {
 
15
 
 
16
  use warnings;
 
17
  use strict;
 
18
 
 
19
  # when changing also change in Makefile.PL
 
20
  my $b_h_eos_req = '0.07';
 
21
 
 
22
  if (eval {
 
23
    require B::Hooks::EndOfScope;
 
24
    B::Hooks::EndOfScope->VERSION($b_h_eos_req);
 
25
    1
 
26
  } ) {
 
27
    B::Hooks::EndOfScope->import('on_scope_end');
 
28
  }
 
29
  else {
 
30
    eval <<'PP' or die $@;
 
31
 
 
32
  use Tie::Hash ();
 
33
 
 
34
  {
 
35
    package namespace::clean::_TieHintHash;
 
36
 
 
37
    use warnings;
 
38
    use strict;
 
39
 
 
40
    use base 'Tie::ExtraHash';
 
41
  }
 
42
 
 
43
  {
 
44
    package namespace::clean::_ScopeGuard;
 
45
 
 
46
    use warnings;
 
47
    use strict;
 
48
 
 
49
    sub arm { bless [ $_[1] ] }
 
50
 
 
51
    sub DESTROY { $_[0]->[0]->() }
 
52
  }
 
53
 
 
54
 
 
55
  sub on_scope_end (&) {
 
56
    $^H |= 0x020000;
 
57
 
 
58
    if( my $stack = tied( %^H ) ) {
 
59
      if ( (my $c = ref $stack) ne 'namespace::clean::_TieHintHash') {
 
60
        die <<EOE;
 
61
========================================================================
 
62
               !!!   F A T A L   E R R O R   !!!
 
63
 
 
64
                 foreign tie() of %^H detected
 
65
========================================================================
 
66
 
 
67
namespace::clean is currently operating in pure-perl fallback mode, because
 
68
your system is lacking the necessary dependency B::Hooks::EndOfScope $b_h_eos_req.
 
69
In this mode namespace::clean expects to be able to tie() the hinthash %^H,
 
70
however it is apparently already tied by means unknown to the tie-class
 
71
$c
 
72
 
 
73
Since this is a no-win situation execution will abort here and now. Please
 
74
try to find out which other module is relying on hinthash tie() ability,
 
75
and file a bug for both the perpetrator and namespace::clean, so that the
 
76
authors can figure out an acceptable way of moving forward.
 
77
 
 
78
EOE
 
79
      }
 
80
      push @$stack, namespace::clean::_ScopeGuard->arm(shift);
91
81
    }
92
82
    else {
93
 
 
94
 
        # calling class, all current functions and our storage
95
 
        my $functions = $pragma->get_functions($cleanee);
96
 
        my $store     = $pragma->get_class_store($cleanee);
97
 
        my $stash     = Package::Stash->new($cleanee);
98
 
 
99
 
        # except parameter can be array ref or single value
100
 
        my %except = map {( $_ => 1 )} (
101
 
            $args{ -except }
102
 
            ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
103
 
            : ()
104
 
        );
105
 
 
106
 
        # register symbols for removal, if they have a CODE entry
107
 
        for my $f (keys %$functions) {
108
 
            next if     $except{ $f };
109
 
            next unless $stash->has_symbol("&$f");
110
 
            $store->{remove}{ $f } = 1;
111
 
        }
112
 
 
113
 
        # register EOF handler on first call to import
114
 
        unless ($store->{handler_is_installed}) {
115
 
            on_scope_end {
116
 
                $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
117
 
            };
118
 
            $store->{handler_is_installed} = 1;
119
 
        }
120
 
 
121
 
        return 1;
122
 
    }
123
 
}
124
 
 
125
 
 
126
 
sub unimport {
127
 
    my ($pragma, %args) = @_;
128
 
 
129
 
    # the calling class, the current functions and our storage
130
 
    my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
131
 
    my $functions = $pragma->get_functions($cleanee);
132
 
    my $store     = $pragma->get_class_store($cleanee);
133
 
 
134
 
    # register all unknown previous functions as excluded
135
 
    for my $f (keys %$functions) {
136
 
        next if $store->{remove}{ $f }
137
 
             or $store->{exclude}{ $f };
138
 
        $store->{exclude}{ $f } = 1;
139
 
    }
140
 
 
141
 
    return 1;
142
 
}
143
 
 
144
 
 
145
 
sub get_class_store {
146
 
    my ($pragma, $class) = @_;
147
 
    my $stash = Package::Stash->new($class);
148
 
    my $var = "%$STORAGE_VAR";
149
 
    $stash->add_symbol($var, {})
150
 
        unless $stash->has_symbol($var);
151
 
    return $stash->get_symbol($var);
152
 
}
153
 
 
154
 
 
155
 
sub get_functions {
156
 
    my ($pragma, $class) = @_;
157
 
 
158
 
    my $stash = Package::Stash->new($class);
159
 
    return {
160
 
        map { $_ => $stash->get_symbol("&$_") }
161
 
            $stash->list_all_symbols('CODE')
162
 
    };
163
 
}
164
 
 
165
 
 
166
 
no warnings;
167
 
'Danger! Laws of Thermodynamics may not apply.'
168
 
 
169
 
__END__
170
 
=pod
171
 
 
172
 
=encoding utf-8
 
83
      tie( %^H, 'namespace::clean::_TieHintHash', namespace::clean::_ScopeGuard->arm(shift) );
 
84
    }
 
85
  }
 
86
 
 
87
  1;
 
88
 
 
89
PP
 
90
 
 
91
  }
 
92
}
173
93
 
174
94
=head1 NAME
175
95
 
176
 
namespace::clean - Keep imports and functions out of your namespace
 
96
namespace::clean - keep imports and functions out of your namespace
177
97
 
178
98
=head1 SYNOPSIS
179
99
 
301
221
effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
302
222
it is your responsibility to make sure it runs at that time.
303
223
 
 
224
=cut
 
225
 
 
226
my $sub_utils_loaded;
 
227
my $DebuggerRename = sub {
 
228
  my ($f, $sub, $cleanee_stash, $deleted_stash) = @_;
 
229
 
 
230
  if (! defined $sub_utils_loaded ) {
 
231
    $sub_utils_loaded = do {
 
232
      my $sn_ver = 0.04;
 
233
      eval { require Sub::Name; Sub::Name->VERSION($sn_ver) }
 
234
        or die "Sub::Name $sn_ver required when running under -d or equivalent: $@";
 
235
 
 
236
      my $si_ver = 0.04;
 
237
      eval { require Sub::Identify; Sub::Identify->VERSION($si_ver) }
 
238
        or die "Sub::Identify $si_ver required when running under -d or equivalent: $@";
 
239
 
 
240
      1;
 
241
    } ? 1 : 0;
 
242
  }
 
243
 
 
244
  if ( Sub::Identify::sub_fullname($sub) eq ($cleanee_stash->name . "::$f") ) {
 
245
    my $new_fq = $deleted_stash->name . "::$f";
 
246
    Sub::Name::subname($new_fq, $sub);
 
247
    $deleted_stash->add_symbol("&$f", $sub);
 
248
  }
 
249
};
 
250
 
 
251
my $RemoveSubs = sub {
 
252
    my $cleanee = shift;
 
253
    my $store   = shift;
 
254
    my $cleanee_stash = Package::Stash->new($cleanee);
 
255
    my $deleted_stash;
 
256
 
 
257
  SYMBOL:
 
258
    for my $f (@_) {
 
259
 
 
260
        # ignore already removed symbols
 
261
        next SYMBOL if $store->{exclude}{ $f };
 
262
 
 
263
        my $sub = $cleanee_stash->get_symbol("&$f")
 
264
          or next SYMBOL;
 
265
 
 
266
        if ($^P and ref(\$cleanee_stash->namespace->{$f}) eq 'GLOB') {
 
267
            # convince the Perl debugger to work
 
268
            # it assumes that sub_fullname($sub) can always be used to find the CV again
 
269
            # since we are deleting the glob where the subroutine was originally
 
270
            # defined, that assumption no longer holds, so we need to move it
 
271
            # elsewhere and point the CV's name to the new glob.
 
272
            $DebuggerRename->(
 
273
              $f,
 
274
              $sub,
 
275
              $cleanee_stash,
 
276
              $deleted_stash ||= Package::Stash->new("namespace::clean::deleted::$cleanee"),
 
277
            );
 
278
        }
 
279
 
 
280
        my @symbols = map {
 
281
            my $name = $_ . $f;
 
282
            my $def = $cleanee_stash->get_symbol($name);
 
283
            defined($def) ? [$name, $def] : ()
 
284
        } '$', '@', '%', '';
 
285
 
 
286
        $cleanee_stash->remove_glob($f);
 
287
 
 
288
        $cleanee_stash->add_symbol(@$_) for @symbols;
 
289
    }
 
290
};
 
291
 
 
292
sub clean_subroutines {
 
293
    my ($nc, $cleanee, @subs) = @_;
 
294
    $RemoveSubs->($cleanee, {}, @subs);
 
295
}
 
296
 
304
297
=head2 import
305
298
 
306
299
Makes a snapshot of the current defined functions and installs a
307
300
L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
308
301
 
 
302
=cut
 
303
 
 
304
sub import {
 
305
    my ($pragma, @args) = @_;
 
306
 
 
307
    my (%args, $is_explicit);
 
308
 
 
309
  ARG:
 
310
    while (@args) {
 
311
 
 
312
        if ($args[0] =~ /^\-/) {
 
313
            my $key = shift @args;
 
314
            my $value = shift @args;
 
315
            $args{ $key } = $value;
 
316
        }
 
317
        else {
 
318
            $is_explicit++;
 
319
            last ARG;
 
320
        }
 
321
    }
 
322
 
 
323
    my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 
324
    if ($is_explicit) {
 
325
        on_scope_end {
 
326
            $RemoveSubs->($cleanee, {}, @args);
 
327
        };
 
328
    }
 
329
    else {
 
330
 
 
331
        # calling class, all current functions and our storage
 
332
        my $functions = $pragma->get_functions($cleanee);
 
333
        my $store     = $pragma->get_class_store($cleanee);
 
334
        my $stash     = Package::Stash->new($cleanee);
 
335
 
 
336
        # except parameter can be array ref or single value
 
337
        my %except = map {( $_ => 1 )} (
 
338
            $args{ -except }
 
339
            ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
 
340
            : ()
 
341
        );
 
342
 
 
343
        # register symbols for removal, if they have a CODE entry
 
344
        for my $f (keys %$functions) {
 
345
            next if     $except{ $f };
 
346
            next unless $stash->has_symbol("&$f");
 
347
            $store->{remove}{ $f } = 1;
 
348
        }
 
349
 
 
350
        # register EOF handler on first call to import
 
351
        unless ($store->{handler_is_installed}) {
 
352
            on_scope_end {
 
353
                $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
 
354
            };
 
355
            $store->{handler_is_installed} = 1;
 
356
        }
 
357
 
 
358
        return 1;
 
359
    }
 
360
}
 
361
 
309
362
=head2 unimport
310
363
 
311
364
This method will be called when you do a
314
367
 
315
368
It will start a new section of code that defines functions to clean up.
316
369
 
 
370
=cut
 
371
 
 
372
sub unimport {
 
373
    my ($pragma, %args) = @_;
 
374
 
 
375
    # the calling class, the current functions and our storage
 
376
    my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 
377
    my $functions = $pragma->get_functions($cleanee);
 
378
    my $store     = $pragma->get_class_store($cleanee);
 
379
 
 
380
    # register all unknown previous functions as excluded
 
381
    for my $f (keys %$functions) {
 
382
        next if $store->{remove}{ $f }
 
383
             or $store->{exclude}{ $f };
 
384
        $store->{exclude}{ $f } = 1;
 
385
    }
 
386
 
 
387
    return 1;
 
388
}
 
389
 
317
390
=head2 get_class_store
318
391
 
319
392
This returns a reference to a hash in a passed package containing
320
393
information about function names included and excluded from removal.
321
394
 
 
395
=cut
 
396
 
 
397
sub get_class_store {
 
398
    my ($pragma, $class) = @_;
 
399
    my $stash = Package::Stash->new($class);
 
400
    my $var = "%$STORAGE_VAR";
 
401
    $stash->add_symbol($var, {})
 
402
        unless $stash->has_symbol($var);
 
403
    return $stash->get_symbol($var);
 
404
}
 
405
 
322
406
=head2 get_functions
323
407
 
324
408
Takes a class as argument and returns all currently defined functions
325
409
in it as a hash reference with the function name as key and a typeglob
326
410
reference to the symbol as value.
327
411
 
 
412
=cut
 
413
 
 
414
sub get_functions {
 
415
    my ($pragma, $class) = @_;
 
416
 
 
417
    my $stash = Package::Stash->new($class);
 
418
    return {
 
419
        map { $_ => $stash->get_symbol("&$_") }
 
420
            $stash->list_all_symbols('CODE')
 
421
    };
 
422
}
 
423
 
328
424
=head1 IMPLEMENTATION DETAILS
329
425
 
330
426
This module works through the effect that a
342
438
Just for completeness sake, if you want to remove the symbol completely,
343
439
use C<undef> instead.
344
440
 
 
441
=head1 CAVEATS
 
442
 
 
443
This module is fully functional in a pure-perl environment, where
 
444
L<B::Hooks::EndOfScope> (with the XS dependency L<Variable::Magic>), may
 
445
not be available. However in this case this module falls back to a
 
446
L<tie()|perlfunc/tie> of L<%^H|perlvar/%^H>  which may or may not interfere
 
447
with some crack you may be doing independently of namespace::clean.
 
448
 
 
449
If you want to ensure that your codebase is protected from this unlikely
 
450
clash, you need to explicitly depend on L<B::Hooks::EndOfScope>.
 
451
 
345
452
=head1 SEE ALSO
346
453
 
347
454
L<B::Hooks::EndOfScope>
352
459
 
353
460
=head1 AUTHORS
354
461
 
355
 
=over 4
 
462
=over
356
463
 
357
464
=item *
358
465
 
366
473
 
367
474
Jesse Luehrs <doy@tozt.net>
368
475
 
 
476
=item *
 
477
 
 
478
Peter Rabbitson <ribasushi@cpan.org>
 
479
 
369
480
=back
370
481
 
371
482
=head1 COPYRIGHT AND LICENSE
372
483
 
373
484
This software is copyright (c) 2011 by Robert 'phaylon' Sedlacek.
374
485
 
375
 
This is free software; you can redistribute it and/or modify it under
376
 
the same terms as the Perl 5 programming language system itself.
 
486
This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself.
377
487
 
378
488
=cut
379
489
 
 
490
no warnings;
 
491
'Danger! Laws of Thermodynamics may not apply.'