local-lib5/lib/perl5/Class/C3/Adopt/NEXT.pm

   1 use strict;
   2 use warnings;
   3
   4 package Class::C3::Adopt::NEXT;
   5
   6 use NEXT;
   7 use MRO::Compat;
   8 use List::MoreUtils qw/none/;
   9 use warnings::register;
  10
  11 our $VERSION = '0.12';
  12
  13 {
  14     my %c3_mro_ok;
  15     my %warned_for;
  16     my @no_warn_regexes;
  17
  18     {
  19         my $orig = NEXT->can('AUTOLOAD');
  20
  21         no warnings 'redefine';
  22         *NEXT::AUTOLOAD = sub {
  23             my $class = ref $_[0] || $_[0];
  24             my $caller = caller();
  25
  26             # 'NEXT::AUTOLOAD' is cargo-culted from C::P::C3, I have no idea if/why it's needed
  27             my $wanted = our $AUTOLOAD || 'NEXT::AUTOLOAD';
  28             my ($wanted_class) = $wanted =~ m{(.*)::};
  29
  30             unless (exists $c3_mro_ok{$class}) {
  31                 eval { mro::get_linear_isa($class, 'c3') };
  32                 if (my $error = $@) {
  33                     warn "Class::C3::calculateMRO('${class}') Error: '${error}';"
  34                     . ' Falling back to plain NEXT.pm behaviour for this class';
  35                     $c3_mro_ok{$class} = 0;
  36                 }
  37                 else {
  38                     $c3_mro_ok{$class} = 1;
  39                 }
  40             }
  41
  42             if (length $c3_mro_ok{$class} && $c3_mro_ok{$class}) {
  43                 unless ($warned_for{$caller}) {
  44                     $warned_for{$caller} = 1;
  45                     if (!@no_warn_regexes || none { $caller =~ $_ } @no_warn_regexes) {
  46                         warnings::warnif("${caller} uses NEXT, which is deprecated. Please see "
  47                             . "the Class::C3::Adopt::NEXT documentation for details. NEXT used ");
  48                     }
  49                 }
  50             }
  51
  52             unless ($c3_mro_ok{$class}) {
  53                 $NEXT::AUTOLOAD = $wanted;
  54                 goto &$orig;
  55             }
  56
  57             goto &next::method if $wanted_class =~ /^NEXT:.*:ACTUAL/;
  58             goto &maybe::next::method;
  59         };
  60
  61         *NEXT::ACTUAL::AUTOLOAD = \&NEXT::AUTOLOAD;
  62     }
  63
  64     sub import {
  65         my ($class, @args) = @_;
  66         my $target = caller();
  67
  68         for my $arg (@args) {
  69             $warned_for{$target} = 1
  70                 if $arg eq '-no_warn';
  71         }
  72     }
  73
  74     sub unimport {
  75         my $class = shift;
  76         my @strings = grep { !ref $_ || ref($_) ne 'Regexp' } @_;
  77         my @regexes = grep { ref($_) && ref($_) eq 'Regexp' } @_;
  78         @c3_mro_ok{@strings} = ('') x @strings;
  79         push @no_warn_regexes, @regexes;
  80     }
  81 }
  82
  83 1;
  84
  85 __END__
  86
  87 =head1 NAME
  88
  89 Class::C3::Adopt::NEXT - make NEXT suck less
  90
  91 =head1 SYNOPSIS
  92
  93     package MyApp::Plugin::FooBar;
  94     #use NEXT;
  95     use Class::C3::Adopt::NEXT;
  96     # or 'use Class::C3::Adopt::NEXT -no_warn;' to suppress warnings
  97
  98     # Or use warnings::register
  99     # no warnings 'Class::C3::Adopt::NEXT';
 100
 101     # Or suppress warnings in a set of modules from one place
 102     # no Class::C3::Adopt::NEXT qw/ Module1 Module2 Module3 /;
 103     # Or suppress using a regex
 104     # no Class::C3::Adopt::NEXT qr/^Module\d$/;
 105
 106     sub a_method {
 107         my ($self) = @_;
 108         # Do some stuff
 109
 110         # Re-dispatch method
 111         # Note that this will generate a warning the _first_ time the package
 112         # uses NEXT unless you un comment the 'no warnings' line above.
 113         $self->NEXT::method();
 114     }
 115
 116 =head1 DESCRIPTION
 117
 118 L<NEXT> was a good solution a few years ago, but isn't any more.  It's slow,
 119 and the order in which it re-dispatches methods appears random at times. It
 120 also encourages bad programming practices, as you end up with code to
 121 re-dispatch methods when all you really wanted to do was run some code before
 122 or after a method fired.
 123
 124 However, if you have a large application, then weaning yourself off C<NEXT>
 125 isn't easy.
 126
 127 This module is intended as a drop-in replacement for NEXT, supporting the same
 128 interface, but using L<Class::C3> to do the hard work. You can then write new
 129 code without C<NEXT>, and migrate individual source files to use C<Class::C3>
 130 or method modifiers as appropriate, at whatever pace you're comfortable with.
 131
 132 =head1 WARNINGS
 133
 134 This module will warn once for each package using NEXT. It uses
 135 L<warnings::register>, and so can be disabled like by adding C<no warnings
 136 'Class::C3::Adopt::NEXT';> to each package which generates a warning, or adding
 137 C<use Class::C3::Adopt::NEXT -no_warn;>, or disable multiple modules at once by
 138 saying:
 139
 140     no Class::C3::Adopt::NEXT qw/ Module1 Module2 Module3 /;
 141
 142 somewhere before the warnings are first triggered. You can also setup entire
 143 name spaces of modules which will not warn using a regex, e.g.
 144
 145     no Class::C3::Adopt::NEXT qr/^Module\d$/;
 146
 147 =head1 MIGRATING
 148
 149 =head2 Current code using NEXT
 150
 151 You add C<use MRO::Compat> to the top of a package as you start converting it,
 152 and gradually replace your calls to C<NEXT::method()> with
 153 C<maybe::next::method()>, and calls to C<NEXT::ACTUAL::method()> with
 154 C<next::method()>.
 155
 156 Example:
 157
 158     sub yourmethod {
 159         my $self = shift;
 160
 161         # $self->NEXT::yourmethod(@_); becomes
 162         $self->maybe::next::method();
 163     }
 164
 165     sub othermethod {
 166         my $self = shift;
 167
 168         # $self->NEXT::ACTUAL::yourmethodname(); becomes
 169         $self->next::method();
 170     }
 171
 172 On systems with L<Class::C3::XS> present, this will automatically be used to
 173 speed up method re-dispatch. If you are running perl version 5.9.5 or greater
 174 then the C3 method resolution algorithm is included in perl. Correct use of
 175 L<MRO::Compat> as shown above allows your code to be seamlessly forward and
 176 backwards compatible, taking advantage of native versions if available, but
 177 falling back to using pure perl C<Class::C3>.
 178
 179 =head2 Writing new code
 180
 181 Use L<Moose> and make all of your plugins L<Moose::Roles|Moose::Role>, then use
 182 method modifiers to wrap methods.
 183
 184 Example:
 185
 186     package MyApp::Role::FooBar;
 187     use Moose::Role;
 188
 189     before 'a_method' => sub {
 190         my ($self) = @_;
 191         # Do some stuff
 192     };
 193
 194     around 'a_method' => sub {
 195         my $orig = shift;
 196         my $self = shift;
 197         # Do some stuff before
 198         my $ret = $self->$orig(@_); # Run wrapped method (or not!)
 199         # Do some stuff after
 200         return $ret;
 201     };
 202
 203     package MyApp;
 204     use Moose;
 205
 206     with 'MyApp::Role::FooBar';
 207
 208 =head1 CAVEATS
 209
 210 There are some inheritance hierarchies that it is possible to create which
 211 cannot be resolved to a simple C3 hierarchy. In that case, this module will
 212 fall back to using C<NEXT>. In this case a warning will be emitted.
 213
 214 Because calculating the MRO of every class every time C<< ->NEXT::foo >> is
 215 used from within it is too expensive, runtime manipulations of C<@ISA> are
 216 prohibited.
 217
 218 =head1 FUNCTIONS
 219
 220 This module replaces C<NEXT::AUTOLOAD> with it's own version. If warnings are
 221 enabled then a warning will be emitted on the first use of C<NEXT> by each
 222 package.
 223
 224 =head1 SEE ALSO
 225
 226 L<MRO::Compat> and L<Class::C3> for method re-dispatch and L<Moose> for method
 227 modifiers and L<roles|Moose::Role>.
 228
 229 L<NEXT> for documentation on the functionality you'll be removing.
 230
 231 =head1 AUTHORS
 232
 233 Florian Ragwitz C<rafl@debian.org>
 234
 235 Tomas Doran C<bobtfish@bobtfish.net>
 236
 237 =head1 COPYRIGHT AND LICENSE
 238
 239 Copyright (c) 2008, 2009  Florian Ragwitz
 240
 241 You may distribute this code under the same terms as Perl itself.
 242
 243 =cut