local-lib5/lib/perl5/MRO/Compat.pm

   1 package MRO::Compat;
   2 use strict;
   3 use warnings;
   4 require 5.006_000;
   5
   6 # Keep this < 1.00, so people can tell the fake
   7 #  mro.pm from the real one
   8 our $VERSION = '0.11';
   9
  10 BEGIN {
  11     # Alias our private functions over to
  12     # the mro:: namespace and load
  13     # Class::C3 if Perl < 5.9.5
  14     if($] < 5.009_005) {
  15         $mro::VERSION # to fool Module::Install when generating META.yml
  16             = $VERSION;
  17         $INC{'mro.pm'} = __FILE__;
  18         *mro::import            = \&__import;
  19         *mro::get_linear_isa    = \&__get_linear_isa;
  20         *mro::set_mro           = \&__set_mro;
  21         *mro::get_mro           = \&__get_mro;
  22         *mro::get_isarev        = \&__get_isarev;
  23         *mro::is_universal      = \&__is_universal;
  24         *mro::method_changed_in = \&__method_changed_in;
  25         *mro::invalidate_all_method_caches
  26                                 = \&__invalidate_all_method_caches;
  27         require Class::C3;
  28         if($Class::C3::XS::VERSION && $Class::C3::XS::VERSION > 0.03) {
  29             *mro::get_pkg_gen   = \&__get_pkg_gen_c3xs;
  30         }
  31         else {
  32             *mro::get_pkg_gen   = \&__get_pkg_gen_pp;
  33         }
  34     }
  35
  36     # Load mro.pm and provide no-op Class::C3::.*initialize() funcs for 5.9.5+
  37     else {
  38         require mro;
  39         no warnings 'redefine';
  40         *Class::C3::initialize = sub { 1 };
  41         *Class::C3::reinitialize = sub { 1 };
  42         *Class::C3::uninitialize = sub { 1 };
  43     }
  44 }
  45
  46 =head1 NAME
  47
  48 MRO::Compat - mro::* interface compatibility for Perls < 5.9.5
  49
  50 =head1 SYNOPSIS
  51
  52    package FooClass; use base qw/X Y Z/;
  53    package X;        use base qw/ZZZ/;
  54    package Y;        use base qw/ZZZ/;
  55    package Z;        use base qw/ZZZ/;
  56
  57    package main;
  58    use MRO::Compat;
  59    my $linear = mro::get_linear_isa('FooClass');
  60    print join(q{, }, @$linear);
  61
  62    # Prints: "FooClass, X, ZZZ, Y, Z"
  63
  64 =head1 DESCRIPTION
  65
  66 The "mro" namespace provides several utilities for dealing
  67 with method resolution order and method caching in general
  68 in Perl 5.9.5 and higher.
  69
  70 This module provides those interfaces for
  71 earlier versions of Perl (back to 5.6.0 anyways).
  72
  73 It is a harmless no-op to use this module on 5.9.5+.  That
  74 is to say, code which properly uses L<MRO::Compat> will work
  75 unmodified on both older Perls and 5.9.5+.
  76
  77 If you're writing a piece of software that would like to use
  78 the parts of 5.9.5+'s mro:: interfaces that are supported
  79 here, and you want compatibility with older Perls, this
  80 is the module for you.
  81
  82 Some parts of this code will work better and/or faster with
  83 L<Class::C3::XS> installed (which is an optional prereq
  84 of L<Class::C3>, which is in turn a prereq of this
  85 package), but it's not a requirement.
  86
  87 This module never exports any functions.  All calls must
  88 be fully qualified with the C<mro::> prefix.
  89
  90 The interface documentation here serves only as a quick
  91 reference of what the function basically does, and what
  92 differences between L<MRO::Compat> and 5.9.5+ one should
  93 look out for.  The main docs in 5.9.5's L<mro> are the real
  94 interface docs, and contain a lot of other useful information.
  95
  96 =head1 Functions
  97
  98 =head2 mro::get_linear_isa($classname[, $type])
  99
 100 Returns an arrayref which is the linearized "ISA" of the given class.
 101 Uses whichever MRO is currently in effect for that class by default,
 102 or the given MRO (either C<c3> or C<dfs> if specified as C<$type>).
 103
 104 The linearized ISA of a class is a single ordered list of all of the
 105 classes that would be visited in the process of resolving a method
 106 on the given class, starting with itself.  It does not include any
 107 duplicate entries.
 108
 109 Note that C<UNIVERSAL> (and any members of C<UNIVERSAL>'s MRO) are not
 110 part of the MRO of a class, even though all classes implicitly inherit
 111 methods from C<UNIVERSAL> and its parents.
 112
 113 =cut
 114
 115 sub __get_linear_isa_dfs {
 116     no strict 'refs';
 117
 118     my $classname = shift;
 119
 120     my @lin = ($classname);
 121     my %stored;
 122     foreach my $parent (@{"$classname\::ISA"}) {
 123         my $plin = __get_linear_isa_dfs($parent);
 124         foreach (@$plin) {
 125             next if exists $stored{$_};
 126             push(@lin, $_);
 127             $stored{$_} = 1;
 128         }
 129     }
 130     return \@lin;
 131 }
 132
 133 sub __get_linear_isa {
 134     my ($classname, $type) = @_;
 135     die "mro::get_mro requires a classname" if !defined $classname;
 136
 137     $type ||= __get_mro($classname);
 138     if($type eq 'dfs') {
 139         return __get_linear_isa_dfs($classname);
 140     }
 141     elsif($type eq 'c3') {
 142         return [Class::C3::calculateMRO($classname)];
 143     }
 144     die "type argument must be 'dfs' or 'c3'";
 145 }
 146
 147 =head2 mro::import
 148
 149 This allows the C<use mro 'dfs'> and
 150 C<use mro 'c3'> syntaxes, providing you
 151 L<use MRO::Compat> first.  Please see the
 152 L</USING C3> section for additional details.
 153
 154 =cut
 155
 156 sub __import {
 157     if($_[1]) {
 158         goto &Class::C3::import if $_[1] eq 'c3';
 159         __set_mro(scalar(caller), $_[1]);
 160     }
 161 }
 162
 163 =head2 mro::set_mro($classname, $type)
 164
 165 Sets the mro of C<$classname> to one of the types
 166 C<dfs> or C<c3>.  Please see the L</USING C3>
 167 section for additional details.
 168
 169 =cut
 170
 171 sub __set_mro {
 172     my ($classname, $type) = @_;
 173
 174     if(!defined $classname || !$type) {
 175         die q{Usage: mro::set_mro($classname, $type)};
 176     }
 177
 178     if($type eq 'c3') {
 179         eval "package $classname; use Class::C3";
 180         die $@ if $@;
 181     }
 182     elsif($type eq 'dfs') {
 183         # In the dfs case, check whether we need to undo C3
 184         if(defined $Class::C3::MRO{$classname}) {
 185             Class::C3::_remove_method_dispatch_table($classname);
 186         }
 187         delete $Class::C3::MRO{$classname};
 188     }
 189     else {
 190         die qq{Invalid mro type "$type"};
 191     }
 192
 193     return;
 194 }
 195
 196 =head2 mro::get_mro($classname)
 197
 198 Returns the MRO of the given class (either C<c3> or C<dfs>).
 199
 200 It considers any Class::C3-using class to have C3 MRO
 201 even before L<Class::C3::initialize()> is called.
 202
 203 =cut
 204
 205 sub __get_mro {
 206     my $classname = shift;
 207     die "mro::get_mro requires a classname" if !defined $classname;
 208     return 'c3' if exists $Class::C3::MRO{$classname};
 209     return 'dfs';
 210 }
 211
 212 =head2 mro::get_isarev($classname)
 213
 214 Returns an arrayref of classes who are subclasses of the
 215 given classname.  In other words, classes in whose @ISA
 216 hierarchy we appear, no matter how indirectly.
 217
 218 This is much slower on pre-5.9.5 Perls with MRO::Compat
 219 than it is on 5.9.5+, as it has to search the entire
 220 package namespace.
 221
 222 =cut
 223
 224 sub __get_all_pkgs_with_isas {
 225     no strict 'refs';
 226     no warnings 'recursion';
 227
 228     my @retval;
 229
 230     my $search = shift;
 231     my $pfx;
 232     my $isa;
 233     if(defined $search) {
 234         $isa = \@{"$search\::ISA"};
 235         $pfx = "$search\::";
 236     }
 237     else {
 238         $search = 'main';
 239         $isa = \@main::ISA;
 240         $pfx = '';
 241     }
 242
 243     push(@retval, $search) if scalar(@$isa);
 244
 245     foreach my $cand (keys %{"$search\::"}) {
 246         if($cand =~ s/::$//) {
 247             next if $cand eq $search; # skip self-reference (main?)
 248             push(@retval, @{__get_all_pkgs_with_isas($pfx . $cand)});
 249         }
 250     }
 251
 252     return \@retval;
 253 }
 254
 255 sub __get_isarev_recurse {
 256     no strict 'refs';
 257
 258     my ($class, $all_isas, $level) = @_;
 259
 260     die "Recursive inheritance detected" if $level > 100;
 261
 262     my %retval;
 263
 264     foreach my $cand (@$all_isas) {
 265         my $found_me;
 266         foreach (@{"$cand\::ISA"}) {
 267             if($_ eq $class) {
 268                 $found_me = 1;
 269                 last;
 270             }
 271         }
 272         if($found_me) {
 273             $retval{$cand} = 1;
 274             map { $retval{$_} = 1 }
 275                 @{__get_isarev_recurse($cand, $all_isas, $level+1)};
 276         }
 277     }
 278     return [keys %retval];
 279 }
 280
 281 sub __get_isarev {
 282     my $classname = shift;
 283     die "mro::get_isarev requires a classname" if !defined $classname;
 284
 285     __get_isarev_recurse($classname, __get_all_pkgs_with_isas(), 0);
 286 }
 287
 288 =head2 mro::is_universal($classname)
 289
 290 Returns a boolean status indicating whether or not
 291 the given classname is either C<UNIVERSAL> itself,
 292 or one of C<UNIVERSAL>'s parents by C<@ISA> inheritance.
 293
 294 Any class for which this function returns true is
 295 "universal" in the sense that all classes potentially
 296 inherit methods from it.
 297
 298 =cut
 299
 300 sub __is_universal {
 301     my $classname = shift;
 302     die "mro::is_universal requires a classname" if !defined $classname;
 303
 304     my $lin = __get_linear_isa('UNIVERSAL');
 305     foreach (@$lin) {
 306         return 1 if $classname eq $_;
 307     }
 308
 309     return 0;
 310 }
 311
 312 =head2 mro::invalidate_all_method_caches
 313
 314 Increments C<PL_sub_generation>, which invalidates method
 315 caching in all packages.
 316
 317 Please note that this is rarely necessary, unless you are
 318 dealing with a situation which is known to confuse Perl's
 319 method caching.
 320
 321 =cut
 322
 323 sub __invalidate_all_method_caches {
 324     # Super secret mystery code :)
 325     @f845a9c1ac41be33::ISA = @f845a9c1ac41be33::ISA;
 326     return;
 327 }
 328
 329 =head2 mro::method_changed_in($classname)
 330
 331 Invalidates the method cache of any classes dependent on the
 332 given class.  In L<MRO::Compat> on pre-5.9.5 Perls, this is
 333 an alias for C<mro::invalidate_all_method_caches> above, as
 334 pre-5.9.5 Perls have no other way to do this.  It will still
 335 enforce the requirement that you pass it a classname, for
 336 compatibility.
 337
 338 Please note that this is rarely necessary, unless you are
 339 dealing with a situation which is known to confuse Perl's
 340 method caching.
 341
 342 =cut
 343
 344 sub __method_changed_in {
 345     my $classname = shift;
 346     die "mro::method_changed_in requires a classname" if !defined $classname;
 347
 348     __invalidate_all_method_caches();
 349 }
 350
 351 =head2 mro::get_pkg_gen($classname)
 352
 353 Returns an integer which is incremented every time a local
 354 method of or the C<@ISA> of the given package changes on
 355 Perl 5.9.5+.  On earlier Perls with this L<MRO::Compat> module,
 356 it will probably increment a lot more often than necessary.
 357
 358 =cut
 359
 360 {
 361     my $__pkg_gen = 2;
 362     sub __get_pkg_gen_pp {
 363         my $classname = shift;
 364         die "mro::get_pkg_gen requires a classname" if !defined $classname;
 365         return $__pkg_gen++;
 366     }
 367 }
 368
 369 sub __get_pkg_gen_c3xs {
 370     my $classname = shift;
 371     die "mro::get_pkg_gen requires a classname" if !defined $classname;
 372
 373     return Class::C3::XS::_plsubgen();
 374 }
 375
 376 =head1 USING C3
 377
 378 While this module makes the 5.9.5+ syntaxes
 379 C<use mro 'c3'> and C<mro::set_mro("Foo", 'c3')> available
 380 on older Perls, it does so merely by passing off the work
 381 to L<Class::C3>.
 382
 383 It does not remove the need for you to call
 384 C<Class::C3::initialize()>, C<Class::C3::reinitialize()>, and/or
 385 C<Class::C3::uninitialize()> at the appropriate times
 386 as documented in the L<Class::C3> docs.  These three functions
 387 are always provided by L<MRO::Compat>, either via L<Class::C3>
 388 itself on older Perls, or directly as no-ops on 5.9.5+.
 389
 390 =head1 SEE ALSO
 391
 392 L<Class::C3>
 393
 394 L<mro>
 395
 396 =head1 AUTHOR
 397
 398 Brandon L. Black, E<lt>blblack@gmail.comE<gt>
 399
 400 =head1 COPYRIGHT AND LICENSE
 401
 402 Copyright 2007-2008 Brandon L. Black E<lt>blblack@gmail.comE<gt>
 403
 404 This library is free software; you can redistribute it and/or modify
 405 it under the same terms as Perl itself.
 406
 407 =cut
 408
 409 1;