Remove all the pure Perl bits to go XS-only
Dave Rolsky [Sun, 22 Feb 2009 03:37:25 +0000 (03:37 +0000)]
Changes
Makefile.PL
lib/Class/MOP.pm
lib/Class/MOP/Attribute.pm
lib/Class/MOP/Class.pm
lib/Class/MOP/Method.pm
lib/Class/MOP/Package.pm
t/header_pp.inc [deleted file]

diff --git a/Changes b/Changes
index 46f2367..29b45b1 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,5 +1,11 @@
 Revision history for Perl extension Class-MOP.
 
+0.78
+    * Everything
+      - This package now requires its XS components. Not using
+        Sub::Name lead to different behavior and bugginess in the pure
+        Perl version of the code.
+
 0.77 Sat, February 14, 2009
     * MOP.xs
       - Avoid assertion errors on debugging perls in is_class_loaded
index 7cfceca..b3d28f2 100644 (file)
@@ -9,21 +9,6 @@ use File::Spec;
 
 use 5.008;
 
-# If undefined, try our best, if true, require XS, if false, never do
-# XS
-my $force_xs;
-
-for (@ARGV) {
-    /^--pm/ and $force_xs = 0;
-    /^--xs/ and $force_xs = 1;
-}
-
-our $has_compiler = $force_xs;
-unless ( defined $force_xs ) {
-    $has_compiler = check_for_compiler()
-        or no_cc();
-}
-
 my %prereqs = (
     'Scalar::Util'             => '1.18',
     'Sub::Name'                => '0.04',
@@ -38,132 +23,14 @@ my %prereqs = (
     'B'                        => '0',
 );
 
-delete @prereqs{qw(Sub::Name Devel::GlobalDestruction)}
-    unless $has_compiler;
-
-write_makefile();
-
-sub write_makefile {
-    my $ccflags = -d '.svn' || $ENV{MAINTAINER_MODE} ? '-Wall' : '';
-
-    WriteMakefile(
-        VERSION_FROM  => 'lib/Class/MOP.pm',
-        NAME          => 'Class::MOP',
-        PREREQ_PM     => \%prereqs,
-        CONFIGURE     => \&init,
-        CCFLAGS       => $ccflags,
-        clean         => { FILES => 'test.c test.o t/pp*' },
-        ABSTRACT_FROM => 'lib/Class/MOP.pm',
-        AUTHOR        => 'Stevan Little <stevan@iinteractive.com>',
-        LICENSE       => 'perl',
-    );
-}
-
-sub no_cc {
-    print <<'EOF';
-
- I cannot determine if you have a C compiler
- so I will install a perl-only implementation
-
- You can force installation of the XS version with
-
-    perl Makefile.PL --xs
-
-EOF
-}
-
-sub check_for_compiler {
-    print "Testing if you have a C compiler\n";
-
-    eval { require ExtUtils::CBuilder };
-    if ($@) {
-        return _check_for_compiler_manually();
-    }
-    else {
-        return _check_for_compiler_with_cbuilder();
-    }
-}
-
-sub _check_for_compiler_with_cbuilder {
-    my $cb = ExtUtils::CBuilder->new( quiet => 1 );
-
-    return $cb->have_compiler();
-}
-
-sub _check_for_compiler_manually {
-    unless ( open F, '>', 'test.c' ) {
-        warn
-            "Cannot write test.c, skipping test compilation and installing pure Perl version.\n";
-        return 0;
-    }
-
-    print F <<'EOF';
-int main() { return 0; }
-EOF
-
-    close F or return 0;
+my $ccflags = -d '.svn' || -d '.git' || $ENV{MAINTAINER_MODE} ? '-Wall' : '';
 
-    my $cc = $Config{cc};
-    if ( $cc =~ /cl(\.exe)?$/ ) {
-
-        # stupid stupid MSVC compiler hack tacken from version.pm's
-        # Makefile.PL
-        $cc .= ' -c';    # prevent it from calling the linker
-    }
-
-    system("$cc -o test$Config{obj_ext} test.c") and return 0;
-
-    unlink $_ for grep {-f} 'test.c', "test$Config{obj_ext}";
-
-    return 1;
-}
-
-# This sucks, but it's the best guess we can make. Since we just use
-# it to run two sets of tests, it's not big deal if it ends up true
-# for a non-maintainer.
-sub is_maintainer {
-    return 0 if $ENV{PERL5_CPAN_IS_RUNNING} || $ENV{PERL5_CPANPLUS_IS_RUNNING};
-
-    return 1;
-}
-
-sub get_pp_tests {
-    opendir my $dh, 't' or die "Cannot read t: $!";
-
-    return grep { $_ !~ /^99/ } grep {/^\d.+\.t$/} readdir $dh;
-}
-
-# This is EUMM voodoo
-sub init {
-    my $hash = $_[1];
-
-    unless ($has_compiler) {
-        @{$hash}{ 'XS', 'C' } = ( {}, [] );
-    }
-
-    $hash;
-}
-
-package MY;
-
-sub postamble {
-    my @test_files = ::get_pp_tests();
-    my $pp_tests = join q{ }, map { File::Spec->catfile('t', "pp_${_}") } @test_files;
-    my @pp_test_targets = join qq{\n}, map {
-        my $source = File::Spec->catfile('t', ${_});
-        File::Spec->catfile('t', "pp_${_}") . q{: }
-        . qq{$source t/header_pp.inc\n\t}
-        . q{$(NOECHO) $(ABSPERLRUN) "-MExtUtils::Command" -e cat t/header_pp.inc }
-        . $source . q{ > $@} . qq{\n}
-    } @test_files;
-    my $test_dep = $::has_compiler && (::is_maintainer() || $ENV{AUTOMATED_TESTING})
-        ? qq{pure_all :: pp_tests\n} . join qq{\n}, @pp_test_targets
-        : '';
-
-    return <<"EOM"
-pp_tests: ${pp_tests}
-
-${test_dep}
-
-EOM
-}
+WriteMakefile(
+    VERSION_FROM  => 'lib/Class/MOP.pm',
+    NAME          => 'Class::MOP',
+    PREREQ_PM     => \%prereqs,
+    CCFLAGS       => $ccflags,
+    ABSTRACT_FROM => 'lib/Class/MOP.pm',
+    AUTHOR        => 'Stevan Little <stevan@iinteractive.com>',
+    LICENSE       => 'perl',
+);
index 5066d3d..fd4afd5 100644 (file)
@@ -9,8 +9,9 @@ use 5.008;
 use MRO::Compat;
 
 use Carp          'confess';
+use Devel::GlobalDestruction qw( in_global_destruction );
 use Scalar::Util  'weaken', 'reftype';
-
+use Sub::Name qw( subname );
 
 use Class::MOP::Class;
 use Class::MOP::Attribute;
@@ -36,45 +37,8 @@ our $XS_VERSION = $VERSION;
 $VERSION = eval $VERSION;
 our $AUTHORITY = 'cpan:STEVAN';    
 
-_try_load_xs() or _load_pure_perl();
-
-sub _try_load_xs {
-    return if $ENV{CLASS_MOP_NO_XS};
-
-    my $e = do {
-        local $@;
-        eval {
-            require XSLoader;
-            # just doing this - no warnings 'redefine' - doesn't work
-            # for some reason
-            local $^W = 0;
-            __PACKAGE__->XSLoader::load($XS_VERSION);
-
-            require Sub::Name;
-            Sub::Name->import(qw(subname));
-
-            require Devel::GlobalDestruction;
-            Devel::GlobalDestruction->import("in_global_destruction");
-
-            *USING_XS = sub () { 1 };
-        };
-        $@;
-    };
-
-    die $e if $e && $e !~ /object version|loadable object/;
-
-    return $e ? 0 : 1;
-}
-
-sub _load_pure_perl {
-    require Sub::Identify;
-    Sub::Identify->import('get_code_info');
-
-    *subname = sub { $_[1] };
-    *in_global_destruction = sub () { !1 };
-
-    *USING_XS = sub () { 0 };
-}
+require XSLoader;
+XSLoader::load( __PACKAGE__, $XS_VERSION );
 
 
 {
@@ -172,55 +136,6 @@ sub _is_valid_class_name {
     return 0;
 }
 
-sub is_class_loaded {
-    my $class = shift;
-
-    return 0 unless _is_valid_class_name($class);
-
-    # walk the symbol table tree to avoid autovififying
-    # \*{${main::}{"Foo::"}} == \*main::Foo::
-
-    my $pack = \*::;
-    foreach my $part (split('::', $class)) {
-        return 0 unless exists ${$$pack}{"${part}::"};
-        $pack = \*{${$$pack}{"${part}::"}};
-    }
-
-    # We used to check in the package stash, but it turns out that
-    # *{${$$package}{VERSION}{SCALAR}} can end up pointing to a
-    # reference to undef. It looks
-
-    my $version = do {
-        no strict 'refs';
-        ${$class . '::VERSION'};
-    };
-
-    return 1 if ! ref $version && defined $version;
-    # Sometimes $VERSION ends up as a reference to undef (weird)
-    return 1 if ref $version && reftype $version eq 'SCALAR' && defined ${$version};
-
-    return 1 if exists ${$$pack}{ISA}
-             && defined *{${$$pack}{ISA}}{ARRAY};
-
-    # check for any method
-    foreach ( keys %{$$pack} ) {
-        next if substr($_, -2, 2) eq '::';
-
-        my $glob = ${$$pack}{$_} || next;
-
-        # constant subs
-        if ( IS_RUNNING_ON_5_10 ) {
-            return 1 if ref $glob eq 'SCALAR';
-        }
-
-        return 1 if defined *{$glob}{CODE};
-    }
-
-    # fail
-    return 0;
-}
-
-
 ## ----------------------------------------------------------------------------
 ## Setting up our environment ...
 ## ----------------------------------------------------------------------------
@@ -915,10 +830,6 @@ compat.
 Whether or not C<mro> provides C<get_isarev>, a much faster way to get all the
 subclasses of a certain class.
 
-=item I<USING_XS>
-
-Whether or not the running C<Class::MOP> is using its XS version.
-
 =back
 
 =head2 Utility functions
index 7637837..89d5703 100644 (file)
@@ -151,8 +151,6 @@ sub _set_initial_slot_value {
 # the next bunch of methods will get bootstrapped
 # away in the Class::MOP bootstrapping section
 
-sub name { $_[0]->{'name'} }
-
 sub associated_class   { $_[0]->{'associated_class'}   }
 sub associated_methods { $_[0]->{'associated_methods'} }
 
index cfc27f4..cc615f9 100644 (file)
@@ -320,57 +320,6 @@ sub method_metaclass         { $_[0]->{'method_metaclass'}            }
 sub wrapped_method_metaclass { $_[0]->{'wrapped_method_metaclass'}    }
 sub instance_metaclass       { $_[0]->{'instance_metaclass'}          }
 
-sub get_method_map {
-    my $self = shift;
-
-    my $class_name = $self->name;
-
-    my $current = Class::MOP::check_package_cache_flag($class_name);
-
-    if (defined $self->{'_package_cache_flag'} && $self->{'_package_cache_flag'} == $current) {
-        return $self->{'methods'} ||= {};
-    }
-
-    $self->{_package_cache_flag} = $current;
-
-    my $map = $self->{'methods'} ||= {};
-
-    my $method_metaclass = $self->method_metaclass;
-
-    my $all_code = $self->get_all_package_symbols('CODE');
-
-    foreach my $symbol (keys %{ $all_code }) {
-        my $code = $all_code->{$symbol};
-
-        next if exists  $map->{$symbol} &&
-                defined $map->{$symbol} &&
-                        $map->{$symbol}->body == $code;
-
-        my ($pkg, $name) = Class::MOP::get_code_info($code);
-        
-        # NOTE:
-        # in 5.10 constant.pm the constants show up 
-        # as being in the right package, but in pre-5.10
-        # they show up as constant::__ANON__ so we 
-        # make an exception here to be sure that things
-        # work as expected in both.
-        # - SL
-        unless ($pkg eq 'constant' && $name eq '__ANON__') {
-            next if ($pkg  || '') ne $class_name ||
-                    (($name || '') ne '__ANON__' && ($pkg  || '') ne $class_name);
-        }
-
-        $map->{$symbol} = $method_metaclass->wrap(
-            $code,
-            associated_metaclass => $self,
-            package_name         => $class_name,
-            name                 => $symbol,
-        );
-    }
-
-    return $map;
-}
-
 # Instance Construction & Cloning
 
 sub new_object {
index 1a9dc99..515f8c7 100644 (file)
@@ -64,8 +64,6 @@ sub _new {
 
 ## accessors
 
-sub body { (shift)->{'body'} }
-
 sub associated_metaclass { shift->{'associated_metaclass'} }
 
 sub attach_to_class {
@@ -79,10 +77,6 @@ sub detach_from_class {
     delete $self->{associated_metaclass};
 }
 
-sub package_name { (shift)->{'package_name'} }
-
-sub name { (shift)->{'name'} }
-
 sub fully_qualified_name {
     my $self = shift;
     $self->package_name . '::' . $self->name;
index 66faca3..43e42f9 100644 (file)
@@ -79,7 +79,6 @@ sub _new {
 # all these attribute readers will be bootstrapped 
 # away in the Class::MOP bootstrap section
 
-sub name      { $_[0]->{'package'} }
 sub namespace { 
     # NOTE:
     # because of issues with the Perl API 
@@ -276,45 +275,6 @@ sub list_all_package_symbols {
     }
 }
 
-sub get_all_package_symbols {
-    my ($self, $type_filter) = @_;
-
-    die "Cannot call get_all_package_symbols as a class method"
-        unless ref $self;
-
-    my $namespace = $self->namespace;
-
-    return $namespace unless defined $type_filter;
-
-    my %ret;
-    # for some reason this nasty impl is orders of magnitude faster than a clean version
-    if ( $type_filter eq 'CODE' ) {
-        my $pkg;
-        no strict 'refs';
-        %ret = map {
-            (ref($namespace->{$_})
-                ? ( $_ => \&{$pkg ||= $self->name . "::$_"} )
-                : ( ref \$namespace->{$_} eq 'GLOB' # don't use {CODE} unless it's really a glob to prevent stringification of stubs
-                    && (*{$namespace->{$_}}{CODE})  # the extra parents prevent breakage on 5.8.2
-                    ? ( $_ => *{$namespace->{$_}}{CODE} )
-                    : (do {
-                        my $sym = B::svref_2object(\$namespace->{$_});
-                        my $svt = ref $sym if $sym;
-                        ($sym && ($svt eq 'B::PV' || $svt eq 'B::IV'))
-                            ? ($_ => ($pkg ||= $self->name)->can($_))
-                            : () }) ) )
-        } keys %$namespace;
-    } else {
-        %ret = map {
-            $_ => *{$namespace->{$_}}{$type_filter}
-        } grep {
-            !ref($namespace->{$_}) && *{$namespace->{$_}}{$type_filter}
-        } keys %$namespace;
-    }
-
-    return \%ret;
-}
-
 1;
 
 __END__
diff --git a/t/header_pp.inc b/t/header_pp.inc
deleted file mode 100644 (file)
index 3f6d438..0000000
+++ /dev/null
@@ -1,2 +0,0 @@
-BEGIN { $ENV{CLASS_MOP_NO_XS} = 1 }
-