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