From: Yuval Kogman <nothingmuch@woobling.org>
Date: Mon, 11 Aug 2008 01:06:15 +0000 (+0000)
Subject: simplify loading of XS code so that it's not as nitrusive to the pureperl bits
X-Git-Tag: 0_64_01~40
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=0531f5107472b7d12155394f59f3755042e21d2c;p=gitmo%2FClass-MOP.git

simplify loading of XS code so that it's not as nitrusive to the pureperl bits
---

diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm
index 0c0550f..2f263f9 100644
--- a/lib/Class/MOP.pm
+++ b/lib/Class/MOP.pm
@@ -9,6 +9,14 @@ use MRO::Compat;
 use Carp          'confess';
 use Scalar::Util  'weaken';
 
+use Sub::Identify 'get_code_info';
+
+use Class::MOP::Class;
+use Class::MOP::Attribute;
+use Class::MOP::Method;
+
+use Class::MOP::Immutable;
+
 BEGIN {
     
     our $VERSION   = '0.65';
@@ -22,79 +30,29 @@ BEGIN {
         ? sub () { 1 }
         : sub () { 1 };
 
-    # NOTE:
-    # we may not use this yet, but once 
-    # the get_code_info XS gets merged 
-    # upstream to it, we will always use 
-    # it. But for now it is just kinda 
-    # extra overhead.
-    # - SL
-    require Sub::Identify;
-        
-    # stash these for a sec, and see how things go
-    my $_PP_subname       = sub { $_[1] };
-    my $_PP_get_code_info = \&Sub::Identify::get_code_info;    
-    
-    if ($ENV{CLASS_MOP_NO_XS}) {
-        # NOTE:
-        # this is if you really want things
-        # to be slow, then you can force the
-        # no-XS rule this way, otherwise we 
-        # make an effort to load as much of 
-        # the XS as possible.
-        # - SL
-        no warnings 'prototype', 'redefine';
-        
-        # this is either part of core or set up appropriately by MRO::Compat
-        *check_package_cache_flag = \&mro::get_pkg_gen; 
-
-        # our own version of Sub::Name
-        *subname       = $_PP_subname;
-        # and the Sub::Identify version of the get_code_info
-        *get_code_info = $_PP_get_code_info;        
-    }
-    else {
-        # now try our best to get as much 
-        # of the XS loaded as possible
-        {
-            my $e = do {
-                local $@;
-                eval {
-                    require XSLoader;
-                    __PACKAGE__->XSLoader::load($VERSION);
-                };
-                $@;
-            };
-
-            die $e if $e && $e !~ /object version|loadable object/;
-            
-            # okay, so the XS failed to load, so 
-            # use the pure perl one instead.
-            *get_code_info = $_PP_get_code_info if $e; 
-        }        
-        
-        # get it from MRO::Compat
-        *check_package_cache_flag = \&mro::get_pkg_gen;        
-        
-        # now try and load the Sub::Name 
-        # module and use that as a means
-        # for naming our CVs, if not, we 
-        # use the workaround instead.
+    {
         local $@;
-        if ( eval { require Sub::Name } ) {
-            *subname = \&Sub::Name::subname;
-        } 
-        else {
-            *subname = $_PP_subname;
-        }     
+        eval 'use Sub::Name qw(subname); 1' || eval 'sub subname { $_[1] }';
     }
-}
 
-use Class::MOP::Class;
-use Class::MOP::Attribute;
-use Class::MOP::Method;
+    # this is either part of core or set up appropriately by MRO::Compat
+    *check_package_cache_flag = \&mro::get_pkg_gen;
+}
 
-use Class::MOP::Immutable;
+# after that everything is loaded, if we're allowed try to load faster XS
+# versions of various things
+unless ($ENV{CLASS_MOP_NO_XS}) {
+    my $e = do {
+        local $@;
+        eval {
+            require XSLoader;
+            __PACKAGE__->XSLoader::load(our $VERSION);
+        };
+        $@;
+    };
+
+    die $e if $e && $e !~ /object version|loadable object/;
+}
 
 {
     # Metaclasses are singletons, so we cache them here.
diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm
index 2cff662..4b9e551 100644
--- a/lib/Class/MOP/Package.pm
+++ b/lib/Class/MOP/Package.pm
@@ -236,37 +236,30 @@ sub list_all_package_symbols {
     }
 }
 
-unless ( defined &get_all_package_symbols ) {
-    local $@;
-    eval q/
-    sub get_all_package_symbols {
-        my ($self, $type_filter) = @_;
-        my $namespace = $self->namespace;
-
-        return %$namespace unless defined $type_filter;
-
-        # for some reason this nasty impl is orders of magnitude aster than a clean version
-        if ( $type_filter eq 'CODE' ) {
-            my $pkg;
-            no strict 'refs';
-            return map {
-                (ref($namespace->{$_})
-                     ? ( $_ => \&{$pkg ||= $self->name . "::$_"} )
-                     : ( *{$namespace->{$_}}{CODE}
-                        ? ( $_ => *{$namespace->{$_}}{$type_filter} )
-                        : ()))
-            } keys %$namespace;
-        } else {
-            return map {
-                $_ => *{$namespace->{$_}}{$type_filter}
-            } grep {
-                !ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter}
-            } keys %$namespace;
-        }
-    }
+sub get_all_package_symbols {
+    my ($self, $type_filter) = @_;
+    my $namespace = $self->namespace;
 
-    1;
-    / || warn $@;
+    return %$namespace unless defined $type_filter;
+
+    # for some reason this nasty impl is orders of magnitude aster than a clean version
+    if ( $type_filter eq 'CODE' ) {
+        my $pkg;
+        no strict 'refs';
+        return map {
+            (ref($namespace->{$_})
+                ? ( $_ => \&{$pkg ||= $self->name . "::$_"} )
+                : ( *{$namespace->{$_}}{CODE}
+                    ? ( $_ => *{$namespace->{$_}}{$type_filter} )
+                    : ()))
+        } keys %$namespace;
+    } else {
+        return map {
+            $_ => *{$namespace->{$_}}{$type_filter}
+        } grep {
+            !ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter}
+        } keys %$namespace;
+    }
 }
 
 1;