lib/Mouse/Util.pm

   1 package Mouse::Util;
   2 use strict;
   3 use warnings;
   4 use base qw/Exporter/;
   5 use Carp qw(confess);
   6 use B ();
   7
   8 our @EXPORT_OK = qw(
   9     load_class
  10     is_class_loaded
  11     get_linear_isa
  12     apply_all_roles
  13     get_code_info
  14     not_supported
  15 );
  16 our %EXPORT_TAGS = (
  17     all  => \@EXPORT_OK,
  18 );
  19
  20 BEGIN {
  21     my $impl;
  22     if ($] >= 5.009_005) {
  23         require mro;
  24         $impl = \&mro::get_linear_isa;
  25     } else {
  26         my $e = do {
  27             local $@;
  28             eval { require MRO::Compat };
  29             $@;
  30         };
  31         if (!$e) {
  32             $impl = \&mro::get_linear_isa;
  33         } else {
  34 #       VVVVV   CODE TAKEN FROM MRO::COMPAT   VVVVV
  35             my $_get_linear_isa_dfs; # this recurses so it isn't pretty
  36             $_get_linear_isa_dfs = sub {
  37                 no strict 'refs';
  38
  39                 my $classname = shift;
  40
  41                 my @lin = ($classname);
  42                 my %stored;
  43                 foreach my $parent (@{"$classname\::ISA"}) {
  44                     my $plin = $_get_linear_isa_dfs->($parent);
  45                     foreach  my $p(@$plin) {
  46                         next if exists $stored{$p};
  47                         push(@lin, $p);
  48                         $stored{$p} = 1;
  49                     }
  50                 }
  51                 return \@lin;
  52             };
  53 #       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
  54             $impl = $_get_linear_isa_dfs;
  55         }
  56     }
  57
  58
  59     no warnings 'once';
  60     *get_linear_isa = $impl;
  61 }
  62
  63 { # taken from Sub::Identify
  64     sub get_code_info($) {\r
  65         my ($coderef) = @_;\r
  66         ref($coderef) or return;\r
  67
  68         my $cv = B::svref_2object($coderef);\r
  69         $cv->isa('B::CV') or return;
  70
  71         my $gv = $cv->GV;\r
  72         $gv->isa('B::GV') or return;\r
  73 \r
  74         return ($gv->STASH->NAME, $gv->NAME);\r
  75     }\r
  76 }
  77
  78 # taken from Class/MOP.pm
  79 {
  80     my %cache;
  81
  82     sub resolve_metaclass_alias {
  83         my ( $type, $metaclass_name, %options ) = @_;
  84
  85         my $cache_key = $type;
  86         return $cache{$cache_key}{$metaclass_name}
  87           if $cache{$cache_key}{$metaclass_name};
  88
  89         my $possible_full_name =
  90             'Mouse::Meta::'
  91           . $type
  92           . '::Custom::'
  93           . $metaclass_name;
  94
  95         my $loaded_class =
  96           load_first_existing_class( $possible_full_name,
  97             $metaclass_name );
  98
  99         return $cache{$cache_key}{$metaclass_name} =
 100             $loaded_class->can('register_implementation')
 101           ? $loaded_class->register_implementation
 102           : $loaded_class;
 103     }
 104 }
 105
 106 # taken from Class/MOP.pm
 107 sub is_valid_class_name {
 108     my $class = shift;
 109
 110     return 0 if ref($class);
 111     return 0 unless defined($class);
 112
 113     return 1 if $class =~ /^\w+(?:::\w+)*$/;
 114
 115     return 0;
 116 }
 117
 118 # taken from Class/MOP.pm
 119 sub load_first_existing_class {
 120     my @classes = @_
 121       or return;
 122
 123     my $found;
 124     my %exceptions;
 125     for my $class (@classes) {
 126         my $e = _try_load_one_class($class);
 127
 128         if ($e) {
 129             $exceptions{$class} = $e;
 130         }
 131         else {
 132             $found = $class;
 133             last;
 134         }
 135     }
 136     return $found if $found;
 137
 138     confess join(
 139         "\n",
 140         map {
 141             sprintf( "Could not load class (%s) because : %s",
 142                 $_, $exceptions{$_} )
 143           } @classes
 144     );
 145 }
 146
 147 # taken from Class/MOP.pm
 148 sub _try_load_one_class {
 149     my $class = shift;
 150
 151     unless ( is_valid_class_name($class) ) {
 152         my $display = defined($class) ? $class : 'undef';
 153         confess "Invalid class name ($display)";
 154     }
 155
 156     return if is_class_loaded($class);
 157
 158     my $file = $class . '.pm';
 159     $file =~ s{::}{/}g;
 160
 161     return do {
 162         local $@;
 163         eval { require($file) };
 164         $@;
 165     };
 166 }
 167
 168
 169 sub load_class {
 170     my $class = shift;
 171     my $e = _try_load_one_class($class);
 172     confess "Could not load class ($class) because : $e" if $e;
 173
 174     return 1;
 175 }
 176
 177 my %is_class_loaded_cache;
 178 sub is_class_loaded {
 179     my $class = shift;
 180
 181     return 0 if ref($class) || !defined($class) || !length($class);
 182
 183     return 1 if $is_class_loaded_cache{$class};
 184
 185     # walk the symbol table tree to avoid autovififying
 186     # \*{${main::}{"Foo::"}} == \*main::Foo::
 187
 188     my $pack = \%::;
 189     foreach my $part (split('::', $class)) {
 190         my $entry = \$pack->{$part . '::'};
 191         return 0 if ref($entry) ne 'GLOB';
 192         $pack = *{$entry}{HASH} or return 0;
 193     }
 194
 195     # check for $VERSION or @ISA
 196     return ++$is_class_loaded_cache{$class} if exists $pack->{VERSION}
 197              && defined *{$pack->{VERSION}}{SCALAR} && defined ${ $pack->{VERSION} };
 198     return ++$is_class_loaded_cache{$class} if exists $pack->{ISA}
 199              && defined *{$pack->{ISA}}{ARRAY} && @{ $pack->{ISA} } != 0;
 200
 201     # check for any method
 202     foreach my $name( keys %{$pack} ) {
 203         my $entry = \$pack->{$name};
 204         return ++$is_class_loaded_cache{$class} if ref($entry) ne 'GLOB' || defined *{$entry}{CODE};
 205     }
 206
 207     # fail
 208     return 0;
 209 }
 210
 211
 212 sub apply_all_roles {
 213     my $meta = Mouse::Meta::Class->initialize(shift);
 214
 215     my @roles;
 216
 217     # Basis of Data::OptList
 218     my $max = scalar(@_);
 219     for (my $i = 0; $i < $max ; $i++) {
 220         if ($i + 1 < $max && ref($_[$i + 1])) {
 221             push @roles, [ $_[$i++] => $_[$i] ];
 222         } else {
 223             push @roles, [ $_[$i] => {} ];
 224         }
 225         my $role_name = $roles[-1][0];
 226         load_class($role_name);
 227         ( $role_name->can('meta') && $role_name->meta->isa('Mouse::Meta::Role') )
 228             || $meta->throw_error("You can only consume roles, $role_name(".$role_name->meta.") is not a Mouse role");
 229     }
 230
 231     if ( scalar @roles == 1 ) {
 232         my ( $role, $params ) = @{ $roles[0] };
 233         $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
 234     }
 235     else {
 236         Mouse::Meta::Role->combine_apply($meta, @roles);
 237     }
 238     return;
 239 }
 240
 241 sub not_supported{
 242     my($feature) = @_;
 243
 244     $feature ||= ( caller(1) )[3]; # subroutine name
 245
 246     local $Carp::CarpLevel = $Carp::CarpLevel + 2;
 247     Carp::croak("Mouse does not currently support $feature");
 248 }
 249
 250 1;
 251
 252 __END__
 253
 254 =head1 NAME
 255
 256 Mouse::Util - features, with or without their dependencies
 257
 258 =head1 IMPLEMENTATIONS FOR
 259
 260 =head2 L<MRO::Compat>
 261
 262 =head3 get_linear_isa
 263
 264 =cut
 265