X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=blobdiff_plain;f=lib%2FMouse%2FUtil.pm;h=d8b93e220e2d0c1a2301bb645bf7434903b97f0b;hp=5b34083b8ad87439eb7bf62f0fe0c6ef2e323682;hb=388b8ebd183c7e01a98401558e45837b20569802;hpb=d8aea268546acbcb18c45b2cfbb9787b31d93cd7

diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index 5b34083..d8b93e2 100644
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -1,132 +1,105 @@
-#!/usr/bin/env perl
 package Mouse::Util;
 use strict;
 use warnings;
-use base 'Exporter';
+use base qw/Exporter/;
+use Carp;
 
-our %dependencies = (
-    'Scalar::Util' => {
-        'blessed' => do {
-            do {
+our @EXPORT_OK = qw(
+    get_linear_isa
+);
+our %EXPORT_TAGS = (
+    all  => \@EXPORT_OK,
+);
+
+BEGIN {
+    my $impl;
+    if ($] >= 5.009_005) {
+        require mro;
+        $impl = \&mro::get_linear_isa;
+    } else {
+        my $loaded = do {
+            local $SIG{__DIE__} = 'DEFAULT';
+            eval "require MRO::Compat; 1";
+        };
+        if ($loaded) {
+            $impl = \&mro::get_linear_isa;
+        } else {
+#       VVVVV   CODE TAKEN FROM MRO::COMPAT   VVVVV
+            my $code; # this recurses so it isn't pretty
+            $code = sub {
                 no strict 'refs';
-                *UNIVERSAL::a_sub_not_likely_to_be_here = sub {
-                    my $ref = ref($_[0]);
-
-                    # deviation from Scalar::Util
-                    # XS returns undef, PP returns GLOB.
-                    # let's make that more consistent by having PP return
-                    # undef if it's a GLOB. :/
-
-                    # \*STDOUT would be allowed as an object in PP blessed
-                    # but not XS
-                    return $ref eq 'GLOB' ? undef : $ref;
-                };
-            };
 
-            sub {
-                local($@, $SIG{__DIE__}, $SIG{__WARN__});
-                length(ref($_[0]))
-                    ? eval { $_[0]->a_sub_not_likely_to_be_here }
-                    : undef;
-            },
-        },
-        'looks_like_number' => sub {
-            local $_ = shift;
-
-            # checks from perlfaq4
-            return 0 if !defined($_) or ref($_);
-            return 1 if (/^[+-]?\d+$/); # is a +/- integer
-            return 1 if (/^([+-]?)(?=\d|\.\d)\d*(\.\d*)?([Ee]([+-]?\d+))?$/); # a C float
-            return 1 if ($] >= 5.008 and /^(Inf(inity)?|NaN)$/i) or ($] >= 5.006001 and /^Inf$/i);
-
-            0;
-        },
-        'reftype' => sub {
-            local($@, $SIG{__DIE__}, $SIG{__WARN__});
-            my $r = shift;
-            my $t;
-
-            length($t = ref($r)) or return undef;
-
-            # This eval will fail if the reference is not blessed
-            eval { $r->a_sub_not_likely_to_be_here; 1 }
-            ? do {
-                $t = eval {
-                    # we have a GLOB or an IO. Stringify a GLOB gives it's name
-                    my $q = *$r;
-                    $q =~ /^\*/ ? "GLOB" : "IO";
-                }
-                or do {
-                    # OK, if we don't have a GLOB what parts of
-                    # a glob will it populate.
-                    # NOTE: A glob always has a SCALAR
-                    local *glob = $r;
-                    defined *glob{ARRAY} && "ARRAY"
-                        or defined *glob{HASH} && "HASH"
-                        or defined *glob{CODE} && "CODE"
-                        or length(ref(${$r})) ? "REF" : "SCALAR";
-                }
-            }
-            : $t
-        },
-    },
-    'MRO::Compat' => {
-        'get_linear_isa' => {
-            loaded     => \&mro::get_linear_isa,
-            not_loaded => do {
-                # this recurses so it isn't pretty
-                my $code;
-                $code = sub {
-                    no strict 'refs';
-
-                    my $classname = shift;
-
-                    my @lin = ($classname);
-                    my %stored;
-                    foreach my $parent (@{"$classname\::ISA"}) {
-                        my $plin = $code->($parent);
-                        foreach (@$plin) {
-                            next if exists $stored{$_};
-                            push(@lin, $_);
-                            $stored{$_} = 1;
-                        }
+                my $classname = shift;
+
+                my @lin = ($classname);
+                my %stored;
+                foreach my $parent (@{"$classname\::ISA"}) {
+                    my $plin = $code->($parent);
+                    foreach (@$plin) {
+                        next if exists $stored{$_};
+                        push(@lin, $_);
+                        $stored{$_} = 1;
                     }
-                    return \@lin;
                 }
-            },
-        },
-    },
-);
-
-our @EXPORT_OK = map { keys %$_ } values %dependencies;
+                return \@lin;
+            };
+#       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
+            $impl = $code;
+        }
+    }
 
-for my $module_name (keys %dependencies) {
-    (my $file = "$module_name.pm") =~ s{::}{/}g;
+    no strict 'refs';
+    *{ __PACKAGE__ . '::get_linear_isa'} = $impl;
+}
 
-    my $loaded = do {
-        local $SIG{__DIE__} = 'DEFAULT';
-        eval "require '$file'; 1";
-    };
+sub apply_all_roles {
+    my $meta = Mouse::Meta::Class->initialize(shift);
 
-    for my $method_name (keys %{ $dependencies{ $module_name } }) {
-        my $producer = $dependencies{$module_name}{$method_name};
-        my $implementation;
+    my @roles;
 
-        if (ref($producer) eq 'HASH') {
-            $implementation = $loaded
-                            ? $producer->{loaded}
-                            : $producer->{not_loaded};
-        }
-        else {
-            $implementation = $loaded
-                            ? $module_name->can($method_name)
-                            : $producer;
+    # Basis of Data::OptList
+    my $max = scalar(@_);
+    for (my $i = 0; $i < $max ; $i++) {
+        if ($i + 1 < $max && ref($_[$i + 1])) {
+            push @roles, [ $_[$i++] => $_[$i] ];
+        } else {
+            push @roles, [ $_[$i] => {} ];
         }
+    }
+
+    foreach my $role_spec (@roles) {
+        Mouse::load_class( $role_spec->[0] );
+    }
+
+    ( $_->[0]->can('meta') && $_->[0]->meta->isa('Mouse::Meta::Role') )
+        || croak("You can only consume roles, "
+        . $_->[0]
+        . " is not a Moose role")
+        foreach @roles;
 
-        no strict 'refs';
-        *{ __PACKAGE__ . '::' . $method_name } = $implementation;
+    if ( scalar @roles == 1 ) {
+        my ( $role, $params ) = @{ $roles[0] };
+        $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
     }
+    else {
+        Mouse::Meta::Role->combine_apply($meta, @roles);
+    }
+
 }
 
 1;
 
+__END__
+
+=head1 NAME
+
+Mouse::Util - features, with or without their dependencies
+
+=head1 IMPLEMENTATIONS FOR
+
+=head2 L<MRO::Compat>
+
+=head3 get_linear_isa
+
+=cut
+