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 $e = do {
  25             local $@;
  26             eval { require MRO::Compat };
  27             $@;
  28         };
  29         if (!$e) {
  30             $impl = \&mro::get_linear_isa;
  31         } else {
  32 #       VVVVV   CODE TAKEN FROM MRO::COMPAT   VVVVV
  33             my $_get_linear_isa_dfs; # this recurses so it isn't pretty
  34             $_get_linear_isa_dfs = sub {
  35                 no strict 'refs';
  36
  37                 my $classname = shift;
  38
  39                 my @lin = ($classname);
  40                 my %stored;
  41                 foreach my $parent (@{"$classname\::ISA"}) {
  42                     my $plin = $_get_linear_isa_dfs->($parent);
  43                     foreach  my $p(@$plin) {
  44                         next if exists $stored{$p};
  45                         push(@lin, $p);
  46                         $stored{$p} = 1;
  47                     }
  48                 }
  49                 return \@lin;
  50             };
  51 #       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
  52             $impl = $_get_linear_isa_dfs;
  53         }
  54     }
  55
  56     no strict 'refs';
  57     *{ __PACKAGE__ . '::get_linear_isa'} = $impl;
  58 }
  59
  60 { # adapted from Class::MOP::Module
  61
  62     sub version { no strict 'refs'; ${shift->name.'::VERSION'} }
  63     sub authority { no strict 'refs'; ${shift->name.'::AUTHORITY'} }
  64     sub identifier {
  65         my $self = shift;
  66         join '-' => (
  67             $self->name,
  68             ($self->version   || ()),
  69             ($self->authority || ()),
  70         );
  71     }
  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     foreach my $class (@classes) {
 121         unless ( _is_valid_class_name($class) ) {
 122             my $display = defined($class) ? $class : 'undef';
 123             confess "Invalid class name ($display)";
 124         }
 125     }
 126
 127     my $found;
 128     my %exceptions;
 129     for my $class (@classes) {
 130         my $e = _try_load_one_class($class);
 131
 132         if ($e) {
 133             $exceptions{$class} = $e;
 134         }
 135         else {
 136             $found = $class;
 137             last;
 138         }
 139     }
 140     return $found if $found;
 141
 142     confess join(
 143         "\n",
 144         map {
 145             sprintf( "Could not load class (%s) because : %s",
 146                 $_, $exceptions{$_} )
 147           } @classes
 148     );
 149 }
 150
 151 # taken from Class/MOP.pm
 152 sub _try_load_one_class {
 153     my $class = shift;
 154
 155     return if Mouse::is_class_loaded($class);
 156
 157     my $file = $class . '.pm';
 158     $file =~ s{::}{/}g;
 159
 160     return do {
 161         local $@;
 162         eval { require($file) };
 163         $@;
 164     };
 165 }
 166
 167 sub apply_all_roles {
 168     my $meta = Mouse::Meta::Class->initialize(shift);
 169
 170     my @roles;
 171
 172     # Basis of Data::OptList
 173     my $max = scalar(@_);
 174     for (my $i = 0; $i < $max ; $i++) {
 175         if ($i + 1 < $max && ref($_[$i + 1])) {
 176             push @roles, [ $_[$i++] => $_[$i] ];
 177         } else {
 178             push @roles, [ $_[$i] => {} ];
 179         }
 180     }
 181
 182     foreach my $role_spec (@roles) {
 183         Mouse::load_class( $role_spec->[0] );
 184     }
 185
 186     ( $_->[0]->can('meta') && $_->[0]->meta->isa('Mouse::Meta::Role') )
 187         || croak("You can only consume roles, "
 188         . $_->[0]
 189         . " is not a Moose role")
 190         foreach @roles;
 191
 192     if ( scalar @roles == 1 ) {
 193         my ( $role, $params ) = @{ $roles[0] };
 194         $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
 195     }
 196     else {
 197         Mouse::Meta::Role->combine_apply($meta, @roles);
 198     }
 199
 200 }
 201
 202 1;
 203
 204 __END__
 205
 206 =head1 NAME
 207
 208 Mouse::Util - features, with or without their dependencies
 209
 210 =head1 IMPLEMENTATIONS FOR
 211
 212 =head2 L<MRO::Compat>
 213
 214 =head3 get_linear_isa
 215
 216 =cut
 217