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 exists $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         return 0 unless exists ${$$pack}{"${part}::"};
 191         $pack = \*{${$$pack}{"${part}::"}};
 192     }
 193
 194     # check for $VERSION or @ISA
 195     return ++$is_class_loaded_cache{$class} if exists ${$$pack}{VERSION}
 196              && defined *{${$$pack}{VERSION}}{SCALAR};
 197     return ++$is_class_loaded_cache{$class} if exists ${$$pack}{ISA}
 198              && defined *{${$$pack}{ISA}}{ARRAY};
 199
 200     # check for any method
 201     foreach ( keys %{$$pack} ) {
 202         next if substr($_, -2, 2) eq '::';
 203         return ++$is_class_loaded_cache{$class} if defined *{${$$pack}{$_}}{CODE};
 204     }
 205
 206     # fail
 207     return 0;
 208 }
 209
 210
 211 sub apply_all_roles {
 212     my $meta = Mouse::Meta::Class->initialize(shift);
 213
 214     my @roles;
 215
 216     # Basis of Data::OptList
 217     my $max = scalar(@_);
 218     for (my $i = 0; $i < $max ; $i++) {
 219         if ($i + 1 < $max && ref($_[$i + 1])) {
 220             push @roles, [ $_[$i++] => $_[$i] ];
 221         } else {
 222             push @roles, [ $_[$i] => {} ];
 223         }
 224     }
 225
 226     foreach my $role_spec (@roles) {
 227         Mouse::load_class( $role_spec->[0] );
 228     }
 229
 230     ( $_->[0]->can('meta') && $_->[0]->meta->isa('Mouse::Meta::Role') )
 231         || confess("You can only consume roles, "
 232         . $_->[0]
 233         . " is not a Moose role")
 234         foreach @roles;
 235
 236     if ( scalar @roles == 1 ) {
 237         my ( $role, $params ) = @{ $roles[0] };
 238         $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
 239     }
 240     else {
 241         Mouse::Meta::Role->combine_apply($meta, @roles);
 242     }
 243     return;
 244 }
 245
 246 sub not_supported{
 247     my($feature) = @_;
 248
 249     $feature ||= ( caller(1) )[3]; # subroutine name
 250
 251     local $Carp::CarpLevel = $Carp::CarpLevel + 2;
 252     Carp::croak("Mouse does not currently support $feature");
 253 }
 254
 255 1;
 256
 257 __END__
 258
 259 =head1 NAME
 260
 261 Mouse::Util - features, with or without their dependencies
 262
 263 =head1 IMPLEMENTATIONS FOR
 264
 265 =head2 L<MRO::Compat>
 266
 267 =head3 get_linear_isa
 268
 269 =cut
 270