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
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',
'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',
+);
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;
$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 );
{
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 ...
## ----------------------------------------------------------------------------
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
# 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'} }
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 {
## accessors
-sub body { (shift)->{'body'} }
-
sub associated_metaclass { shift->{'associated_metaclass'} }
sub attach_to_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;
# 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
}
}
-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__
+++ /dev/null
-BEGIN { $ENV{CLASS_MOP_NO_XS} = 1 }
-
projects / gitmo/Class-MOP.git / commitdiff