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