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     version
  11     authority
  12     identifier
  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 $loaded = do {
  25             local $SIG{__DIE__} = 'DEFAULT';
  26             eval { require MRO::Compat; 1 };
  27         };
  28         if ($loaded) {
  29             $impl = \&mro::get_linear_isa;
  30         } else {
  31 #       VVVVV   CODE TAKEN FROM MRO::COMPAT   VVVVV
  32             my $code; # this recurses so it isn't pretty
  33             $code = 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 = $code->($parent);
  42                     foreach (@$plin) {
  43                         next if exists $stored{$_};
  44                         push(@lin, $_);
  45                         $stored{$_} = 1;
  46                     }
  47                 }
  48                 return \@lin;
  49             };
  50 #       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
  51             $impl = $code;
  52         }
  53     }
  54
  55     no strict 'refs';
  56     *{ __PACKAGE__ . '::get_linear_isa'} = $impl;
  57 }
  58
  59 { # adapted from Class::MOP::Module
  60
  61     sub version { no strict 'refs'; ${shift->name.'::VERSION'} }
  62     sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} }
  63     sub identifier {
  64         my $self = shift;
  65         join '-' => (
  66             $self->name,
  67             ($self->version   || ()),
  68             ($self->authority || ()),
  69         );
  70     }
  71 }
  72
  73 # taken from Class/MOP.pm
  74 {
  75     my %cache;
  76
  77     sub resolve_metaclass_alias {
  78         my ( $type, $metaclass_name, %options ) = @_;
  79
  80         my $cache_key = $type;
  81         return $cache{$cache_key}{$metaclass_name}
  82           if $cache{$cache_key}{$metaclass_name};
  83
  84         my $possible_full_name =
  85             'Mouse::Meta::'
  86           . $type
  87           . '::Custom::'
  88           . $metaclass_name;
  89
  90         my $loaded_class =
  91           load_first_existing_class( $possible_full_name,
  92             $metaclass_name );
  93
  94         return $cache{$cache_key}{$metaclass_name} =
  95             $loaded_class->can('register_implementation')
  96           ? $loaded_class->register_implementation
  97           : $loaded_class;
  98     }
  99 }
 100
 101 # taken from Class/MOP.pm
 102 sub _is_valid_class_name {
 103     my $class = shift;
 104
 105     return 0 if ref($class);
 106     return 0 unless defined($class);
 107     return 0 unless length($class);
 108
 109     return 1 if $class =~ /^\w+(?:::\w+)*$/;
 110
 111     return 0;
 112 }
 113
 114 # taken from Class/MOP.pm
 115 sub load_first_existing_class {
 116     my @classes = @_
 117       or return;
 118
 119     foreach my $class (@classes) {
 120         unless ( _is_valid_class_name($class) ) {
 121             my $display = defined($class) ? $class : 'undef';
 122             confess "Invalid class name ($display)";
 123         }
 124     }
 125
 126     my $found;
 127     my %exceptions;
 128     for my $class (@classes) {
 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         || croak("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
 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