| File | /usr/local/share/perl/5.10.0/MRO/Compat.pm |
| Statements Executed | 32 |
| Total Time | 0.001787 seconds |
| Calls | P | F | Exclusive Time |
Inclusive Time |
Subroutine |
|---|---|---|---|---|---|
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::BEGIN |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__ANON__[:40] |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__ANON__[:41] |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__ANON__[:42] |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__get_all_pkgs_with_isas |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__get_isarev |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__get_isarev_recurse |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__get_linear_isa |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__get_linear_isa_dfs |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__get_mro |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__get_pkg_gen_c3xs |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__get_pkg_gen_pp |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__import |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__invalidate_all_method_caches |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__is_universal |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__method_changed_in |
| 0 | 0 | 0 | 0s | 0s | MRO::Compat::__set_mro |
| Line | Stmts. | Exclusive Time | Avg. | Code |
|---|---|---|---|---|
| 1 | package MRO::Compat; | |||
| 2 | 3 | 26µs | 9µs | use strict; # spent 7µs making 1 call to strict::import |
| 3 | 3 | 232µs | 77µs | use warnings; # spent 20µs making 1 call to warnings::import |
| 4 | 1 | 20µs | 20µs | require 5.006_000; |
| 5 | ||||
| 6 | # Keep this < 1.00, so people can tell the fake | |||
| 7 | # mro.pm from the real one | |||
| 8 | 1 | 600ns | 600ns | 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 | 1 | 2µs | 2µs | 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 | 1 | 89µs | 89µs | require mro; |
| 39 | 3 | 117µs | 39µs | no warnings 'redefine'; # spent 19µs making 1 call to warnings::unimport |
| 40 | 1 | 4µs | 4µs | *Class::C3::initialize = sub { 1 }; |
| 41 | 1 | 2µs | 2µs | *Class::C3::reinitialize = sub { 1 }; |
| 42 | 1 | 5µs | 5µs | *Class::C3::uninitialize = sub { 1 }; |
| 43 | } | |||
| 44 | 1 | 38µs | 38µs | } |
| 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 | 3 | 460µs | 153µs | no strict 'refs'; # spent 21µs making 1 call to strict::unimport |
| 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 | 3 | 28µs | 9µs | no strict 'refs'; # spent 21µs making 1 call to strict::unimport |
| 226 | 3 | 206µs | 69µs | no warnings 'recursion'; # spent 23µs making 1 call to warnings::unimport |
| 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 | 3 | 550µs | 183µs | no strict 'refs'; # spent 23µs making 1 call to strict::unimport |
| 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 | 2 | 1µs | 650ns | 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 | 6µs | 6µs | 1; |