From: Dave Rolsky Date: Sun, 22 Feb 2009 03:37:25 +0000 (+0000) Subject: Remove all the pure Perl bits to go XS-only X-Git-Tag: 0.77_01~3 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=4bfa5ddbc8d54123eb64b0873f71a28b03064f9a;p=gitmo%2FClass-MOP.git Remove all the pure Perl bits to go XS-only --- diff --git a/Changes b/Changes index 46f2367..29b45b1 100644 --- 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 diff --git a/Makefile.PL b/Makefile.PL index 7cfceca..b3d28f2 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -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 ', - 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 ', + LICENSE => 'perl', +); diff --git a/lib/Class/MOP.pm b/lib/Class/MOP.pm index 5066d3d..fd4afd5 100644 --- a/lib/Class/MOP.pm +++ b/lib/Class/MOP.pm @@ -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 provides C, a much faster way to get all the subclasses of a certain class. -=item I - -Whether or not the running C is using its XS version. - =back =head2 Utility functions diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index 7637837..89d5703 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -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'} } diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index cfc27f4..cc615f9 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -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 { diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index 1a9dc99..515f8c7 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -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; diff --git a/lib/Class/MOP/Package.pm b/lib/Class/MOP/Package.pm index 66faca3..43e42f9 100644 --- a/lib/Class/MOP/Package.pm +++ b/lib/Class/MOP/Package.pm @@ -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 index 3f6d438..0000000 --- a/t/header_pp.inc +++ /dev/null @@ -1,2 +0,0 @@ -BEGIN { $ENV{CLASS_MOP_NO_XS} = 1 } -