lib/Mouse/Util.pm

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