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
  56     no warnings 'once';
  57     *get_linear_isa = $impl;
  58 }
  59
  60 { # taken from Sub::Identify
  61     sub get_code_info($) {\r
  62         my ($coderef) = @_;\r
  63         ref($coderef) or return;\r
  64
  65         my $cv = B::svref_2object($coderef);\r
  66         $cv->isa('B::CV') or return;
  67
  68         my $gv = $cv->GV;\r
  69         $gv->isa('B::GV') or return;\r
  70 \r
  71         return ($gv->STASH->NAME, $gv->NAME);\r
  72     }\r
  73 }
  74
  75 # taken from Class/MOP.pm
  76 {
  77     my %cache;
  78
  79     sub resolve_metaclass_alias {
  80         my ( $type, $metaclass_name, %options ) = @_;
  81
  82         my $cache_key = $type;
  83         return $cache{$cache_key}{$metaclass_name}
  84           if $cache{$cache_key}{$metaclass_name};
  85
  86         my $possible_full_name =
  87             'Mouse::Meta::'
  88           . $type
  89           . '::Custom::'
  90           . $metaclass_name;
  91
  92         my $loaded_class =
  93           load_first_existing_class( $possible_full_name,
  94             $metaclass_name );
  95
  96         return $cache{$cache_key}{$metaclass_name} =
  97             $loaded_class->can('register_implementation')
  98           ? $loaded_class->register_implementation
  99           : $loaded_class;
 100     }
 101 }
 102
 103 # taken from Class/MOP.pm
 104 sub is_valid_class_name {
 105     my $class = shift;
 106
 107     return 0 if ref($class);
 108     return 0 unless defined($class);
 109     return 0 unless length($class);
 110
 111     return 1 if $class =~ /^\w+(?:::\w+)*$/;
 112
 113     return 0;
 114 }
 115
 116 # taken from Class/MOP.pm
 117 sub load_first_existing_class {
 118     my @classes = @_
 119       or return;
 120
 121     my $found;
 122     my %exceptions;
 123     for my $class (@classes) {
 124         unless ( is_valid_class_name($class) ) {
 125             my $display = defined($class) ? $class : 'undef';
 126             confess "Invalid class name ($display)";
 127         }
 128
 129         my $e = _try_load_one_class($class);
 130
 131         if ($e) {
 132             $exceptions{$class} = $e;
 133         }
 134         else {
 135             $found = $class;
 136             last;
 137         }
 138     }
 139     return $found if $found;
 140
 141     confess join(
 142         "\n",
 143         map {
 144             sprintf( "Could not load class (%s) because : %s",
 145                 $_, $exceptions{$_} )
 146           } @classes
 147     );
 148 }
 149
 150 # taken from Class/MOP.pm
 151 sub _try_load_one_class {
 152     my $class = shift;
 153
 154     return if Mouse::is_class_loaded($class);
 155
 156     my $file = $class . '.pm';
 157     $file =~ s{::}{/}g;
 158
 159     return do {
 160         local $@;
 161         eval { require($file) };
 162         $@;
 163     };
 164 }
 165
 166 sub apply_all_roles {
 167     my $meta = Mouse::Meta::Class->initialize(shift);
 168
 169     my @roles;
 170
 171     # Basis of Data::OptList
 172     my $max = scalar(@_);
 173     for (my $i = 0; $i < $max ; $i++) {
 174         if ($i + 1 < $max && ref($_[$i + 1])) {
 175             push @roles, [ $_[$i++] => $_[$i] ];
 176         } else {
 177             push @roles, [ $_[$i] => {} ];
 178         }
 179     }
 180
 181     foreach my $role_spec (@roles) {
 182         Mouse::load_class( $role_spec->[0] );
 183     }
 184
 185     ( $_->[0]->can('meta') && $_->[0]->meta->isa('Mouse::Meta::Role') )
 186         || confess("You can only consume roles, "
 187         . $_->[0]
 188         . " is not a Moose role")
 189         foreach @roles;
 190
 191     if ( scalar @roles == 1 ) {
 192         my ( $role, $params ) = @{ $roles[0] };
 193         $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
 194     }
 195     else {
 196         Mouse::Meta::Role->combine_apply($meta, @roles);
 197     }
 198     return;
 199 }
 200
 201 1;
 202
 203 __END__
 204
 205 =head1 NAME
 206
 207 Mouse::Util - features, with or without their dependencies
 208
 209 =head1 IMPLEMENTATIONS FOR
 210
 211 =head2 L<MRO::Compat>
 212
 213 =head3 get_linear_isa
 214
 215 =cut
 216