Class-C3-XS-0.13/0000711000175000017500000000000011256666750011735 5ustar raflraflClass-C3-XS-0.13/inc/0000711000175000017500000000000011256666747012514 5ustar raflraflClass-C3-XS-0.13/inc/Module/0000711000175000017500000000000011256666747013741 5ustar raflraflClass-C3-XS-0.13/inc/Module/Install/0000711000175000017500000000000011256666750015341 5ustar raflraflClass-C3-XS-0.13/inc/Module/Install/Can.pm0000644000175000017500000000333311256666646016416 0ustar raflrafl#line 1 package Module::Install::Can; use strict; use Config (); use File::Spec (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # check if we can load some module ### Upgrade this to not have to load the module if possible sub can_use { my ($self, $mod, $ver) = @_; $mod =~ s{::|\\}{/}g; $mod .= '.pm' unless $mod =~ /\.pm$/i; my $pkg = $mod; $pkg =~ s{/}{::}g; $pkg =~ s{\.pm$}{}i; local $@; eval { require $mod; $pkg->VERSION($ver || 0); 1 }; } # check if we can run some command sub can_run { my ($self, $cmd) = @_; my $_cmd = $cmd; return $_cmd if (-x $_cmd or $_cmd = MM->maybe_command($_cmd)); for my $dir ((split /$Config::Config{path_sep}/, $ENV{PATH}), '.') { next if $dir eq ''; my $abs = File::Spec->catfile($dir, $_[1]); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # can we locate a (the) C compiler sub can_cc { my $self = shift; my @chunks = split(/ /, $Config::Config{cc}) or return; # $Config{cc} may contain args; try to find out the program part while (@chunks) { return $self->can_run("@chunks") || (pop(@chunks), next); } return; } # Fix Cygwin bug on maybe_command(); if ( $^O eq 'cygwin' ) { require ExtUtils::MM_Cygwin; require ExtUtils::MM_Win32; if ( ! defined(&ExtUtils::MM_Cygwin::maybe_command) ) { *ExtUtils::MM_Cygwin::maybe_command = sub { my ($self, $file) = @_; if ($file =~ m{^/cygdrive/}i and ExtUtils::MM_Win32->can('maybe_command')) { ExtUtils::MM_Win32->maybe_command($file); } else { ExtUtils::MM_Unix->maybe_command($file); } } } } 1; __END__ #line 156 Class-C3-XS-0.13/inc/Module/Install/WriteAll.pm0000644000175000017500000000222211256666646017434 0ustar raflrafl#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91';; @ISA = qw{Module::Install::Base}; $ISCORE = 1; } sub WriteAll { my $self = shift; my %args = ( meta => 1, sign => 0, inline => 0, check_nmake => 1, @_, ); $self->sign(1) if $args{sign}; $self->admin->WriteAll(%args) if $self->is_admin; $self->check_nmake if $args{check_nmake}; unless ( $self->makemaker_args->{PL_FILES} ) { $self->makemaker_args( PL_FILES => {} ); } # Until ExtUtils::MakeMaker support MYMETA.yml, make sure # we clean it up properly ourself. $self->realclean_files('MYMETA.yml'); if ( $args{inline} ) { $self->Inline->write; } else { $self->Makefile->write; } # The Makefile write process adds a couple of dependencies, # so write the META.yml files after the Makefile. if ( $args{meta} ) { $self->Meta->write; } # Experimental support for MYMETA if ( $ENV{X_MYMETA} ) { if ( $ENV{X_MYMETA} eq 'JSON' ) { $self->Meta->write_mymeta_json; } else { $self->Meta->write_mymeta_yaml; } } return 1; } 1; Class-C3-XS-0.13/inc/Module/Install/Makefile.pm0000644000175000017500000001600311256666646017430 0ustar raflrafl#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub Makefile { $_[0] } my %seen = (); sub prompt { shift; # Infinite loop protection my @c = caller(); if ( ++$seen{"$c[1]|$c[2]|$_[0]"} > 3 ) { die "Caught an potential prompt infinite loop ($c[1]|$c[2]|$_[0])"; } # In automated testing, always use defaults if ( $ENV{AUTOMATED_TESTING} and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } sub makemaker_args { my $self = shift; my $args = ( $self->{makemaker_args} ||= {} ); %$args = ( %$args, @_ ); return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = sShift; my $name = shift; my $args = $self->makemaker_args; $args->{name} = defined $args->{$name} ? join( ' ', $args->{name}, @_ ) : join( ' ', @_ ); } sub build_subdirs { my $self = shift; my $subdirs = $self->makemaker_args->{DIR} ||= []; for my $subdir (@_) { push @$subdirs, $subdir; } } sub clean_files { my $self = shift; my $clean = $self->makemaker_args->{clean} ||= {}; %$clean = ( %$clean, FILES => join ' ', grep { length $_ } ($clean->{FILES} || (), @_), ); } sub realclean_files { my $self = shift; my $realclean = $self->makemaker_args->{realclean} ||= {}; %$realclean = ( %$realclean, FILES => join ' ', grep { length $_ } ($realclean->{FILES} || (), @_), ); } sub libs { my $self = shift; my $libs = ref $_[0] ? shift : [ shift ]; $self->makemaker_args( LIBS => $libs ); } sub inc { my $self = shift; $self->makemaker_args( INC => shift ); } my %test_dir = (); sub _wanted_t { /\.t$/ and -f $_ and $test_dir{$File::Find::dir} = 1; } sub tests_recursive { my $self = shift; if ( $self->tests ) { die "tests_recursive will not work if tests are already defined"; } my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } %test_dir = (); require File::Find; File::Find::find( \&_wanted_t, $dir ); $self->tests( join ' ', map { "$_/*.t" } sort keys %test_dir ); } sub write { my $self = shift; die "&Makefile->write() takes no arguments\n" if @_; # Check the current Perl version my $perl_version = $self->perl_version; if ( $perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } # Make sure we have a new enough MakeMaker require ExtUtils::MakeMaker; if ( $perl_version and $self->_cmp($perl_version, '5.006') >= 0 ) { # MakeMaker can complain about module versions that include # an underscore, even though its own version may contain one! # Hence the funny regexp to get rid of it. See RT #35800 # for details. $self->build_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); $self->configure_requires( 'ExtUtils::MakeMaker' => $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/ ); } else { # Allow legacy-compatibility with 5.005 by depending on the # most recent EU:MM that supported 5.005. $self->build_requires( 'ExtUtils::MakeMaker' => 6.42 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.42 ); } # Generate the MakeMaker params my $args = $self->makemaker_args; $args->{DISTNAME} = $self->name; $args->{NAME} = $self->module_name || $self->name; $args->{VERSION} = $self->version; $args->{NAME} =~ s/-/::/g; if ( $self->tests ) { $args->{test} = { TESTS => $self->tests }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = $self->author; } if ( eval($ExtUtils::MakeMaker::VERSION) >= 6.10 ) { $args->{NO_META} = 1; } if ( eval($ExtUtils::MakeMaker::VERSION) > 6.17 and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } # Merge both kinds of requires into prereq_pm my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } map { @$_ } grep $_, ($self->configure_requires, $self->build_requires, $self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # merge both kinds of requires into prereq_pm my $subdirs = ($args->{DIR} ||= []); if ($self->bundles) { foreach my $bundle (@{ $self->bundles }) { my ($file, $dir) = @$bundle; push @$subdirs, $dir if -d $dir; delete $prereq->{$file}; } } if ( my $perl_version = $self->perl_version ) { eval "use $perl_version; 1" or die "ERROR: perl: Version $] is installed, " . "but we need version >= $perl_version"; } $args->{INSTALLDIRS} = $self->installdirs; my %args = map { ( $_ => $args->{$_} ) } grep {defined($args->{$_})} keys %$args; my $user_preop = delete $args{dist}->{PREOP}; if (my $preop = $self->admin->preop($user_preop)) { foreach my $key ( keys %$preop ) { $args{dist}->{$key} = $preop->{$key}; } } my $mm = ExtUtils::MakeMaker::WriteMakefile(%args); $self->fix_up_makefile($mm->{FIRST_MAKEFILE} || 'Makefile'); } sub fix_up_makefile { my $self = shift; my $makefile_name = shift; my $top_class = ref($self->_top) || ''; my $top_version = $self->_top->VERSION || ''; my $preamble = $self->preamble ? "# Preamble by $top_class $top_version\n" . $self->preamble : ''; my $postamble = "# Postamble by $top_class $top_version\n" . ($self->postamble || ''); local *MAKEFILE; open MAKEFILE, "< $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; my $makefile = do { local $/; }; close MAKEFILE or die $!; $makefile =~ s/\b(test_harness\(\$\(TEST_VERBOSE\), )/$1'inc', /; $makefile =~ s/( -I\$\(INST_ARCHLIB\))/ -Iinc$1/g; $makefile =~ s/( "-I\$\(INST_LIB\)")/ "-Iinc"$1/g; $makefile =~ s/^(FULLPERL = .*)/$1 "-Iinc"/m; $makefile =~ s/^(PERL = .*)/$1 "-Iinc"/m; # Module::Install will never be used to build the Core Perl # Sometimes PERL_LIB and PERL_ARCHLIB get written anyway, which breaks # PREFIX/PERL5LIB, and thus, install_share. Blank them if they exist $makefile =~ s/^PERL_LIB = .+/PERL_LIB =/m; #$makefile =~ s/^PERL_ARCHLIB = .+/PERL_ARCHLIB =/m; # Perl 5.005 mentions PERL_LIB explicitly, so we have to remove that as well. $makefile =~ s/(\"?)-I\$\(PERL_LIB\)\1//g; # XXX - This is currently unused; not sure if it breaks other MM-users # $makefile =~ s/^pm_to_blib\s+:\s+/pm_to_blib :: /mg; open MAKEFILE, "> $makefile_name" or die "fix_up_makefile: Couldn't open $makefile_name: $!"; print MAKEFILE "$preamble$makefile$postamble" or die $!; close MAKEFILE or die $!; 1; } sub preamble { my ($self, $text) = @_; $self->{preamble} = $text . $self->{preamble} if defined $text; $self->{preamble}; } sub postamble { my ($self, $text) = @_; $self->{postamble} ||= $self->admin->postamble; $self->{postamble} .= $text if defined $text; $self->{postamble} } 1; __END__ #line 394 Class-C3-XS-0.13/inc/Module/Install/Metadata.pm0000644000175000017500000003530411256666645017437 0ustar raflrafl#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract author version distribution_type tests installdirs }; my @tuple_keys = qw{ configure_requires build_requires requires recommends bundles resources }; my @resource_keys = qw{ homepage bugtracker repository }; my @array_keys = qw{ keywords }; sub Meta { shift } sub Meta_BooleanKeys { @boolean_keys } sub Meta_ScalarKeys { @scalar_keys } sub Meta_TupleKeys { @tuple_keys } sub Meta_ResourceKeys { @resource_keys } sub Meta_ArrayKeys { @array_keys } foreach my $key ( @boolean_keys ) { *$key = sub { my $self = shift; if ( defined wantarray and not @_ ) { return $self->{values}->{$key}; } $self->{values}->{$key} = ( @_ ? $_[0] : 1 ); return $self; }; } foreach my $key ( @scalar_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} = shift; return $self; }; } foreach my $key ( @array_keys ) { *$key = sub { my $self = shift; return $self->{values}->{$key} if defined wantarray and !@_; $self->{values}->{$key} ||= []; push @{$self->{values}->{$key}}, @_; return $self; }; } foreach my $key ( @resource_keys ) { *$key = sub { my $self = shift; unless ( @_ ) { return () unless $self->{values}->{resources}; return map { $_->[1] } grep { $_->[0] eq $key } @{ $self->{values}->{resources} }; } return $self->{values}->{resources}->{$key} unless @_; my $uri = shift or die( "Did not provide a value to $key()" ); $self->resources( $key => $uri ); return 1; }; } foreach my $key ( grep { $_ ne "resources" } @tuple_keys) { *$key = sub { my $self = shift; return $self->{values}->{$key} unless @_; my @added; while ( @_ ) { my $module = shift or last; my $version = shift || 0; push @added, [ $module, $version ]; } push @{ $self->{values}->{$key} }, @added; return map {@$_} @added; }; } # Resource handling my %lc_resource = map { $_ => 1 } qw{ homepage license bugtracker repository }; sub resources { my $self = shift; while ( @_ ) { my $name = shift or last; my $value = shift or next; if ( $name eq lc $name and ! $lc_resource{$name} ) { die("Unsupported reserved lowercase resource '$name'"); } $self->{values}->{resources} ||= []; push @{ $self->{values}->{resources} }, [ $name, $value ]; } $self->{values}->{resources}; } # Aliases for build_requires that will have alternative # meanings in some future version of META.yml. sub test_requires { shift->build_requires(@_) } sub install_requires { shift->build_requires(@_) } # Aliases for installdirs options sub install_as_core { $_[0]->installdirs('perl') } sub install_as_cpan { $_[0]->installdirs('site') } sub install_as_site { $_[0]->installdirs('site') } sub install_as_vendor { $_[0]->installdirs('vendor') } sub dynamic_config { my $self = shift; unless ( @_ ) { warn "You MUST provide an explicit true/false value to dynamic_config\n"; return $self; } $self->{values}->{dynamic_config} = $_[0] ? 1 : 0; return 1; } sub perl_version { my $self = shift; return $self->{values}->{perl_version} unless @_; my $version = shift or die( "Did not provide a value to perl_version()" ); # Normalize the version $version = $self->_perl_version($version); # We don't support the reall old versions unless ( $version >= 5.005 ) { die "Module::Install only supports 5.005 or newer (use ExtUtils::MakeMaker)\n"; } $self->{values}->{perl_version} = $version; } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', artistic => 'http://opensource.org/licenses/artistic-license.php', artistic_2 => 'http://opensource.org/licenses/artistic-license-2.0.php', lgpl => 'http://opensource.org/licenses/lgpl-license.php', lgpl2 => 'http://opensource.org/licenses/lgpl-2.1.php', lgpl3 => 'http://opensource.org/licenses/lgpl-3.0.html', bsd => 'http://opensource.org/licenses/bsd-license.php', gpl => 'http://opensource.org/licenses/gpl-license.php', gpl2 => 'http://opensource.org/licenses/gpl-2.0.php', gpl3 => 'http://opensource.org/licenses/gpl-3.0.html', mit => 'http://opensource.org/licenses/mit-license.php', mozilla => 'http://opensource.org/licenses/mozilla1.1.php', open_source => undef, unrestricted => undef, restrictive => undef, unknown => undef, ); sub license { my $self = shift; return $self->{values}->{license} unless @_; my $license = shift or die( 'Did not provide a value to license()' ); $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub all_from { my ( $self, $file ) = @_; unless ( defined($file) ) { my $name = $self->name or die( "all_from called with no args without setting name() first" ); $file = join('/', 'lib', split(/-/, $name)) . '.pm'; $file =~ s{.*/}{} unless -e $file; unless ( -e $file ) { die("all_from cannot find $file from $name"); } } unless ( -f $file ) { die("The path '$file' does not exist, or is not a file"); } # Some methods pull from POD instead of code. # If there is a matching .pod, use that instead my $pod = $file; $pod =~ s/\.pm$/.pod/i; $pod = $file unless -e $pod; # Pull the different values $self->name_from($file) unless $self->name; $self->version_from($file) unless $self->version; $self->perl_version_from($file) unless $self->perl_version; $self->author_from($pod) unless $self->author; $self->license_from($pod) unless $self->license; $self->abstract_from($pod) unless $self->abstract; return 1; } sub provides { my $self = shift; my $provides = ( $self->{values}->{provides} ||= {} ); %$provides = (%$provides, @_) if @_; return $provides; } sub auto_provides { my $self = shift; return $self unless $self->is_admin; unless (-e 'MANIFEST') { warn "Cannot deduce auto_provides without a MANIFEST, skipping\n"; return $self; } # Avoid spurious warnings as we are not checking manifest here. local $SIG{__WARN__} = sub {1}; require ExtUtils::Manifest; local *ExtUtils::Manifest::manicheck = sub { return }; require Module::Build; my $build = Module::Build->new( dist_name => $self->name, dist_version => $self->version, license => $self->license, ); $self->provides( %{ $build->find_dist_packages || {} } ); } sub feature { my $self = shift; my $name = shift; my $features = ( $self->{values}->{features} ||= [] ); my $mods; if ( @_ == 1 and ref( $_[0] ) ) { # The user used ->feature like ->features by passing in the second # argument as a reference. Accomodate for that. $mods = $_[0]; } else { $mods = \@_; } my $count = 0; push @$features, ( $name => [ map { ref($_) ? ( ref($_) eq 'HASH' ) ? %$_ : @$_ : $_ } @$mods ] ); return @$features; } sub features { my $self = shift; while ( my ( $name, $mods ) = splice( @_, 0, 2 ) ) { $self->feature( $name, @$mods ); } return $self->{values}->{features} ? @{ $self->{values}->{features} } : (); } sub no_index { my $self = shift; my $type = shift; push @{ $self->{values}->{no_index}->{$type} }, @_ if $type; return $self->{values}->{no_index}; } sub read { my $self = shift; $self->include_deps( 'YAML::Tiny', 0 ); require YAML::Tiny; my $data = YAML::Tiny::LoadFile('META.yml'); # Call methods explicitly in case user has already set some values. while ( my ( $key, $value ) = each %$data ) { next unless $self->can($key); if ( ref $value eq 'HASH' ) { while ( my ( $module, $version ) = each %$value ) { $self->can($key)->($self, $module => $version ); } } else { $self->can($key)->($self, $value); } } return $self; } sub write { my $self = shift; return $self unless $self->is_admin; $self->admin->write_meta; return $self; } sub version_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->version( ExtUtils::MM_Unix->parse_version($file) ); } sub abstract_from { require ExtUtils::MM_Unix; my ( $self, $file ) = @_; $self->abstract( bless( { DISTNAME => $self->name }, 'ExtUtils::MM_Unix' )->parse_abstract($file) ); } # Add both distribution and module name sub name_from { my ($self, $file) = @_; if ( Module::Install::_read($file) =~ m/ ^ \s* package \s* ([\w:]+) \s* ; /ixms ) { my ($name, $module_name) = ($1, $1); $name =~ s{::}{-}g; $self->name($name); unless ( $self->module_name ) { $self->module_name($module_name); } } else { die("Cannot determine name from $file\n"); } } sub perl_version_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ^ (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; $self->perl_version($perl_version); } else { warn "Cannot determine perl version info from $_[0]\n"; return; } } sub author_from { my $self = shift; my $content = Module::Install::_read($_[0]); if ($content =~ m/ =head \d \s+ (?:authors?)\b \s* ([^\n]*) | =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b \s* .*? copyright .*? \d\d\d[\d.]+ \s* (?:\bby\b)? \s* ([^\n]*) /ixms) { my $author = $1 || $2; $author =~ s{E}{<}g; $author =~ s{E}{>}g; $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } sub license_from { my $self = shift; if ( Module::Install::_read($_[0]) =~ m/ ( =head \d \s+ (?:licen[cs]e|licensing|copyright|legal)\b .*? ) (=head\\d.*|=cut.*|) \z /ixms ) { my $license_text = $1; my @phrases = ( 'under the same (?:terms|license) as (?:perl|the perl programming language) itself' => 'perl', 1, 'GNU general public license' => 'gpl', 1, 'GNU public license' => 'gpl', 1, 'GNU lesser general public license' => 'lgpl', 1, 'GNU lesser public license' => 'lgpl', 1, 'GNU library general public license' => 'lgpl', 1, 'GNU library public license' => 'lgpl', 1, 'BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s{\s+}{\\s+}g; if ( $license_text =~ /\b$pattern\b/i ) { $self->license($license); return 1; } } } warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } sub _extract_bugtracker { my @links = $_[0] =~ m#L<(\Qhttp://rt.cpan.org/\E[^>]+)>#g; my %links; @links{@links}=(); @links=keys %links; return @links; } sub bugtracker_from { my $self = shift; my $content = Module::Install::_read($_[0]); my @links = _extract_bugtracker($content); unless ( @links ) { warn "Cannot determine bugtracker info from $_[0]\n"; return 0; } if ( @links > 1 ) { warn "Found more than on rt.cpan.org link in $_[0]\n"; return 0; } # Set the bugtracker bugtracker( $links[0] ); return 1; } sub requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->requires( $module => $version ); } } sub test_requires_from { my $self = shift; my $content = Module::Install::_readperl($_[0]); my @requires = $content =~ m/^use\s+([^\W\d]\w*(?:::\w+)*)\s+([\d\.]+)/mg; while ( @requires ) { my $module = shift @requires; my $version = shift @requires; $self->test_requires( $module => $version ); } } # Convert triple-part versions (eg, 5.6.1 or 5.8.9) to # numbers (eg, 5.006001 or 5.008009). # Also, convert double-part versions (eg, 5.8) sub _perl_version { my $v = $_[-1]; $v =~ s/^([1-9])\.([1-9]\d?\d?)$/sprintf("%d.%03d",$1,$2)/e; $v =~ s/^([1-9])\.([1-9]\d?\d?)\.(0|[1-9]\d?\d?)$/sprintf("%d.%03d%03d",$1,$2,$3 || 0)/e; $v =~ s/(\.\d\d\d)000$/$1/; $v =~ s/_.+$//; if ( ref($v) ) { # Numify $v = $v + 0; } return $v; } ###################################################################### # MYMETA Support sub WriteMyMeta { die "WriteMyMeta has been deprecated"; } sub write_mymeta_yaml { my $self = shift; # We need YAML::Tiny to write the MYMETA.yml file unless ( eval { require YAML::Tiny; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.yml\n"; YAML::Tiny::DumpFile('MYMETA.yml', $meta); } sub write_mymeta_json { my $self = shift; # We need JSON to write the MYMETA.json file unless ( eval { require JSON; 1; } ) { return 1; } # Generate the data my $meta = $self->_write_mymeta_data or return 1; # Save as the MYMETA.yml file print "Writing MYMETA.json\n"; Module::Install::_write( 'MYMETA.json', JSON->new->pretty(1)->canonical->encode($meta), ); } sub _write_mymeta_data { my $self = shift; # If there's no existing META.yml there is nothing we can do return undef unless -f 'META.yml'; # We need Parse::CPAN::Meta to load the file unless ( eval { require Parse::CPAN::Meta; 1; } ) { return undef; } # Merge the perl version into the dependencies my $val = $self->Meta->{values}; my $perl = delete $val->{perl_version}; if ( $perl ) { $val->{requires} ||= []; my $requires = $val->{requires}; # Canonize to three-dot version after Perl 5.6 if ( $perl >= 5.006 ) { $perl =~ s{^(\d+)\.(\d\d\d)(\d*)}{join('.', $1, int($2||0), int($3||0))}e } unshift @$requires, [ perl => $perl ]; } # Load the advisory META.yml file my @yaml = Parse::CPAN::Meta::LoadFile('META.yml'); my $meta = $yaml[0]; # Overwrite the non-configure dependency hashs delete $meta->{requires}; delete $meta->{build_requires}; delete $meta->{recommends}; if ( exists $val->{requires} ) { $meta->{requires} = { map { @$_ } @{ $val->{requires} } }; } if ( exists $val->{build_requires} ) { $meta->{build_requires} = { map { @$_ } @{ $val->{build_requires} } }; } return $meta; } 1; Class-C3-XS-0.13/inc/Module/Install/Base.pm0000644000175000017500000000176611256666645016576 0ustar raflrafl#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '0.91'; } # Suspend handler for "redefined" warnings BEGIN { my $w = $SIG{__WARN__}; $SIG{__WARN__} = sub { $w }; } #line 42 sub new { my $class = shift; unless ( defined &{"${class}::call"} ) { *{"${class}::call"} = sub { shift->_top->call(@_) }; } unless ( defined &{"${class}::load"} ) { *{"${class}::load"} = sub { shift->_top->load(@_) }; } bless { @_ }, $class; } #line 61 sub AUTOLOAD { local $@; my $func = eval { shift->_top->autoload } or return; goto &$func; } #line 75 sub _top { $_[0]->{_top}; } #line 90 sub admin { $_[0]->_top->{admin} or Module::Install::Base::FakeAdmin->new; } #line 106 sub is_admin { $_[0]->admin->VERSION; } sub DESTROY {} package Module::Install::Base::FakeAdmin; my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 154 Class-C3-XS-0.13/inc/Module/Install/Fetch.pm0000644000175000017500000000462711256666646016755 0ustar raflrafl#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } sub get_file { my ($self, %args) = @_; my ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; if ( $scheme eq 'http' and ! eval { require LWP::Simple; 1 } ) { $args{url} = $args{ftp_url} or (warn("LWP support unavailable!\n"), return); ($scheme, $host, $path, $file) = $args{url} =~ m|^(\w+)://([^/]+)(.+)/(.+)| or return; } $|++; print "Fetching '$file' from $host... "; unless (eval { require Socket; Socket::inet_aton($host) }) { warn "'$host' resolve failed!\n"; return; } return unless $scheme eq 'ftp' or $scheme eq 'http'; require Cwd; my $dir = Cwd::getcwd(); chdir $args{local_dir} or return if exists $args{local_dir}; if (eval { require LWP::Simple; 1 }) { LWP::Simple::mirror($args{url}, $file); } elsif (eval { require Net::FTP; 1 }) { eval { # use Net::FTP to get past firewall my $ftp = Net::FTP->new($host, Passive => 1, Timeout => 600); $ftp->login("anonymous", 'anonymous@example.com'); $ftp->cwd($path); $ftp->binary; $ftp->get($file) or (warn("$!\n"), return); $ftp->quit; } } elsif (my $ftp = $self->can_run('ftp')) { eval { # no Net::FTP, fallback to ftp.exe require FileHandle; my $fh = FileHandle->new; local $SIG{CHLD} = 'IGNORE'; unless ($fh->open("|$ftp -n")) { warn "Couldn't open ftp: $!\n"; chdir $dir; return; } my @dialog = split(/\n/, <<"END_FTP"); open $host user anonymous anonymous\@example.com cd $path binary get $file $file quit END_FTP foreach (@dialog) { $fh->print("$_\n") } $fh->close; } } else { warn "No working 'ftp' program available!\n"; chdir $dir; return; } unless (-f $file) { warn "Fetching failed: $@\n"; chdir $dir; return; } return if exists $args{size} and -s $file != $args{size}; system($args{run}) if exists $args{run}; unlink($file) if $args{remove}; print(((!exists $args{check_for} or -e $args{check_for}) ? "done!" : "failed! ($!)"), "\n"); chdir $dir; return !$?; } 1; Class-C3-XS-0.13/inc/Module/Install/Win32.pm0000644000175000017500000000340311256666646016615 0ustar raflrafl#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '0.91'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } # determine if the user needs nmake, and download it if needed sub check_nmake { my $self = shift; $self->load('can_run'); $self->load('get_file'); require Config; return unless ( $^O eq 'MSWin32' and $Config::Config{make} and $Config::Config{make} =~ /^nmake\b/i and ! $self->can_run('nmake') ); print "The required 'nmake' executable not found, fetching it...\n"; require File::Basename; my $rv = $self->get_file( url => 'http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe', ftp_url => 'ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe', local_dir => File::Basename::dirname($^X), size => 51928, run => 'Nmake15.exe /o > nul', check_for => 'Nmake.exe', remove => 1, ); die <<'END_MESSAGE' unless $rv; ------------------------------------------------------------------------------- Since you are using Microsoft Windows, you will need the 'nmake' utility before installation. It's available at: http://download.microsoft.com/download/vc15/Patch/1.52/W95/EN-US/Nmake15.exe or ftp://ftp.microsoft.com/Softlib/MSLFILES/Nmake15.exe Please download the file manually, save it to a directory in %PATH% (e.g. C:\WINDOWS\COMMAND\), then launch the MS-DOS command line shell, "cd" to that directory, and run "Nmake15.exe" from there; that will create the 'nmake.exe' file needed by this module. You may then resume the installation process described in README. ------------------------------------------------------------------------------- END_MESSAGE } 1; Class-C3-XS-0.13/inc/Module/Install.pm0000644000175000017500000002411411256666644015713 0ustar raflrafl#line 1 package Module::Install; # For any maintainers: # The load order for Module::Install is a bit magic. # It goes something like this... # # IF ( host has Module::Install installed, creating author mode ) { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to installed version of inc::Module::Install # 3. The installed version of inc::Module::Install loads # 4. inc::Module::Install calls "require Module::Install" # 5. The ./inc/ version of Module::Install loads # } ELSE { # 1. Makefile.PL calls "use inc::Module::Install" # 2. $INC{inc/Module/Install.pm} set to ./inc/ version of Module::Install # 3. The ./inc/ version of Module::Install loads # } use 5.005; use strict 'vars'; use vars qw{$VERSION $MAIN}; BEGIN { # All Module::Install core packages now require synchronised versions. # This will be used to ensure we don't accidentally load old or # different versions of modules. # This is not enforced yet, but will be some time in the next few # releases once we can make sure it won't clash with custom # Module::Install extensions. $VERSION = '0.91'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } # Whether or not inc::Module::Install is actually loaded, the # $INC{inc/Module/Install.pm} is what will still get set as long as # the caller loaded module this in the documented manner. # If not set, the caller may NOT have loaded the bundled version, and thus # they may not have a MI version that works with the Makefile.PL. This would # result in false errors or unexpected behaviour. And we don't want that. my $file = join( '/', 'inc', split /::/, __PACKAGE__ ) . '.pm'; unless ( $INC{$file} ) { die <<"END_DIE" } Please invoke ${\__PACKAGE__} with: use inc::${\__PACKAGE__}; not: use ${\__PACKAGE__}; END_DIE # If the script that is loading Module::Install is from the future, # then make will detect this and cause it to re-run over and over # again. This is bad. Rather than taking action to touch it (which # is unreliable on some platforms and requires write permissions) # for now we should catch this and refuse to run. if ( -f $0 ) { my $s = (stat($0))[9]; # If the modification time is only slightly in the future, # sleep briefly to remove the problem. my $a = $s - time; if ( $a > 0 and $a < 5 ) { sleep 5 } # Too far in the future, throw an error. my $t = time; if ( $s > $t ) { die <<"END_DIE" } Your installer $0 has a modification time in the future ($s > $t). This is known to create infinite loops in make. Please correct this, then run $0 again. END_DIE } # Build.PL was formerly supported, but no longer is due to excessive # difficulty in implementing every single feature twice. if ( $0 =~ /Build.PL$/i ) { die <<"END_DIE" } Module::Install no longer supports Build.PL. It was impossible to maintain duel backends, and has been deprecated. Please remove all Build.PL files and only use the Makefile.PL installer. END_DIE # To save some more typing in Module::Install installers, every... # use inc::Module::Install # ...also acts as an implicit use strict. $^H |= strict::bits(qw(refs subs vars)); use Cwd (); use File::Find (); use File::Path (); use FindBin; sub autoload { my $self = shift; my $who = $self->_caller; my $cwd = Cwd::cwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::cwd(); if ( my $code = $sym->{$pwd} ) { # Delegate back to parent dirs goto &$code unless $cwd eq $pwd; } $$sym =~ /([^:]+)$/ or die "Cannot autoload $who - $sym"; my $method = $1; if ( uc($method) eq $method ) { # Do nothing return; } elsif ( $method =~ /^_/ and $self->can($method) ) { # Dispatch to the root M:I class return $self->$method(@_); } # Dispatch to the appropriate plugin unshift @_, ( $self, $1 ); goto &{$self->can('call')}; }; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; unless ( -f $self->{file} ) { require "$self->{path}/$self->{dispatch}.pm"; File::Path::mkpath("$self->{prefix}/$self->{author}"); $self->{admin} = "$self->{name}::$self->{dispatch}"->new( _top => $self ); $self->{admin}->init; @_ = ($class, _self => $self); goto &{"$self->{name}::import"}; } *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{"$self->{file}"}; delete $INC{"$self->{path}.pm"}; # Save to the singleton $MAIN = $self; return 1; } sub preload { my $self = shift; unless ( $self->{extensions} ) { $self->load_extensions( "$self->{prefix}/$self->{path}", $self ); } my @exts = @{$self->{extensions}}; unless ( @exts ) { @exts = $self->{admin}->load_all_extensions; } my %seen; foreach my $obj ( @exts ) { while (my ($method, $glob) = each %{ref($obj) . '::'}) { next unless $obj->can($method); next if $method =~ /^_/; next if $method eq uc($method); $seen{$method}++; } } my $who = $self->_caller; foreach my $name ( sort keys %seen ) { *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; # ignore the prefix on extension modules built from top level. my $base_path = Cwd::abs_path($FindBin::Bin); unless ( Cwd::abs_path(Cwd::cwd()) eq $base_path ) { delete $args{prefix}; } return $args{_self} if $args{_self}; $args{dispatch} ||= 'Admin'; $args{prefix} ||= 'inc'; $args{author} ||= ($^O eq 'VMS' ? '_author' : '.author'); $args{bundle} ||= 'inc/BUNDLES'; $args{base} ||= $base_path; $class =~ s/^\Q$args{prefix}\E:://; $args{name} ||= $class; $args{version} ||= $class->VERSION; unless ( $args{path} ) { $args{path} = $args{name}; $args{path} =~ s!::!/!g; } $args{file} ||= "$args{base}/$args{prefix}/$args{path}.pm"; $args{wrote} = 0; bless( \%args, $class ); } sub call { my ($self, $method) = @_; my $obj = $self->load($method) or return; splice(@_, 0, 2, $obj); goto &{$obj->can($method)}; } sub load { my ($self, $method) = @_; $self->load_extensions( "$self->{prefix}/$self->{path}", $self ) unless $self->{extensions}; foreach my $obj (@{$self->{extensions}}) { return $obj if $obj->can($method); } my $admin = $self->{admin} or die <<"END_DIE"; The '$method' method does not exist in the '$self->{prefix}' path! Please remove the '$self->{prefix}' directory and run $0 again to load it. END_DIE my $obj = $admin->load($method, 1); push @{$self->{extensions}}, $obj; $obj; } sub load_extensions { my ($self, $path, $top) = @_; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = delete $INC{$file}; push @{$self->{extensions}}, &{$new}($pkg, _top => $top ); } $self->{extensions} ||= []; } sub find_extensions { my ($self, $path) = @_; my @found; File::Find::find( sub { my $file = $File::Find::name; return unless $file =~ m!^\Q$path\E/(.+)\.pm\Z!is; my $subpath = $1; return if lc($subpath) eq lc($self->{dispatch}); $file = "$self->{path}/$subpath.pm"; my $pkg = "$self->{name}::$subpath"; $pkg =~ s!/!::!g; # If we have a mixed-case package name, assume case has been preserved # correctly. Otherwise, root through the file to locate the case-preserved # version of the package name. if ( $subpath eq lc($subpath) || $subpath eq uc($subpath) ) { my $content = Module::Install::_read($subpath . '.pm'); my $in_pod = 0; foreach ( split //, $content ) { $in_pod = 1 if /^=\w/; $in_pod = 0 if /^=cut/; next if ($in_pod || /^=cut/); # skip pod text next if /^\s*#/; # and comments if ( m/^\s*package\s+($pkg)\s*;/i ) { $pkg = $1; last; } } } push @found, [ $file, $pkg ]; }, $path ) if -d $path; @found; } ##################################################################### # Common Utility Functions sub _caller { my $depth = 0; my $call = caller($depth); while ( $call eq __PACKAGE__ ) { $depth++; $call = caller($depth); } return $call; } sub _read { local *FH; if ( $] >= 5.006 ) { open( FH, '<', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "< $_[0]" ) or die "open($_[0]): $!"; } my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; if ( $] >= 5.006 ) { open( FH, '>', $_[0] ) or die "open($_[0]): $!"; } else { open( FH, "> $_[0]" ) or die "open($_[0]): $!"; } foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version ($) { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp ($$) { _version($_[0]) <=> _version($_[1]); } # Cloned from Params::Util::_CLASS sub _CLASS ($) { ( defined $_[0] and ! ref $_[0] and $_[0] =~ m/^[^\W\d]\w*(?:::\w+)*\z/s ) ? $_[0] : undef; } 1; # Copyright 2008 - 2009 Adam Kennedy. Class-C3-XS-0.13/ChangeLog0000644000175000017500000000370111256666574013524 0ustar raflraflRevision history for Perl extension Class::C3::XS 0.13 Thu Sep 24, 2009 - Release 0.12_03 as a stable release, without further modifications. 0.12_03 Mon Sep 21, 2009 - Fix compatibility with perl 5.6.x. Thanks again, Nicholas. 0.12_02 Mon Sep 7, 2009 - Actually ship with the changes 0.12_01 claimed to have. Thanks for catching this, Nicholas. 0.12_01 Sat Aug 22, 2009 - Backport a couple of performance tweaks from bleadperl. This gives a performance improvement of about 40% in calculating the linearized isa for hierarchies with single parents only. 0.11 Mon Mar 30, 2009 - Define SVfARG if the perl we're compiling for doesn't have it (Florian Ragwitz). 0.10 Sat Mar 28, 2009 - Improve error message on merge errors (Florian Ragwitz). 0.09 Wed Mar 25, 2009 - Use I32 instead of int (Brandon L Black). - Explicitly specify xs prototyping behaviour (Florian Ragwitz). - Fix several compiler warnings (Florian Ragwitz). - Check return values when storing values in hashes and error out if it didn't work (Florian Ragwitz). - Stop using auto_install in Makefile.PL (Florian Ragwitz). - Remove fake Build.PL (Florian Ragwitz). 0.08 Wed Jun 13, 2007 Fixed next::method, etc under the Perl debugger 0.07 Mon Jun 4, 2007 Fixed "goto &next::method" and related gotos, which fixes Catalyst::Plugin::C3. 0.06 Wed May 16, 2007 Removed the "assert(HvAUX(stash))" that was failing for some Now 5.6.x-compatible, thanks to some testing from dec 0.05 Mon May 14, 2007 Backported optimizations and memory-management fixes from bleadperl 0.04 Sat May 12, 2007 Small new private feature to help MRO::Compat 0.03 Tues May 8, 2007 Remove Build.PL from the dist 0.02 Thurs May 3, 2007 First non-dev release 0.01_01 Sun Apr 15, 2007 Initial development release Class-C3-XS-0.13/t/0000711000175000017500000000000011256666750012200 5ustar raflraflClass-C3-XS-0.13/t/35_next_method_in_anon.t0000644000175000017500000000155111162275006016707 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More tests => 3; BEGIN { use_ok('Class::C3::XS') } =pod This tests the successful handling of a next::method call from within an anonymous subroutine. =cut { package A; sub foo { return 'A::foo'; } sub bar { return 'A::bar'; } } { package B; use base 'A'; sub foo { my $code = sub { return 'B::foo => ' . (shift)->next::method(); }; return (shift)->$code; } sub bar { my $code1 = sub { my $code2 = sub { return 'B::bar => ' . (shift)->next::method(); }; return (shift)->$code2; }; return (shift)->$code1; } } is(B->foo, "B::foo => A::foo", 'method resolved inside anonymous sub'); is(B->bar, "B::bar => A::bar", 'method resolved inside nested anonymous subs'); Class-C3-XS-0.13/t/01_MRO.t0000644000175000017500000000113411162275006013313 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More tests => 2; BEGIN { use_ok('Class::C3::XS'); } =pod This tests the classic diamond inheritence pattern. / \ \ / =cut { package Diamond_A; our @ISA = qw//; } { package Diamond_B; use base 'Diamond_A'; } { package Diamond_C; use base 'Diamond_A'; } { package Diamond_D; use base ('Diamond_B', 'Diamond_C'); } is_deeply( [ Class::C3::XS::calculateMRO('Diamond_D') ], [ qw(Diamond_D Diamond_B Diamond_C Diamond_A) ], '... got the right MRO for Diamond_D'); Class-C3-XS-0.13/t/33_next_method_used_with_NEXT.t0000644000175000017500000000216011162275006020112 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More; BEGIN { eval "use NEXT"; plan skip_all => "NEXT required for this test" if $@; plan tests => 4; } use Class::C3::XS; { package Foo; use strict; use warnings; sub foo { 'Foo::foo' } package Fuz; use strict; use warnings; use base 'Foo'; sub foo { 'Fuz::foo => ' . (shift)->next::method } package Bar; use strict; use warnings; use base 'Foo'; sub foo { 'Bar::foo => ' . (shift)->next::method } package Baz; use strict; use warnings; require NEXT; # load this as late as possible so we can catch the test skip use base 'Bar', 'Fuz'; sub foo { 'Baz::foo => ' . (shift)->NEXT::foo } } is(Foo->foo, 'Foo::foo', '... got the right value from Foo->foo'); is(Fuz->foo, 'Fuz::foo => Foo::foo', '... got the right value from Fuz->foo'); is(Bar->foo, 'Bar::foo => Foo::foo', '... got the right value from Bar->foo'); is(Baz->foo, 'Baz::foo => Bar::foo => Fuz::foo => Foo::foo', '... got the right value using NEXT in a subclass of a C3 class'); Class-C3-XS-0.13/t/04_MRO.t0000644000175000017500000000235411162275006013323 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More tests => 2; BEGIN { use_ok('Class::C3::XS'); } =pod example taken from: L Object ^ | LifeForm ^ ^ / \ Sentient BiPedal ^ ^ | | Intelligent Humanoid ^ ^ \ / Vulcan define class () end class; define class () end class; define class () end class; define class () end class; define class (, ) end class; =cut { package Object; our @ISA = qw//; package LifeForm; use base 'Object'; package Sentient; use base 'LifeForm'; package BiPedal; use base 'LifeForm'; package Intelligent; use base 'Sentient'; package Humanoid; use base 'BiPedal'; package Vulcan; use base ('Intelligent', 'Humanoid'); } is_deeply( [ Class::C3::XS::calculateMRO('Vulcan') ], [ qw(Vulcan Intelligent Sentient Humanoid BiPedal LifeForm Object) ], '... got the right MRO for the Vulcan Dylan Example'); Class-C3-XS-0.13/t/03_MRO.t0000644000175000017500000000335511162275006013324 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More tests => 2; BEGIN { use_ok('Class::C3::XS'); } =pod This example is take from: http://www.python.org/2.3/mro.html "My second example" class O: pass class F(O): pass class E(O): pass class D(O): pass class C(D,F): pass class B(E,D): pass class A(B,C): pass 6 --- Level 3 | O | / --- \ / | \ / | \ / | \ --- --- --- Level 2 2 | E | 4 | D | | F | 5 --- --- --- \ / \ / \ / \ / \ / \ / --- --- Level 1 1 | B | | C | 3 --- --- \ / \ / --- Level 0 0 | A | --- >>> A.mro() (, , , , , , ) =cut { package Test::O; our @ISA = qw//; package Test::F; use base 'Test::O'; package Test::E; use base 'Test::O'; package Test::D; use base 'Test::O'; package Test::C; use base ('Test::D', 'Test::F'); package Test::B; use base ('Test::E', 'Test::D'); package Test::A; use base ('Test::B', 'Test::C'); } is_deeply( [ Class::C3::XS::calculateMRO('Test::A') ], [ qw(Test::A Test::B Test::E Test::C Test::D Test::F Test::O) ], '... got the right MRO for Test::A'); Class-C3-XS-0.13/t/31_next_method_skip.t0000644000175000017500000000434611162275006016235 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More tests => 10; BEGIN { use_ok('Class::C3::XS') } =pod This tests the classic diamond inheritence pattern. / \ \ / =cut { package Diamond_A; sub bar { 'Diamond_A::bar' } sub baz { 'Diamond_A::baz' } } { package Diamond_B; use base 'Diamond_A'; sub baz { 'Diamond_B::baz => ' . (shift)->next::method() } } { package Diamond_C; use base 'Diamond_A'; sub foo { 'Diamond_C::foo' } sub buz { 'Diamond_C::buz' } sub woz { 'Diamond_C::woz' } sub maybe { 'Diamond_C::maybe' } } { package Diamond_D; use base ('Diamond_B', 'Diamond_C'); sub foo { 'Diamond_D::foo => ' . (shift)->next::method() } sub bar { 'Diamond_D::bar => ' . (shift)->next::method() } sub buz { 'Diamond_D::buz => ' . (shift)->baz() } sub fuz { 'Diamond_D::fuz => ' . (shift)->next::method() } sub woz { 'Diamond_D::woz can => ' . ((shift)->next::can() ? 1 : 0) } sub noz { 'Diamond_D::noz can => ' . ((shift)->next::can() ? 1 : 0) } sub maybe { 'Diamond_D::maybe => ' . ((shift)->maybe::next::method() || 0) } sub moybe { 'Diamond_D::moybe => ' . ((shift)->maybe::next::method() || 0) } } is(Diamond_D->foo, 'Diamond_D::foo => Diamond_C::foo', '... skipped B and went to C correctly'); is(Diamond_D->bar, 'Diamond_D::bar => Diamond_A::bar', '... skipped B & C and went to A correctly'); is(Diamond_D->baz, 'Diamond_B::baz => Diamond_A::baz', '... called B method, skipped C and went to A correctly'); is(Diamond_D->buz, 'Diamond_D::buz => Diamond_B::baz => Diamond_A::baz', '... called D method dispatched to , different method correctly'); eval { Diamond_D->fuz }; like($@, qr/^No next::method 'fuz' found for Diamond_D/, '... cannot re-dispatch to a method which is not there'); is(Diamond_D->woz, 'Diamond_D::woz can => 1', '... can re-dispatch figured out correctly'); is(Diamond_D->noz, 'Diamond_D::noz can => 0', '... cannot re-dispatch figured out correctly'); is(Diamond_D->maybe, 'Diamond_D::maybe => Diamond_C::maybe', '... redispatched D to C when it exists'); is(Diamond_D->moybe, 'Diamond_D::moybe => 0', '... quietly failed redispatch from D'); Class-C3-XS-0.13/t/32_next_method_edge_cases.t0000644000175000017500000000326711162275006017353 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More tests => 12; BEGIN { use_ok('Class::C3::XS') } { { package Foo; use strict; use warnings; sub new { bless {}, $_[0] } sub bar { 'Foo::bar' } } # call the submethod in the direct instance my $foo = Foo->new(); isa_ok($foo, 'Foo'); can_ok($foo, 'bar'); is($foo->bar(), 'Foo::bar', '... got the right return value'); # fail calling it from a subclass { package Bar; use strict; use warnings; our @ISA = ('Foo'); } my $bar = Bar->new(); isa_ok($bar, 'Bar'); isa_ok($bar, 'Foo'); # test it working with with Sub::Name SKIP: { eval 'use Sub::Name'; skip "Sub::Name is required for this test", 3 if $@; my $m = sub { (shift)->next::method() }; Sub::Name::subname('Bar::bar', $m); { no strict 'refs'; *{'Bar::bar'} = $m; } can_ok($bar, 'bar'); my $value = eval { $bar->bar() }; ok(!$@, '... calling bar() succedded') || diag $@; is($value, 'Foo::bar', '... got the right return value too'); } # test it failing without Sub::Name { package Baz; use strict; use warnings; our @ISA = ('Foo'); } my $baz = Baz->new(); isa_ok($baz, 'Baz'); isa_ok($baz, 'Foo'); { my $m = sub { (shift)->next::method() }; { no strict 'refs'; *{'Baz::bar'} = $m; } eval { $baz->bar() }; ok($@, '... calling bar() with next::method failed') || diag $@; } } Class-C3-XS-0.13/t/00_load.t0000644000175000017500000000015711162275006013600 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More tests => 1; BEGIN { use_ok('Class::C3::XS'); } Class-C3-XS-0.13/t/02_MRO.t0000644000175000017500000000521211162275006013315 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More tests => 7; BEGIN { use_ok('Class::C3::XS'); } =pod This example is take from: http://www.python.org/2.3/mro.html "My first example" class O: pass class F(O): pass class E(O): pass class D(O): pass class C(D,F): pass class B(D,E): pass class A(B,C): pass 6 --- Level 3 | O | (more general) / --- \ / | \ | / | \ | / | \ | --- --- --- | Level 2 3 | D | 4| E | | F | 5 | --- --- --- | \ \ _ / | | \ / \ _ | | \ / \ | | --- --- | Level 1 1 | B | | C | 2 | --- --- | \ / | \ / \ / --- Level 0 0 | A | (more specialized) --- =cut { package Test::O; our @ISA = qw//; package Test::F; use base 'Test::O'; package Test::E; use base 'Test::O'; package Test::D; use base 'Test::O'; package Test::C; use base ('Test::D', 'Test::F'); package Test::B; use base ('Test::D', 'Test::E'); package Test::A; use base ('Test::B', 'Test::C'); } is_deeply( [ Class::C3::XS::calculateMRO('Test::F') ], [ qw(Test::F Test::O) ], '... got the right MRO for Test::F'); is_deeply( [ Class::C3::XS::calculateMRO('Test::E') ], [ qw(Test::E Test::O) ], '... got the right MRO for Test::E'); is_deeply( [ Class::C3::XS::calculateMRO('Test::D') ], [ qw(Test::D Test::O) ], '... got the right MRO for Test::D'); is_deeply( [ Class::C3::XS::calculateMRO('Test::C') ], [ qw(Test::C Test::D Test::F Test::O) ], '... got the right MRO for Test::C'); is_deeply( [ Class::C3::XS::calculateMRO('Test::B') ], [ qw(Test::B Test::D Test::E Test::O) ], '... got the right MRO for Test::B'); is_deeply( [ Class::C3::XS::calculateMRO('Test::A') ], [ qw(Test::A Test::B Test::C Test::D Test::E Test::F Test::O) ], '... got the right MRO for Test::A'); Class-C3-XS-0.13/t/30_next_method.t0000644000175000017500000000245111162275006015201 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More tests => 5; BEGIN { use_ok('Class::C3::XS') } =pod This tests the classic diamond inheritence pattern. / \ \ / =cut { package Diamond_A; sub hello { 'Diamond_A::hello' } sub foo { 'Diamond_A::foo' } } { package Diamond_B; use base 'Diamond_A'; sub foo { 'Diamond_B::foo => ' . (shift)->next::method() } } { package Diamond_C; use base 'Diamond_A'; sub hello { 'Diamond_C::hello => ' . (shift)->next::method() } sub foo { 'Diamond_C::foo => ' . (shift)->next::method() } } { package Diamond_D; use base ('Diamond_B', 'Diamond_C'); sub foo { 'Diamond_D::foo => ' . (shift)->next::method() } } is(Diamond_C->hello, 'Diamond_C::hello => Diamond_A::hello', '... method resolved itself as expected'); is(Diamond_C->can('hello')->('Diamond_C'), 'Diamond_C::hello => Diamond_A::hello', '... can(method) resolved itself as expected'); is(UNIVERSAL::can("Diamond_C", 'hello')->('Diamond_C'), 'Diamond_C::hello => Diamond_A::hello', '... can(method) resolved itself as expected'); is(Diamond_D->foo, 'Diamond_D::foo => Diamond_B::foo => Diamond_C::foo => Diamond_A::foo', '... method foo resolved itself as expected'); Class-C3-XS-0.13/t/pod.t0000644000175000017500000000025711162275006013145 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More; eval "use Test::Pod 1.14"; plan skip_all => "Test::Pod 1.14 required for testing POD" if $@; all_pod_files_ok(); Class-C3-XS-0.13/t/lib/0000711000175000017500000000000011256666750012746 5ustar raflraflClass-C3-XS-0.13/t/lib/C.pm0000644000175000017500000000007311162275006013460 0ustar raflraflpackage t::lib::C; use base ('t::lib::A', 't::lib::B'); 1; Class-C3-XS-0.13/t/lib/A.pm0000644000175000017500000000004711162275006013457 0ustar raflraflpackage t::lib::A; our @ISA = qw//; 1; Class-C3-XS-0.13/t/lib/D.pm0000644000175000017500000000007311162275006013461 0ustar raflraflpackage t::lib::D; use base ('t::lib::A', 't::lib::E'); 1; Class-C3-XS-0.13/t/lib/B.pm0000644000175000017500000000004711162275006013460 0ustar raflraflpackage t::lib::B; our @ISA = qw//; 1; Class-C3-XS-0.13/t/lib/F.pm0000644000175000017500000000007311162275006013463 0ustar raflraflpackage t::lib::F; use base ('t::lib::C', 't::lib::D'); 1; Class-C3-XS-0.13/t/lib/E.pm0000644000175000017500000000004711162275006013463 0ustar raflraflpackage t::lib::E; our @ISA = qw//; 1; Class-C3-XS-0.13/t/36_next_goto.t0000644000175000017500000000155211162275006014700 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More tests => 5; BEGIN { use_ok('Class::C3::XS') } { package Proxy; our @ISA = qw//; sub next_proxy { goto &next::method } sub maybe_proxy { goto &maybe::next::method } sub can_proxy { goto &next::can } package TBase; our @ISA = qw//; sub foo { 42 } sub bar { 24 } # baz doesn't exist intentionally sub quux { 242 } package TTop; our @ISA = qw/TBase/; sub foo { shift->Proxy::next_proxy() } sub bar { shift->Proxy::maybe_proxy() } sub baz { shift->Proxy::maybe_proxy() } sub quux { shift->Proxy::can_proxy()->() } } is(TTop->foo, 42, 'proxy next::method via goto'); is(TTop->bar, 24, 'proxy maybe::next::method via goto'); is(TTop->baz, undef, 'proxy maybe::next::method via goto with no method'); is(TTop->quux, 242, 'proxy next::can via goto'); Class-C3-XS-0.13/t/34_next_method_in_eval.t0000644000175000017500000000104111162275006016674 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More tests => 2; BEGIN { use_ok('Class::C3::XS') } =pod This tests the use of an eval{} block to wrap a next::method call. =cut { package A; sub foo { die 'A::foo died'; return 'A::foo succeeded'; } } { package B; use base 'A'; sub foo { eval { return 'B::foo => ' . (shift)->next::method(); }; if ($@) { return $@; } } } like(B->foo, qr/^A::foo died/, 'method resolved inside eval{}'); Class-C3-XS-0.13/t/05_MRO.t0000644000175000017500000000067211162275006013325 0ustar raflrafl#!/usr/bin/perl use strict; use warnings; use Test::More tests => 3; BEGIN { use_ok('Class::C3::XS'); use_ok('t::lib::F'); } =pod From the parrot test t/pmc/object-meths.t A B A E \ / \ / C D \ / \ / F =cut is_deeply( [ Class::C3::XS::calculateMRO('t::lib::F') ], [ qw(t::lib::F t::lib::C t::lib::D t::lib::A t::lib::B t::lib::E) ], '... got the right MRO for t::lib::F'); Class-C3-XS-0.13/Makefile.PL0000644000175000017500000000045611162277153013713 0ustar raflrafluse inc::Module::Install 0.75; name 'Class-C3-XS'; all_from 'lib/Class/C3/XS.pm'; perl_version 5.006_000; test_requires 'Test::More' => '0.47'; # Rebuild README for maintainers if(-e 'MANIFEST.SKIP') { system("pod2text lib/Class/C3/XS.pm >README"); } auto_provides; WriteAll; Class-C3-XS-0.13/XS.xs0000644000175000017500000005463311256666517012667 0ustar raflrafl #include "EXTERN.h" #include "perl.h" #include "XSUB.h" /* *********** ppport stuff */ #ifndef PERL_UNUSED_VAR # define PERL_UNUSED_VAR(x) ((void)x) #endif #if defined(PERL_GCC_PEDANTIC) # ifndef PERL_GCC_BRACE_GROUPS_FORBIDDEN # define PERL_GCC_BRACE_GROUPS_FORBIDDEN # endif #endif #if defined(__GNUC__) && !defined(PERL_GCC_BRACE_GROUPS_FORBIDDEN) && !defined(__cplusplus) # ifndef PERL_USE_GCC_BRACE_GROUPS # define PERL_USE_GCC_BRACE_GROUPS # endif #endif #ifndef SvREFCNT_inc # ifdef PERL_USE_GCC_BRACE_GROUPS # define SvREFCNT_inc(sv) \ ({ \ SV * const _sv = (SV*)(sv); \ if (_sv) \ (SvREFCNT(_sv))++; \ _sv; \ }) # else # define SvREFCNT_inc(sv) \ ((PL_Sv=(SV*)(sv)) ? (++(SvREFCNT(PL_Sv)),PL_Sv) : NULL) # endif #endif #ifndef dAX # define dAX I32 ax = MARK - PL_stack_base + 1 #endif #ifndef dVAR # define dVAR dNOOP #endif #ifndef packWARN # define packWARN(a) (a) #endif /* *********** end ppport.h stuff */ #ifndef SVfARG # define SVfARG(p) ((void*)(p)) #endif /* Most of this code is backported from the bleadperl patch's mro.c, and then modified to work with Class::C3's internals. */ AV* __mro_linear_isa_c3(pTHX_ HV* stash, HV* cache, I32 level) { AV* retval; GV** gvp; GV* gv; AV* isa; const char* stashname; STRLEN stashname_len; I32 made_mortal_cache = 0; assert(stash); stashname = HvNAME(stash); stashname_len = strlen(stashname); if (!stashname) Perl_croak(aTHX_ "Can't linearize anonymous symbol table"); if (level > 100) Perl_croak(aTHX_ "Recursive inheritance detected in package '%s'", stashname); if(!cache) { cache = (HV*)sv_2mortal((SV*)newHV()); made_mortal_cache = 1; } else { SV** cache_entry = hv_fetch(cache, stashname, stashname_len, 0); if(cache_entry) return (AV*)SvREFCNT_inc(*cache_entry); } /* not in cache, make a new one */ gvp = (GV**)hv_fetch(stash, "ISA", 3, FALSE); isa = (gvp && (gv = *gvp) && gv != (GV*)&PL_sv_undef) ? GvAV(gv) : NULL; if(isa && AvFILLp(isa) >= 0) { SV** seqs_ptr; I32 seqs_items; HV* tails; AV* const seqs = (AV*)sv_2mortal((SV*)newAV()); I32* heads; /* This builds @seqs, which is an array of arrays. The members of @seqs are the MROs of the members of @ISA, followed by @ISA itself. */ I32 items = AvFILLp(isa) + 1; SV** isa_ptr = AvARRAY(isa); while(items--) { SV* const isa_item = *isa_ptr++; HV* const isa_item_stash = gv_stashsv(isa_item, 0); if(!isa_item_stash) { /* if no stash, make a temporary fake MRO containing just itself */ AV* const isa_lin = newAV(); av_push(isa_lin, newSVsv(isa_item)); av_push(seqs, (SV*)isa_lin); } else { /* recursion */ AV* const isa_lin = __mro_linear_isa_c3(aTHX_ isa_item_stash, cache, level + 1); if(items == 0 && AvFILLp(seqs) == -1) { /* Only one parent class. For this case, the C3 linearisation is this class followed by the parent's linearisation, so don't bother with the expensive calculation. */ SV **svp; I32 subrv_items = AvFILLp(isa_lin) + 1; SV *const *subrv_p = AvARRAY(isa_lin); /* Hijack the allocated but unused array seqs to be the return value. It's currently mortalised. */ retval = seqs; av_extend(retval, subrv_items); AvFILLp(retval) = subrv_items; svp = AvARRAY(retval); /* First entry is this class. */ *svp++ = newSVpvn(stashname, stashname_len); while(subrv_items--) { /* These values are unlikely to be shared hash key scalars, so no point in adding code to optimising for a case that is unlikely to be true. (Or prove me wrong and do it.) */ SV *const val = *subrv_p++; *svp++ = newSVsv(val); } SvREFCNT_dec(isa_lin); SvREFCNT_inc(retval); goto done; } av_push(seqs, (SV*)isa_lin); } } av_push(seqs, SvREFCNT_inc((SV*)isa)); tails = (HV*)sv_2mortal((SV*)newHV()); /* This builds "heads", which as an array of integer array indices, one per seq, which point at the virtual "head" of the seq (initially zero) */ Newz(0xdead, heads, AvFILLp(seqs)+1, I32); /* This builds %tails, which has one key for every class mentioned in the tail of any sequence in @seqs (tail meaning everything after the first class, the "head"). The value is how many times this key appears in the tails of @seqs. */ seqs_ptr = AvARRAY(seqs); seqs_items = AvFILLp(seqs) + 1; while(seqs_items--) { AV* const seq = (AV*)*seqs_ptr++; I32 seq_items = AvFILLp(seq); if(seq_items > 0) { SV** seq_ptr = AvARRAY(seq) + 1; while(seq_items--) { SV* const seqitem = *seq_ptr++; /* LVALUE fetch will create a new undefined SV if necessary */ HE* const he = hv_fetch_ent(tails, seqitem, 1, 0); if(he) { SV* const val = HeVAL(he); /* For 5.8.0 and later, sv_inc() with increment undef to an IV of 1, which is what we want for a newly created entry. However, for 5.6.x it will become an NV of 1.0, which confuses the SvIVX() checks above */ if(SvIOK(val)) { SvIVX(val)++; } else { sv_setiv(val, 1); } } else { croak("failed to store value in hash"); } } } } /* Initialize retval to build the return value in */ retval = newAV(); av_push(retval, newSVpvn(stashname, stashname_len)); /* us first */ /* This loop won't terminate until we either finish building the MRO, or get an exception. */ while(1) { SV* cand = NULL; SV* winner = NULL; int s; /* "foreach $seq (@seqs)" */ SV** const avptr = AvARRAY(seqs); for(s = 0; s <= AvFILLp(seqs); s++) { SV** svp; AV * const seq = (AV*)(avptr[s]); SV* seqhead; if(!seq) continue; /* skip empty seqs */ svp = av_fetch(seq, heads[s], 0); seqhead = *svp; /* seqhead = head of this seq */ if(!winner) { HE* tail_entry; SV* val; /* if we haven't found a winner for this round yet, and this seqhead is not in tails (or the count for it in tails has dropped to zero), then this seqhead is our new winner, and is added to the final MRO immediately */ cand = seqhead; if((tail_entry = hv_fetch_ent(tails, cand, 0, 0)) && (val = HeVAL(tail_entry)) && (SvIVX(val) > 0)) continue; winner = newSVsv(cand); av_push(retval, winner); /* note however that even when we find a winner, we continue looping over @seqs to do housekeeping */ } if(!sv_cmp(seqhead, winner)) { /* Once we have a winner (including the iteration where we first found him), inc the head ptr for any seq which had the winner as a head, NULL out any seq which is now empty, and adjust tails for consistency */ const int new_head = ++heads[s]; if(new_head > AvFILLp(seq)) { SvREFCNT_dec(avptr[s]); avptr[s] = NULL; } else { HE* tail_entry; SV* val; /* Because we know this new seqhead used to be a tail, we can assume it is in tails and has a positive value, which we need to dec */ svp = av_fetch(seq, new_head, 0); seqhead = *svp; tail_entry = hv_fetch_ent(tails, seqhead, 0, 0); val = HeVAL(tail_entry); sv_dec(val); } } } /* if we found no candidates, we are done building the MRO. !cand means no seqs have any entries left to check */ if(!cand) { Safefree(heads); break; } /* If we had candidates, but nobody won, then the @ISA hierarchy is not C3-incompatible */ if(!winner) { SV *errmsg; I32 i; /* we have to do some cleanup before we croak */ errmsg = newSVpvf("Inconsistent hierarchy during C3 merge of class '%s':\n\t" "current merge results [\n", stashname); for (i = 0; i <= av_len(retval); i++) { SV **elem = av_fetch(retval, i, 0); sv_catpvf(errmsg, "\t\t%"SVf",\n", SVfARG(*elem)); } sv_catpvf(errmsg, "\t]\n\tmerging failed on '%"SVf"'", SVfARG(cand)); SvREFCNT_dec(retval); Safefree(heads); croak("%"SVf, SVfARG(errmsg)); } } } else { /* @ISA was undefined or empty */ /* build a retval containing only ourselves */ retval = newAV(); av_push(retval, newSVpvn(stashname, stashname_len)); } done: /* we don't want anyone modifying the cache entry but us, and we do so by replacing it completely */ SvREADONLY_on(retval); if(!made_mortal_cache) { SvREFCNT_inc(retval); if(!hv_store(cache, stashname, stashname_len, (SV*)retval, 0)) { croak("failed to store value in hash"); } } return retval; } STATIC I32 __dopoptosub_at(const PERL_CONTEXT *cxstk, I32 startingblock) { I32 i; for (i = startingblock; i >= 0; i--) { if(CxTYPE((PERL_CONTEXT*)(&cxstk[i])) == CXt_SUB) return i; } return i; } XS(XS_Class_C3_XS_nextcan); XS(XS_Class_C3_XS_nextcan) { dVAR; dXSARGS; SV* self = ST(0); const I32 throw_nomethod = SvIVX(ST(1)); register I32 cxix = cxstack_ix; register const PERL_CONTEXT *ccstack = cxstack; const PERL_SI *top_si = PL_curstackinfo; HV* selfstash; GV* cvgv; SV *stashname; const char *fq_subname; const char *subname; STRLEN fq_subname_len; STRLEN stashname_len; STRLEN subname_len; SV* sv; GV** gvp; AV* linear_av; SV** linear_svp; HV* cstash; GV* candidate = NULL; CV* cand_cv = NULL; const char *hvname; I32 entries; HV* nmcache; HE* cache_entry; SV* cachekey; I32 i; SP -= items; if(sv_isobject(self)) selfstash = SvSTASH(SvRV(self)); else selfstash = gv_stashsv(self, 0); assert(selfstash); hvname = HvNAME(selfstash); if (!hvname) Perl_croak(aTHX_ "Can't use anonymous symbol table for method lookup"); /* This block finds the contextually-enclosing fully-qualified subname, much like looking at (caller($i))[3] until you find a real sub that isn't ANON, etc (also skips over pureperl next::method, etc) */ for(i = 0; i < 2; i++) { cxix = __dopoptosub_at(ccstack, cxix); for (;;) { /* we may be in a higher stacklevel, so dig down deeper */ while (cxix < 0) { if(top_si->si_type == PERLSI_MAIN) Perl_croak(aTHX_ "next::method/next::can/maybe::next::method must be used in method context"); top_si = top_si->si_prev; ccstack = top_si->si_cxstack; cxix = __dopoptosub_at(ccstack, top_si->si_cxix); } if(CxTYPE((PERL_CONTEXT*)(&ccstack[cxix])) != CXt_SUB || (PL_DBsub && GvCV(PL_DBsub) && ccstack[cxix].blk_sub.cv == GvCV(PL_DBsub))) { cxix = __dopoptosub_at(ccstack, cxix - 1); continue; } { const I32 dbcxix = __dopoptosub_at(ccstack, cxix - 1); if (PL_DBsub && GvCV(PL_DBsub) && dbcxix >= 0 && ccstack[dbcxix].blk_sub.cv == GvCV(PL_DBsub)) { if(CxTYPE((PERL_CONTEXT*)(&ccstack[dbcxix])) != CXt_SUB) { cxix = dbcxix; continue; } } } cvgv = CvGV(ccstack[cxix].blk_sub.cv); if(!isGV(cvgv)) { cxix = __dopoptosub_at(ccstack, cxix - 1); continue; } /* we found a real sub here */ sv = sv_newmortal(); gv_efullname3(sv, cvgv, NULL); if (SvPOK(sv)) { fq_subname = SvPVX(sv); fq_subname_len = SvCUR(sv); subname = strrchr(fq_subname, ':'); } else { subname = NULL; } subname = strrchr(fq_subname, ':'); if(!subname) Perl_croak(aTHX_ "next::method/next::can/maybe::next::method cannot find enclosing method"); subname++; subname_len = fq_subname_len - (subname - fq_subname); if(subname_len == 8 && strEQ(subname, "__ANON__")) { cxix = __dopoptosub_at(ccstack, cxix - 1); continue; } break; } cxix--; } /* If we made it to here, we found our context */ /* cachekey = "objpkg|context::method::name" */ cachekey = sv_2mortal(newSVpv(hvname, 0)); sv_catpvn(cachekey, "|", 1); sv_catsv(cachekey, sv); nmcache = get_hv("next::METHOD_CACHE", 1); if((cache_entry = hv_fetch_ent(nmcache, cachekey, 0, 0))) { SV* val = HeVAL(cache_entry); if(val == &PL_sv_undef) { if(throw_nomethod) Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); XSRETURN_EMPTY; } XPUSHs(sv_2mortal(newRV_inc(val))); XSRETURN(1); } /* beyond here is just for cache misses, so perf isn't as critical */ stashname_len = subname - fq_subname - 2; stashname = sv_2mortal(newSVpvn(fq_subname, stashname_len)); linear_av = __mro_linear_isa_c3(aTHX_ selfstash, NULL, 0); linear_svp = AvARRAY(linear_av); entries = AvFILLp(linear_av) + 1; while (entries--) { SV* const linear_sv = *linear_svp++; assert(linear_sv); if(sv_eq(linear_sv, stashname)) break; } if(entries > 0) { SV* sub_sv = sv_2mortal(newSVpv(subname, subname_len)); HV* cc3_mro = get_hv("Class::C3::MRO", 0); while (entries--) { SV* const linear_sv = *linear_svp++; assert(linear_sv); if(cc3_mro) { HE* he_cc3_mro_class = hv_fetch_ent(cc3_mro, linear_sv, 0, 0); if(he_cc3_mro_class) { SV* cc3_mro_class_sv = HeVAL(he_cc3_mro_class); if(SvROK(cc3_mro_class_sv)) { HV* cc3_mro_class = (HV*)SvRV(cc3_mro_class_sv); SV** svp_cc3_mro_class_methods = hv_fetch(cc3_mro_class, "methods", 7, 0); if(svp_cc3_mro_class_methods) { SV* cc3_mro_class_methods_sv = *svp_cc3_mro_class_methods; if(SvROK(cc3_mro_class_methods_sv)) { HV* cc3_mro_class_methods = (HV*)SvRV(cc3_mro_class_methods_sv); if(hv_exists_ent(cc3_mro_class_methods, sub_sv, 0)) continue; } } } } } cstash = gv_stashsv(linear_sv, FALSE); if (!cstash) { if (ckWARN(WARN_MISC)) Perl_warner(aTHX_ packWARN(WARN_MISC), "Can't locate package %"SVf" for @%s::ISA", (void*)linear_sv, hvname); continue; } assert(cstash); gvp = (GV**)hv_fetch(cstash, subname, subname_len, 0); if (!gvp) continue; candidate = *gvp; assert(candidate); if (SvTYPE(candidate) != SVt_PVGV) gv_init(candidate, cstash, subname, subname_len, TRUE); if (SvTYPE(candidate) == SVt_PVGV && (cand_cv = GvCV(candidate)) && !GvCVGEN(candidate)) { SvREFCNT_dec(linear_av); SvREFCNT_inc((SV*)cand_cv); if (!hv_store_ent(nmcache, cachekey, (SV*)cand_cv, 0)) { croak("failed to store value in hash"); } XPUSHs(sv_2mortal(newRV_inc((SV*)cand_cv))); XSRETURN(1); } } } SvREFCNT_dec(linear_av); if (!hv_store_ent(nmcache, cachekey, &PL_sv_undef, 0)) { croak("failed to store value in hash"); } if(throw_nomethod) Perl_croak(aTHX_ "No next::method '%s' found for %s", subname, hvname); XSRETURN_EMPTY; } XS(XS_Class_C3_XS_calculateMRO); XS(XS_Class_C3_XS_calculateMRO) { dVAR; dXSARGS; SV* classname; HV* class_stash; HV* cache = NULL; AV* res; I32 res_items; I32 ret_items; SV** res_ptr; if(items < 1 || items > 2) croak("Usage: calculateMRO(classname[, cache])"); classname = ST(0); if(items == 2) cache = (HV*)SvRV(ST(1)); class_stash = gv_stashsv(classname, 0); if(!class_stash) Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname)); res = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0); res_items = ret_items = AvFILLp(res) + 1; res_ptr = AvARRAY(res); SP -= items; while(res_items--) { SV* res_item = *res_ptr++; XPUSHs(sv_2mortal(newSVsv(res_item))); } SvREFCNT_dec(res); PUTBACK; return; } XS(XS_Class_C3_XS_plsubgen); XS(XS_Class_C3_XS_plsubgen) { dVAR; dXSARGS; SP -= items; XPUSHs(sv_2mortal(newSViv(PL_sub_generation))); PUTBACK; return; } XS(XS_Class_C3_XS_calc_mdt); XS(XS_Class_C3_XS_calc_mdt) { dVAR; dXSARGS; SV* classname; HV* cache; HV* class_stash; AV* class_mro; HV* our_c3mro; /* $Class::C3::MRO{classname} */ SV* has_ovf = NULL; HV* methods; I32 mroitems; /* temps */ HV* hv; HE* he; SV** svp; if(items < 1 || items > 2) croak("Usage: calculate_method_dispatch_table(classname[, cache])"); classname = ST(0); class_stash = gv_stashsv(classname, 0); if(!class_stash) Perl_croak(aTHX_ "No such class: '%s'!", SvPV_nolen(classname)); if(items == 2) cache = (HV*)SvRV(ST(1)); class_mro = __mro_linear_isa_c3(aTHX_ class_stash, cache, 0); our_c3mro = newHV(); if(!hv_store(our_c3mro, "MRO", 3, (SV*)newRV_noinc((SV*)class_mro), 0)) { croak("failed to store value in hash"); } hv = get_hv("Class::C3::MRO", 1); if(!hv_store_ent(hv, classname, (SV*)newRV_noinc((SV*)our_c3mro), 0)) { croak("failed to store value in hash"); } methods = newHV(); /* skip first entry */ mroitems = AvFILLp(class_mro); svp = AvARRAY(class_mro) + 1; while(mroitems--) { SV* mro_class = *svp++; HV* mro_stash = gv_stashsv(mro_class, 0); if(!mro_stash) continue; if(!has_ovf) { SV** ovfp = hv_fetch(mro_stash, "()", 2, 0); if(ovfp) has_ovf = *ovfp; } hv_iterinit(mro_stash); while((he = hv_iternext(mro_stash))) { CV* code; SV* mskey; SV* msval; HE* ourent; HV* meth_hash; SV* orig; mskey = hv_iterkeysv(he); if(hv_exists_ent(methods, mskey, 0)) continue; msval = hv_iterval(mro_stash, he); if(SvTYPE(msval) != SVt_PVGV || !(code = GvCVu(msval))) continue; if((ourent = hv_fetch_ent(class_stash, mskey, 0, 0))) { SV* val = HeVAL(ourent); if(val && SvTYPE(val) == SVt_PVGV && GvCVu(val)) continue; } meth_hash = newHV(); orig = newSVsv(mro_class); sv_catpvn(orig, "::", 2); sv_catsv(orig, mskey); if( !hv_store(meth_hash, "orig", 4, orig, 0) || !hv_store(meth_hash, "code", 4, newRV_inc((SV*)code), 0) || !hv_store_ent(methods, mskey, newRV_noinc((SV*)meth_hash), 0) ) { croak("failed to store value in hash"); } } } if(!hv_store(our_c3mro, "methods", 7, newRV_noinc((SV*)methods), 0)) { croak("failed to store value in hash"); } if(has_ovf) { if(!hv_store(our_c3mro, "has_overload_fallback", 21, SvREFCNT_inc(has_ovf), 0)) { croak("failed to store value in hash"); } } XSRETURN_EMPTY; } MODULE = Class::C3::XS PACKAGE = Class::C3::XS PROTOTYPES: DISABLED BOOT: newXS("Class::C3::XS::calculateMRO", XS_Class_C3_XS_calculateMRO, __FILE__); newXS("Class::C3::XS::_plsubgen", XS_Class_C3_XS_plsubgen, __FILE__); newXS("Class::C3::XS::_calculate_method_dispatch_table", XS_Class_C3_XS_calc_mdt, __FILE__); newXS("Class::C3::XS::_nextcan", XS_Class_C3_XS_nextcan, __FILE__); Class-C3-XS-0.13/META.yml0000644000175000017500000000113211256666647013220 0ustar raflrafl--- abstract: 'XS speedups for Class::C3' author: - 'Brandon L. Black, ' build_requires: ExtUtils::MakeMaker: 6.42 Test::More: 0.47 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 0.91' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Class-C3-XS no_index: directory: - inc - t provides: Class::C3::XS: file: lib/Class/C3/XS.pm version: 0.13 requires: perl: 5.6.0 resources: license: http://dev.perl.org/licenses/ version: 0.13 Class-C3-XS-0.13/MANIFEST0000644000175000017500000000117411256666640013077 0ustar raflraflChangeLog inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Class/C3/XS.pm Makefile.PL MANIFEST This list of files META.yml README t/00_load.t t/01_MRO.t t/02_MRO.t t/03_MRO.t t/04_MRO.t t/05_MRO.t t/30_next_method.t t/31_next_method_skip.t t/32_next_method_edge_cases.t t/33_next_method_used_with_NEXT.t t/34_next_method_in_eval.t t/35_next_method_in_anon.t t/36_next_goto.t t/lib/A.pm t/lib/B.pm t/lib/C.pm t/lib/D.pm t/lib/E.pm t/lib/F.pm t/pod.t XS.xs Class-C3-XS-0.13/lib/0000711000175000017500000000000011256666750012503 5ustar raflraflClass-C3-XS-0.13/lib/Class/0000711000175000017500000000000011256666750013550 5ustar raflraflClass-C3-XS-0.13/lib/Class/C3/0000711000175000017500000000000011256666750014015 5ustar raflraflClass-C3-XS-0.13/lib/Class/C3/XS.pm0000644000175000017500000000277311256666531014723 0ustar raflraflpackage Class::C3::XS; use 5.006_000; use strict; use warnings; our $VERSION = '0.13'; =pod =head1 NAME Class::C3::XS - XS speedups for Class::C3 =head1 SUMMARY use Class::C3; # Automatically loads Class::C3::XS # if it's installed locally =head1 DESCRIPTION This contains XS performance enhancers for L version 0.16 and higher. The main L package will use this package automatically if it can find it. Do not use this package directly, use L instead. The test suite here is not complete, although it does verify a few basic things. The best testing comes from running the L test suite *after* this module is installed. This module won't do anything for you if you're running a version of L older than 0.16. (It's not a dependency because it would be circular with the optional dep from that package to this one). =head1 AUTHOR Brandon L. Black, Eblblack@gmail.comE =head1 LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut require XSLoader; XSLoader::load('Class::C3::XS', $VERSION); $VERSION = eval $VERSION; package # hide me from PAUSE next; sub can { Class::C3::XS::_nextcan($_[0], 0) } sub method { my $method = Class::C3::XS::_nextcan($_[0], 1); goto &$method; } package # hide me from PAUSE maybe::next; sub method { my $method = Class::C3::XS::_nextcan($_[0], 0); goto &$method if defined $method; return; } 1; Class-C3-XS-0.13/README0000644000175000017500000000174211256666645012634 0ustar raflraflNAME Class::C3::XS - XS speedups for Class::C3 SUMMARY use Class::C3; # Automatically loads Class::C3::XS # if it's installed locally DESCRIPTION This contains XS performance enhancers for Class::C3 version 0.16 and higher. The main Class::C3 package will use this package automatically if it can find it. Do not use this package directly, use Class::C3 instead. The test suite here is not complete, although it does verify a few basic things. The best testing comes from running the Class::C3 test suite *after* this module is installed. This module won't do anything for you if you're running a version of Class::C3 older than 0.16. (It's not a dependency because it would be circular with the optional dep from that package to this one). AUTHOR Brandon L. Black, LICENSE This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself.