oops, copied the wrong sub

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

diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index a27600b..e080bf4 100644 (file)
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -2,13 +2,86 @@
 package Mouse::Util;
 use strict;
 use warnings;
-use base 'Exporter';
+use Exporter 'import';
 use Carp;
 
+our @EXPORT_OK = qw(
+    blessed
+    get_linear_isa
+    looks_like_number
+    openhandle
+    reftype
+    weaken
+);
+our %EXPORT_TAGS = (
+    all  => \@EXPORT_OK,
+);
+
+# We only have to do this nastiness if we haven't loaded XS version of
+# Mouse.pm, so check if we're running under PurePerl or not
 BEGIN {
-    our %dependencies = (
-        'Scalar::Util' => {
+    if ($Mouse::PurePerl) {
+        _install_pp_func();
+    } else {
+        # If we're running under XS, we can provide
+        #   blessed
+        #   looks_like_number
+        #   reftype
+        #   weaken
+        # other functions need to be loaded from our respective sources
+
+        if (defined &Scalar::Util::openhandle || eval { require Scalar::Util; 1 }) {
+            *openhandle = \&Scalar::Util::openhandle;
+        } else {
+            # XXX - room for improvement
+            *openhandle = sub {
+                my $fh = shift;
+                my $rt = reftype($fh) || '';
+
+                return defined(fileno($fh)) ? $fh : undef
+                    if $rt eq 'IO';
 
+                if (reftype(\$fh) eq 'GLOB') { # handle  openhandle(*DATA)
+                    $fh = \(my $tmp=$fh);
+                }
+                elsif ($rt ne 'GLOB') {
+                    return undef;
+                }
+
+                (tied(*$fh) or defined(fileno($fh)))
+                    ? $fh : undef;
+            };
+        }
+
+        if (defined &mro::get_linear_isa || eval { require MRO::Compat; 1; }) {
+            *get_linear_isa = \&mro::get_linear_isa;
+        } else {
+            # this recurses so it isn't pretty
+            my $code;
+            *get_linear_isa = $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;
+                    }
+                }
+                return \@lin;
+            };
+        }
+    }
+}
+
+sub _install_pp_func {
+    my %dependencies = (
+        'Scalar::Util' => {
 #       VVVVV   CODE TAKEN FROM SCALAR::UTIL   VVVVV
             'blessed' => do {
                 *UNIVERSAL::a_sub_not_likely_to_be_here = sub {
@@ -121,79 +194,9 @@ BEGIN {
             },
 #       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
         },
-#       VVVVV   CODE TAKEN FROM TEST::EXCEPTION   VVVVV
-        'Test::Exception' => do {
-
-            my $Tester;
-
-            my $is_exception = sub {
-                my $exception = shift;
-                return ref $exception || $exception ne '';
-            };
-
-            my $exception_as_string = sub {
-                my ( $prefix, $exception ) = @_;
-                return "$prefix normal exit" unless $is_exception->( $exception );
-                my $class = ref $exception;
-                $exception = "$class ($exception)"
-                        if $class && "$exception" !~ m/^\Q$class/;
-                chomp $exception;
-                return "$prefix $exception";
-            };
-            my $try_as_caller = sub {
-                my $coderef = shift;
-                eval { $coderef->() };
-                $@;
-            };
-
-            {
-                'throws_ok' => sub (&$;$) {
-                    my ( $coderef, $expecting, $description ) = @_;
-                    Carp::croak "throws_ok: must pass exception class/object or regex"
-                        unless defined $expecting;
-                    $description = $exception_as_string->( "threw", $expecting )
-                        unless defined $description;
-                    my $exception = $try_as_caller->($coderef);
-
-                    $Tester ||= Test::Builder->new;
-
-                    my $regex = $Tester->maybe_regex( $expecting );
-                    my $ok = $regex
-                        ? ( $exception =~ m/$regex/ )
-                        : eval {
-                            $exception->isa( ref $expecting ? ref $expecting : $expecting )
-                        };
-                    $Tester->ok( $ok, $description );
-                    unless ( $ok ) {
-                        $Tester->diag( $exception_as_string->( "expecting:", $expecting ) );
-                        $Tester->diag( $exception_as_string->( "found:", $exception ) );
-                    };
-                    $@ = $exception;
-                    return $ok;
-                },
-                'lives_ok' => sub (&;$) {
-                    my ( $coderef, $description ) = @_;
-                    my $exception = $try_as_caller->( $coderef );
-
-                    $Tester ||= Test::Builder->new;
-
-                    my $ok = $Tester->ok( ! $is_exception->( $exception ), $description );
-                    $Tester->diag( $exception_as_string->( "died:", $exception ) ) unless $ok;
-                    $@ = $exception;
-                    return $ok;
-                },
-            },
-        },
-    );
-
-    our %loaded;
-
-    our @EXPORT_OK = map { keys %$_ } values %dependencies;
-    our %EXPORT_TAGS = (
-        all  => \@EXPORT_OK,
-        test => [qw/throws_ok lives_ok/],
     );
 
+    my %loaded;
     for my $module_name (keys %dependencies) {
         my $loaded = do {
             local $SIG{__DIE__} = 'DEFAULT';
@@ -223,6 +226,15 @@ BEGIN {
     }
 }
 
+sub apply_all_roles {
+    my $meta = Mouse::Meta::Class->initialize(shift);
+    my $role  = shift;
+    confess "Mouse::Util only supports 'apply_all_roles' on individual roles at a time" if @_;
+
+    Mouse::load_class($role);
+    $role->meta->apply($meta);
+}
+
 1;
 
 __END__