X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMouse%2FUtil.pm;h=77cbb2a9822cc6526172a684b8b3e24bcf7d0b7f;hb=64959bc911422335c41bea9cadc584f33d6ba705;hp=4c194fda6bece9516da73b413fe449173c24ab28;hpb=eae8075956ba01581ea7488b4ddb2506db1111da;p=gitmo%2FMouse.git

diff --git a/lib/Mouse/Util.pm b/lib/Mouse/Util.pm
index 4c194fd..77cbb2a 100644
--- a/lib/Mouse/Util.pm
+++ b/lib/Mouse/Util.pm
@@ -21,7 +21,150 @@ our %EXPORT_TAGS = (
 # Mouse.pm, so check if we're running under PurePerl or not
 BEGIN {
     if ($Mouse::PurePerl) {
-        _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 {
+                        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
+                },
+                '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;
+                },
+                weaken => {
+                    loaded => \&Scalar::Util::weaken,
+                    not_loaded => sub { die "Scalar::Util required for weak reference support" },
+                },
+    #       ^^^^^   CODE TAKEN FROM SCALAR::UTIL   ^^^^^
+            },
+            'MRO::Compat' => {
+    #       VVVVV   CODE TAKEN FROM MRO::COMPAT   VVVVV
+                '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;
+                                }
+                            }
+                            return \@lin;
+                        }
+                    },
+                },
+    #       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
+            },
+        );
+    
+        my %loaded;
+        for my $module_name (keys %dependencies) {
+            my $loaded = do {
+                local $SIG{__DIE__} = 'DEFAULT';
+                eval "require $module_name; 1";
+            };
+    
+            $loaded{$module_name} = $loaded;
+    
+            for my $method_name (keys %{ $dependencies{ $module_name } }) {
+                my $producer = $dependencies{$module_name}{$method_name};
+                my $implementation;
+    
+                if (ref($producer) eq 'HASH') {
+                    $implementation = $loaded
+                                    ? $producer->{loaded}
+                                    : $producer->{not_loaded};
+                }
+                else {
+                    $implementation = $loaded
+                                    ? $module_name->can($method_name)
+                                    : $producer;
+                }
+    
+                no strict 'refs';
+                *{ __PACKAGE__ . '::' . $method_name } = $implementation;
+            }
+        }
     } else {
         # If we're running under XS, we can provide
         #   blessed
@@ -30,41 +173,30 @@ BEGIN {
         #   weaken
         # other functions need to be loaded from our respective sources
 
-        if (defined &Scalar::Util::openhandle) {
+        if (defined &Scalar::Util::openhandle || eval { require Scalar::Util; 1 }) {
             *openhandle = \&Scalar::Util::openhandle;
         } else {
             # XXX - room for improvement
             *openhandle = sub {
-                local($@, $SIG{__DIE__}, $SIG{__WARN__});
-                my $r = shift;
-                my $t;
+                my $fh = shift;
+                my $rt = reftype($fh) || '';
 
-                length($t = ref($r)) or return undef;
+                return defined(fileno($fh)) ? $fh : undef
+                    if $rt eq 'IO';
 
-                # 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";
-                    }
+                if (reftype(\$fh) eq 'GLOB') { # handle  openhandle(*DATA)
+                    $fh = \(my $tmp=$fh);
+                }
+                elsif ($rt ne 'GLOB') {
+                    return undef;
                 }
-                : $t
+
+                (tied(*$fh) or defined(fileno($fh)))
+                    ? $fh : undef;
             };
         }
 
-        if (defined &mro::get_linear_isa) {
+        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
@@ -90,153 +222,6 @@ BEGIN {
     }
 }
 
-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 {
-                    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
-            },
-            '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;
-            },
-            weaken => {
-                loaded => \&Scalar::Util::weaken,
-                not_loaded => sub { die "Scalar::Util required for weak reference support" },
-            },
-#       ^^^^^   CODE TAKEN FROM SCALAR::UTIL   ^^^^^
-        },
-        'MRO::Compat' => {
-#       VVVVV   CODE TAKEN FROM MRO::COMPAT   VVVVV
-            '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;
-                            }
-                        }
-                        return \@lin;
-                    }
-                },
-            },
-#       ^^^^^   CODE TAKEN FROM MRO::COMPAT   ^^^^^
-        },
-    );
-
-    my %loaded;
-    for my $module_name (keys %dependencies) {
-        my $loaded = do {
-            local $SIG{__DIE__} = 'DEFAULT';
-            eval "require $module_name; 1";
-        };
-
-        $loaded{$module_name} = $loaded;
-
-        for my $method_name (keys %{ $dependencies{ $module_name } }) {
-            my $producer = $dependencies{$module_name}{$method_name};
-            my $implementation;
-
-            if (ref($producer) eq 'HASH') {
-                $implementation = $loaded
-                                ? $producer->{loaded}
-                                : $producer->{not_loaded};
-            }
-            else {
-                $implementation = $loaded
-                                ? $module_name->can($method_name)
-                                : $producer;
-            }
-
-            no strict 'refs';
-            *{ __PACKAGE__ . '::' . $method_name } = $implementation;
-        }
-    }
-}
-
 sub apply_all_roles {
     my $meta = Mouse::Meta::Class->initialize(shift);
     my $role  = shift;