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