A tiny tweak

[gitmo/Mouse.git] / lib / Mouse / Util.pm

diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index 1bb4d41..73e76ba 100644 (file)
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -2,11 +2,14 @@ package Mouse::Util;
 use strict;
 use warnings;
 use base qw/Exporter/;
-use Carp;
+use Carp qw(confess);
+use B ();
 
 our @EXPORT_OK = qw(
     get_linear_isa
     apply_all_roles
+    get_code_info
+    not_supported
 );
 our %EXPORT_TAGS = (
     all  => \@EXPORT_OK,
@@ -18,16 +21,17 @@ BEGIN {
         require mro;
         $impl = \&mro::get_linear_isa;
     } else {
-        my $loaded = do {
-            local $SIG{__DIE__} = 'DEFAULT';
-            eval "require MRO::Compat; 1";
+        my $e = do {
+            local $@;
+            eval { require MRO::Compat };
+            $@;
         };
-        if ($loaded) {
+        if (!$e) {
             $impl = \&mro::get_linear_isa;
         } else {
 #       VVVVV   CODE TAKEN FROM MRO::COMPAT   VVVVV
-            my $code; # this recurses so it isn't pretty
-            $code = sub {
+            my $_get_linear_isa_dfs; # this recurses so it isn't pretty
+            $_get_linear_isa_dfs = sub {
                 no strict 'refs';
 
                 my $classname = shift;
@@ -35,22 +39,38 @@ BEGIN {
                 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 $plin = $_get_linear_isa_dfs->($parent);
+                    foreach  my $p(@$plin) {
+                        next if exists $stored{$p};
+                        push(@lin, $p);
+                        $stored{$p} = 1;
                     }
                 }
                 return \@lin;
             };
 #       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
-            $impl = $code;
+            $impl = $_get_linear_isa_dfs;
         }
     }
 
-    no strict 'refs';
-    *{ __PACKAGE__ . '::get_linear_isa'} = $impl;
+
+    no warnings 'once';
+    *get_linear_isa = $impl;
+}
+
+{ # taken from Sub::Identify
+    sub get_code_info($) {\r
+        my ($coderef) = @_;\r
+        ref($coderef) or return;\r
+
+        my $cv = B::svref_2object($coderef);\r
+        $cv->isa('B::CV') or return;
+
+        my $gv = $cv->GV;\r
+        $gv->isa('B::GV') or return;\r
+\r
+        return ($gv->STASH->NAME, $gv->NAME);\r
+    }\r
 }
 
 # taken from Class/MOP.pm
@@ -82,7 +102,7 @@ BEGIN {
 }
 
 # taken from Class/MOP.pm
-sub _is_valid_class_name {
+sub is_valid_class_name {
     my $class = shift;
 
     return 0 if ref($class);
@@ -99,16 +119,14 @@ sub load_first_existing_class {
     my @classes = @_
       or return;
 
-    foreach my $class (@classes) {
-        unless ( _is_valid_class_name($class) ) {
+    my $found;
+    my %exceptions;
+    for my $class (@classes) {
+        unless ( is_valid_class_name($class) ) {
             my $display = defined($class) ? $class : 'undef';
             confess "Invalid class name ($display)";
         }
-    }
 
-    my $found;
-    my %exceptions;
-    for my $class (@classes) {
         my $e = _try_load_one_class($class);
 
         if ($e) {
@@ -166,7 +184,7 @@ sub apply_all_roles {
     }
 
     ( $_->[0]->can('meta') && $_->[0]->meta->isa('Mouse::Meta::Role') )
-        || croak("You can only consume roles, "
+        || confess("You can only consume roles, "
         . $_->[0]
         . " is not a Moose role")
         foreach @roles;
@@ -178,7 +196,16 @@ sub apply_all_roles {
     else {
         Mouse::Meta::Role->combine_apply($meta, @roles);
     }
+    return;
+}
+
+sub not_supported{
+    my($feature) = @_;
+
+    $feature ||= ( caller(1) )[3]; # subroutine name
 
+    local $Carp::CarpLevel = $Carp::CarpLevel + 2;
+    Carp::croak("Mouse does not currently support $feature");
 }
 
 1;