← Back to branch summary

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

« back to all changes in this revision

Viewing changes to .pc/fix-pod-spelling.patch/lib/namespace/clean.pm

  • Committer: Bazaar Package Importer
  • Author(s): gregor herrmann, Ansgar Burchardt, gregor herrmann
  • Date: 2010-06-13 14:20:13 UTC
  • mfrom: (1.1.6 upstream)
  • Revision ID: james.westby@ubuntu.com-20100613142013-5pl6g9bsrbqu57oj
Tags: 0.17-1
[ Ansgar Burchardt ]
* New upstream release.
* debian/copyright: Remove information on inc/* (removed upstream).
* Add (build-)dep on libpackage-stash-perl.
* Add myself to Uploaders.

[ gregor herrmann ]
* Refresh fix-pod-spelling.patch.
* debian/copyright: update upstream copyright year.

Show diffs side-by-side

added added

removed removed

Lines of Context:
.pc/fix-pod-spelling.patch/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.17';
 
7
}
 
8
# ABSTRACT: Keep imports and functions out of your namespace
 
9
 
 
10
use warnings;
 
11
use strict;
 
12
 
 
13
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.03;
 
17
use B::Hooks::EndOfScope 0.07;
 
18
 
 
19
$STORAGE_VAR = '__NAMESPACE_CLEAN_STORAGE';
 
20
 
 
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_package_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_package_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_package_symbol($variable, $sub);
 
47
            }
 
48
        }
 
49
 
 
50
        $cleanee_stash->remove_package_symbol($variable);
 
51
    }
 
52
};
 
53
 
 
54
sub clean_subroutines {
 
55
    my ($nc, $cleanee, @subs) = @_;
 
56
    $RemoveSubs->($cleanee, {}, @subs);
 
57
}
 
58
 
 
59
 
 
60
sub import {
 
61
    my ($pragma, @args) = @_;
 
62
 
 
63
    my (%args, $is_explicit);
 
64
 
 
65
  ARG:
 
66
    while (@args) {
 
67
 
 
68
        if ($args[0] =~ /^\-/) {
 
69
            my $key = shift @args;
 
70
            my $value = shift @args;
 
71
            $args{ $key } = $value;
 
72
        }
 
73
        else {
 
74
            $is_explicit++;
 
75
            last ARG;
 
76
        }
 
77
    }
 
78
 
 
79
    my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 
80
    if ($is_explicit) {
 
81
        on_scope_end {
 
82
            $RemoveSubs->($cleanee, {}, @args);
 
83
        };
 
84
    }
 
85
    else {
 
86
 
 
87
        # calling class, all current functions and our storage
 
88
        my $functions = $pragma->get_functions($cleanee);
 
89
        my $store     = $pragma->get_class_store($cleanee);
 
90
        my $stash     = Package::Stash->new($cleanee);
 
91
 
 
92
        # except parameter can be array ref or single value
 
93
        my %except = map {( $_ => 1 )} (
 
94
            $args{ -except }
 
95
            ? ( ref $args{ -except } eq 'ARRAY' ? @{ $args{ -except } } : $args{ -except } )
 
96
            : ()
 
97
        );
 
98
 
 
99
        # register symbols for removal, if they have a CODE entry
 
100
        for my $f (keys %$functions) {
 
101
            next if     $except{ $f };
 
102
            next unless $stash->has_package_symbol("&$f");
 
103
            $store->{remove}{ $f } = 1;
 
104
        }
 
105
 
 
106
        # register EOF handler on first call to import
 
107
        unless ($store->{handler_is_installed}) {
 
108
            on_scope_end {
 
109
                $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
 
110
            };
 
111
            $store->{handler_is_installed} = 1;
 
112
        }
 
113
 
 
114
        return 1;
 
115
    }
 
116
}
 
117
 
 
118
 
 
119
sub unimport {
 
120
    my ($pragma, %args) = @_;
 
121
 
 
122
    # the calling class, the current functions and our storage
 
123
    my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
 
124
    my $functions = $pragma->get_functions($cleanee);
 
125
    my $store     = $pragma->get_class_store($cleanee);
 
126
 
 
127
    # register all unknown previous functions as excluded
 
128
    for my $f (keys %$functions) {
 
129
        next if $store->{remove}{ $f }
 
130
             or $store->{exclude}{ $f };
 
131
        $store->{exclude}{ $f } = 1;
 
132
    }
 
133
 
 
134
    return 1;
 
135
}
 
136
 
 
137
 
 
138
sub get_class_store {
 
139
    my ($pragma, $class) = @_;
 
140
    my $stash = Package::Stash->new($class);
 
141
    return $stash->get_package_symbol("%$STORAGE_VAR");
 
142
}
 
143
 
 
144
 
 
145
sub get_functions {
 
146
    my ($pragma, $class) = @_;
 
147
 
 
148
    my $stash = Package::Stash->new($class);
 
149
    return {
 
150
        map { $_ => $stash->get_package_symbol("&$_") }
 
151
            $stash->list_all_package_symbols('CODE')
 
152
    };
 
153
}
 
154
 
 
155
 
 
156
no warnings;
 
157
'Danger! Laws of Thermodynamics may not apply.'
 
158
 
 
159
__END__
 
160
=pod
 
161
 
 
162
=encoding utf-8
2
163
 
3
164
=head1 NAME
4
165
 
5
166
namespace::clean - Keep imports and functions out of your namespace
6
167
 
7
 
=cut
8
 
 
9
 
use warnings;
10
 
use strict;
11
 
 
12
 
use vars        qw( $VERSION $STORAGE_VAR $SCOPE_HOOK_KEY $SCOPE_EXPLICIT );
13
 
use Symbol      qw( qualify_to_ref gensym );
14
 
use B::Hooks::EndOfScope;
15
 
use Sub::Identify qw(sub_fullname);
16
 
use Sub::Name qw(subname);
17
 
 
18
 
=head1 VERSION
19
 
 
20
 
0.13
21
 
 
22
 
=cut
23
 
 
24
 
$VERSION         = '0.14';
25
 
$STORAGE_VAR     = '__NAMESPACE_CLEAN_STORAGE';
26
 
 
27
168
=head1 SYNOPSIS
28
169
 
29
170
  package Foo;
62
203
When you define a function, or import one, into a Perl package, it will
63
204
naturally also be available as a method. This does not per se cause
64
205
problems, but it can complicate subclassing and, for example, plugin
65
 
classes that are included via multiple inheritance by loading them as 
 
206
classes that are included via multiple inheritance by loading them as
66
207
base classes.
67
208
 
68
209
The C<namespace::clean> pragma will remove all previously declared or
139
280
 
140
281
=head1 METHODS
141
282
 
142
 
You shouldn't need to call any of these. Just C<use> the package at the
143
 
appropriate place.
144
 
 
145
 
=cut
146
 
 
147
283
=head2 clean_subroutines
148
284
 
149
285
This exposes the actual subroutine-removal logic.
155
291
effect at a specific time (e.g. C<namespace::clean> acts on scope compile end)
156
292
it is your responsibility to make sure it runs at that time.
157
293
 
158
 
=cut
159
 
 
160
 
my $RemoveSubs = sub {
161
 
 
162
 
    my $cleanee = shift;
163
 
    my $store   = shift;
164
 
  SYMBOL:
165
 
    for my $f (@_) {
166
 
        my $fq = "${cleanee}::$f";
167
 
 
168
 
        # ignore already removed symbols
169
 
        next SYMBOL if $store->{exclude}{ $f };
170
 
        no strict 'refs';
171
 
 
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
 
            }
203
 
        }
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.
208
 
            delete ${ "${cleanee}::" }{ $f };
209
 
        }
210
 
    }
211
 
};
212
 
 
213
 
sub clean_subroutines {
214
 
    my ($nc, $cleanee, @subs) = @_;
215
 
    $RemoveSubs->($cleanee, {}, @subs);
216
 
}
217
 
 
218
294
=head2 import
219
295
 
220
296
Makes a snapshot of the current defined functions and installs a
221
297
L<B::Hooks::EndOfScope> hook in the current scope to invoke the cleanups.
222
298
 
223
 
=cut
224
 
 
225
 
sub import {
226
 
    my ($pragma, @args) = @_;
227
 
 
228
 
    my (%args, $is_explicit);
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
 
        }
242
 
    }
243
 
 
244
 
    my $cleanee = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
245
 
    if ($is_explicit) {
246
 
        on_scope_end {
247
 
            $RemoveSubs->($cleanee, {}, @args);
248
 
        };
249
 
    }
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}) {
273
 
            on_scope_end {
274
 
                $RemoveSubs->($cleanee, $store, keys %{ $store->{remove} });
275
 
            };
276
 
            $store->{handler_is_installed} = 1;
277
 
        }
278
 
 
279
 
        return 1;
280
 
    }
281
 
}
282
 
 
283
299
=head2 unimport
284
300
 
285
301
This method will be called when you do a
288
304
 
289
305
It will start a new section of code that defines functions to clean up.
290
306
 
291
 
=cut
292
 
 
293
 
sub unimport {
294
 
    my ($pragma, %args) = @_;
295
 
 
296
 
    # the calling class, the current functions and our storage
297
 
    my $cleanee   = exists $args{ -cleanee } ? $args{ -cleanee } : scalar caller;
298
 
    my $functions = $pragma->get_functions($cleanee);
299
 
    my $store     = $pragma->get_class_store($cleanee);
300
 
 
301
 
    # register all unknown previous functions as excluded
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
307
=head2 get_class_store
312
308
 
313
 
This returns a reference to a hash in a passed package containing 
 
309
This returns a reference to a hash in a passed package containing
314
310
information about function names included and excluded from removal.
315
311
 
316
 
=cut
317
 
 
318
 
sub get_class_store {
319
 
    my ($pragma, $class) = @_;
320
 
    no strict 'refs';
321
 
    return \%{ "${class}::${STORAGE_VAR}" };
322
 
}
323
 
 
324
312
=head2 get_functions
325
313
 
326
314
Takes a class as argument and returns all currently defined functions
327
315
in it as a hash reference with the function name as key and a typeglob
328
316
reference to the symbol as value.
329
317
 
330
 
=cut
331
 
 
332
 
sub get_functions {
333
 
    my ($pragma, $class) = @_;
334
 
 
335
 
    return {
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
341
 
    };
342
 
}
343
 
 
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
 
 
350
318
=head1 IMPLEMENTATION DETAILS
351
319
 
352
 
This module works through the effect that a 
 
320
This module works through the effect that a
353
321
 
354
322
  delete $SomePackage::{foo};
355
323
 
368
336
 
369
337
L<B::Hooks::EndOfScope>
370
338
 
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.
 
339
=head1 THANKS
 
340
 
 
341
Many thanks to Matt S Trout for the inspiration on the whole idea.
 
342
 
 
343
=head1 AUTHORS
 
344
 
 
345
=over 4
 
346
 
 
347
=item *
 
348
 
 
349
Robert 'phaylon' Sedlacek <rs@474.at>
 
350
 
 
351
=item *
 
352
 
 
353
Florian Ragwitz <rafl@debian.org>
 
354
 
 
355
=item *
 
356
 
 
357
Jesse Luehrs <doy@tozt.net>
 
358
 
 
359
=back
 
360
 
 
361
=head1 COPYRIGHT AND LICENSE
 
362
 
 
363
This software is copyright (c) 2010 by Robert 'phaylon' Sedlacek.
 
364
 
 
365
This is free software; you can redistribute it and/or modify it under
 
366
the same terms as the Perl 5 programming language system itself.
380
367
 
381
368
=cut
382
369
 
383
 
no warnings;
384
 
'Danger! Laws of Thermodynamics may not apply.'