Class-C3-Adopt-NEXT-0.12/0000711000175000017500000000000011213200741013176 5ustar raflraflClass-C3-Adopt-NEXT-0.12/inc/0000711000175000017500000000000011213200741013747 5ustar raflraflClass-C3-Adopt-NEXT-0.12/inc/Module/0000711000175000017500000000000011213200741015174 5ustar raflraflClass-C3-Adopt-NEXT-0.12/inc/Module/Install/0000711000175000017500000000000011213200741016602 5ustar raflraflClass-C3-Adopt-NEXT-0.12/inc/Module/Install/Can.pm0000644000175000017500000000333311213200667017662 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-Adopt-NEXT-0.12/inc/Module/Install/WriteAll.pm0000644000175000017500000000222211213200667020700 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-Adopt-NEXT-0.12/inc/Module/Install/Makefile.pm0000644000175000017500000001600311213200667020674 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-Adopt-NEXT-0.12/inc/Module/Install/ExtraTests.pm0000644000175000017500000000537711213200667021301 0ustar raflrafl#line 1 use strict; use warnings; use 5.006; package Module::Install::ExtraTests; use Module::Install::Base; BEGIN { our $VERSION = '0.006'; our $ISCORE = 1; our @ISA = qw{Module::Install::Base}; } sub extra_tests { my ($self) = @_; return unless -d 'xt'; return unless my @content = grep { $_ =~ /^[.]/ } ; die "unknown files found in ./xt" if grep { -f } @content; my %known = map {; $_ => 1 } qw(author smoke release); my @unknown = grep { not $known{$_} } @content; die "unknown directories found in ./xt: @unknown" if @unknown; { no warnings qw(closure once); package # The newline tells PAUSE, "DO NOT INDEXING!" MY; sub test_via_harness { my ($self, $perl, $tests) = @_; my $a_str = -d 'xt/author' ? 'xt/author' : ''; my $r_str = -d 'xt/release' ? 'xt/release' : ''; my $s_str = -d 'xt/smoke' ? 'xt/smoke' : ''; my $is_author = $Module::Install::AUTHOR ? 1 : 0; return qq{\t$perl "-Iinc" "-MModule::Install::ExtraTests" } . qq{"-e" "Module::Install::ExtraTests::__harness('Test::Harness', $is_author, '$a_str', '$r_str', '$s_str', \$(TEST_VERBOSE), '\$(INST_LIB)', '\$(INST_ARCHLIB)')" $tests\n}; } sub dist_test { my ($self, @args) = @_; my $text = $self->SUPER::dist_test(@args); my @lines = split /\n/, $text; $_ =~ s/ (\S*MAKE\S* test )/ RELEASE_TESTING=1 $1 / for grep { m/ test / } @lines; return join "\n", @lines; } } } sub __harness { my $harness_class = shift; my $is_author = shift; my $author_tests = shift; my $release_tests = shift; my $smoke_tests = shift; eval "require $harness_class; 1" or die; require File::Spec; my $verbose = shift; eval "\$$harness_class\::verbose = $verbose; 1" or die; # Because Windows doesn't do this for us and listing all the *.t files # out on the command line can blow over its exec limit. require ExtUtils::Command; push @ARGV, __PACKAGE__->_deep_t($author_tests) if $author_tests and (exists $ENV{AUTHOR_TESTING} ? $ENV{AUTHOR_TESTING} : $is_author); push @ARGV, __PACKAGE__->_deep_t($release_tests) if $release_tests and $ENV{RELEASE_TESTING}; push @ARGV, __PACKAGE__->_deep_t($smoke_tests) if $smoke_tests and $ENV{AUTOMATED_TESTING}; my @argv = ExtUtils::Command::expand_wildcards(@ARGV); local @INC = @INC; unshift @INC, map { File::Spec->rel2abs($_) } @_; $harness_class->can('runtests')->(sort { lc $a cmp lc $b } @argv); } sub _wanted { my $href = shift; no warnings 'once'; sub { /\.t$/ and -f $_ and $href->{$File::Find::dir} = 1 } } sub _deep_t { my ($self, $dir) = @_; require File::Find; my %test_dir; File::Find::find(_wanted(\%test_dir), $dir); return map { "$_/*.t" } sort keys %test_dir; } 1; __END__ Class-C3-Adopt-NEXT-0.12/inc/Module/Install/Metadata.pm0000644000175000017500000003530411213200666020703 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-Adopt-NEXT-0.12/inc/Module/Install/Base.pm0000644000175000017500000000176611213200666020042 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-Adopt-NEXT-0.12/inc/Module/Install/Fetch.pm0000644000175000017500000000462711213200667020221 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-Adopt-NEXT-0.12/inc/Module/Install/Win32.pm0000644000175000017500000000340311213200667020061 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-Adopt-NEXT-0.12/inc/Module/Install.pm0000644000175000017500000002411411213200666017160 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-Adopt-NEXT-0.12/Changes0000644000175000017500000000374511213200462014512 0ustar raflrafl0.12 Mon, 08 Jun 2009 14:16:34 +0200 * Update copyright notice. * A couple of pod whitespace changes. 0.11 Tue, 19 May 2009 18:34:17 +0100 * Change wording of warning to be more clear. 0.10 Tue, 12 May 2009 13:23:52 +0200 * Depend on Test::Exception 0.27 to avoid breaking tests on older versions (Closes: RT#45986). 0.09 Tue, 28 Apr 2009 23:14:58 +0100 * Rewrite a chunk of the documentation to be more clear, and also to beter cater for our primary audience (people being linked from Catalyst). Based on feeback from kiffin. 0.08 Wed, 22 Apr 2009 05:19:48 +0200 * Add additional example for doc for converting from NEXT, to help out lazy people who only read the verbatim sections (abraxxa). 0.07 Thu, 19 Feb 2009 01:44:43 +0100 * Add ability to disable warnings for an entire set of modules using a regex. * Change warnings to use the caller instead of the class name of the instance so that warnings are reported on the class which actually uses NEXT, not the class which inherits from it. 0.06 Thu, 25 Dec 2008 00:15:14 +0100 * Update documentation. 0.05 Sat, 20 Dec 2008 16:04:48 +0100 * Upgrade Module::Install::ExtraTests to 0.006. This makes things work on Win32 again (closes RT#41817). * Update warning to be more eloquent. * Document warnings. * Implement a -no_warn import switch to turn of warnings locally. 0.04 Sun, 07 Dec 2008 01:11:59 +0100 * Install our hacked version of NEXT::AUTOLOAD into NEXT::ACTUAL::AUTOLOAD too. This makes us work with NEXT 0.61, which doesn't do all of its magic in NEXT::AUTOLOAD anymore (closes RT#41467). 0.03 Fri, 05 Dec 2008 22:53:48 +0100 * Make the tests work with the error message produced by the pure-perl Class::C3 (RT#41460). * Use MRO::Compat instead of Class::C3 directly. 0.02 Tue, 02 Dec 2008 15:41:39 +0100 * Depend on Test::Exception. * Fix some test fails on perls with different c3 diagnostics. 0.01 Mon, 01 Dec 2008 19:54:51 +0100 * Initial release. Class-C3-Adopt-NEXT-0.12/t/0000711000175000017500000000000011213200741013441 5ustar raflraflClass-C3-Adopt-NEXT-0.12/t/incompatible.t0000644000175000017500000000103511116321156016311 0ustar raflrafluse strict; use warnings; use Test::More tests => 3; use Class::C3::Adopt::NEXT; { package X; package Y; package XY; our @ISA = qw/X Y/; package YX; our @ISA = qw/Y X/; package Z; our @ISA = qw/XY YX/; sub foo { shift->NEXT::foo(@_) } } my @warnings; $SIG{__WARN__} = sub { push @warnings, @_ }; is(scalar @warnings, 0, 'no warnings yet'); Z->foo; Z->foo; is(scalar @warnings, 1, 'got a warning',); like($warnings[0], qr/inconsistent hierarchy .* merg(?:e|ing)/i, 'inconsistent c3 hierarchy'); Class-C3-Adopt-NEXT-0.12/t/basic.t0000644000175000017500000000233011204624151014722 0ustar raflrafluse strict; use warnings; use Test::More tests => 12; use Test::Exception; use FindBin; use lib "$FindBin::Bin/lib"; use vars qw/@warnings/; BEGIN { $SIG{__WARN__} = sub { push @warnings, @_ } } use C3NT; BEGIN { use_ok('Class::C3::Adopt::NEXT'); } my $quux_obj = C3NT::Quux->new; is(scalar @warnings, 0, 'no warnings yet'); is($quux_obj->basic, 42, 'Basic inherited method returns correct value'); like($warnings[0], qr/C3NT::Quux uses NEXT/, 'warning for the first time NEXT is used'); is($quux_obj->basic, 42, 'Basic inherited method returns correct value'); is(scalar @warnings, 3, 'warn only once per class'); { my $non_exist_rval; lives_ok(sub { $non_exist_rval = $quux_obj->non_exist; }, 'Non-existant non-ACTUAL throws no errors'); is($non_exist_rval, undef, 'Non-existant non-ACTUAL returns undef'); } throws_ok(sub { $quux_obj->non_exist_actual; }, qr|non_exist_actual\b.*\bC3NT::Quux|, 'Non-existant ACTUAL throws correct error'); throws_ok(sub { $quux_obj->actual_fail_halfway; }, qr|actual_fail_halfway\b.*\bC3NT::Quux|, 'Non-existant ACTUAL in superclass throws correct error'); is( $quux_obj->c3_then_next, 21, 'C3 then NEXT' ); is( $quux_obj->next_then_c3, 22, 'NEXT then C3' ); Class-C3-Adopt-NEXT-0.12/t/disable_regex.t0000644000175000017500000000054511147124433016450 0ustar raflrafluse strict; use warnings; use Test::More tests => 2; use Class::C3::Adopt::NEXT; use FindBin; use lib "$FindBin::Bin/lib"; use C3NT; no Class::C3::Adopt::NEXT qr/^C3NT::/; my $obj = C3NT::Quux->new; my @warnings; $SIG{__WARN__} = sub { push @warnings, @_ }; is($obj->basic, 42); is(scalar @warnings, 0, 'no warnings after disabling NEXT adoption'); Class-C3-Adopt-NEXT-0.12/t/warning_package.t0000644000175000017500000000106011204624151016760 0ustar raflrafluse strict; use warnings; use Test::More tests => 3; use Test::Exception; use FindBin; use lib "$FindBin::Bin/lib"; use Class::C3::Adopt::NEXT; use vars qw/@warnings/; BEGIN { $SIG{__WARN__} = sub { push @warnings, @_ } } use C3NT; my $child = C3NT::Child->new; @warnings = (); $child->basic; like($warnings[0], qr/C3NT::Quux uses NEXT/, 'warning for the class NEXT is used by'); like($warnings[1], qr/C3NT::Bar uses NEXT/, 'warning for the class NEXT is used by'); like($warnings[2], qr/C3NT::Baz uses NEXT/, 'warning for the class NEXT is used by'); Class-C3-Adopt-NEXT-0.12/t/import.t0000644000175000017500000000065511121437441015165 0ustar raflrafluse strict; use warnings; use Test::More tests => 1; use Class::C3::Adopt::NEXT; { package BaseClass; sub foo { 42 } } { package Derived; # no warnings 'Class::C3::Adopt::NEXT'; use Class::C3::Adopt::NEXT -no_warn; sub foo { return shift->NEXT::foo(@_); } } my @warnings; $SIG{__WARN__} = sub { push @warnings, @_ }; Derived->foo; is(scalar @warnings, 0, '-no_warn disables warnings'); Class-C3-Adopt-NEXT-0.12/t/nowarn.t0000644000175000017500000000055411115024700015146 0ustar raflrafluse strict; use warnings; use Test::More tests => 2; use Class::C3::Adopt::NEXT; use FindBin; use lib "$FindBin::Bin/lib"; use C3NT_nowarn; my @warnings; $SIG{__WARN__} = sub { push @warnings, @_ }; my $quux_obj = C3NT::Quux->new; is($quux_obj->basic, 42, 'Basic inherited method returns correct value'); is(scalar @warnings, 0, 'no warnings when disabled'); Class-C3-Adopt-NEXT-0.12/t/lib/0000711000175000017500000000000011213200741014207 5ustar raflraflClass-C3-Adopt-NEXT-0.12/t/lib/C3NT.pm0000644000175000017500000000226411147124557015310 0ustar raflrafluse strict; use warnings; package C3NT; { package C3NT::Foo; sub new { return bless {} => shift } sub basic { 42 } sub c3_then_next { 21 } sub next_then_c3 { 22 } } { package C3NT::Bar; use base qw/C3NT::Foo/; sub basic { shift->NEXT::basic } sub next_then_c3 { shift->next::method } sub actual_fail_halfway { shift->NEXT::ACTUAL::actual_fail_halfway } } { package C3NT::Baz; use base qw/C3NT::Foo/; sub basic { shift->NEXT::basic } sub c3_then_next { shift->NEXT::c3_then_next } } { package C3NT::Quux; use base qw/C3NT::Bar C3NT::Baz/; sub basic { shift->NEXT::basic } sub non_exist { shift->NEXT::non_exist } sub non_exist_actual { shift->NEXT::ACTUAL::non_exist_actual } sub actual_fail_halfway { shift->NEXT::ACTUAL::actual_fail_halfway } sub c3_then_next { shift->next::method } sub next_then_c3 { shift->NEXT::next_then_c3 } } { package C3NT::Child; use base qw/C3NT::Quux/; } 1; Class-C3-Adopt-NEXT-0.12/t/lib/C3NT_nowarn.pm0000644000175000017500000000240011147124557016664 0ustar raflrafluse strict; use warnings; package C3NT_nowarn; { package C3NT::Foo; sub new { return bless {} => shift } sub basic { 42 } sub c3_then_next { 21 } sub next_then_c3 { 22 } } { package C3NT::Bar; use base qw/C3NT::Foo/; no warnings 'Class::C3::Adopt::NEXT'; sub basic { shift->NEXT::basic } sub next_then_c3 { shift->next::method } sub actual_fail_halfway { shift->NEXT::ACTUAL::actual_fail_halfway } } { package C3NT::Baz; use base qw/C3NT::Foo/; no warnings 'Class::C3::Adopt::NEXT'; sub basic { shift->NEXT::basic } sub c3_then_next { shift->NEXT::c3_then_next } } { package C3NT::Quux; use base qw/C3NT::Bar C3NT::Baz/; no warnings 'Class::C3::Adopt::NEXT'; sub basic { shift->NEXT::basic } sub non_exist { shift->NEXT::non_exist } sub non_exist_actual { shift->NEXT::ACTUAL::non_exist_actual } sub actual_fail_halfway { shift->NEXT::ACTUAL::actual_fail_halfway } sub c3_then_next { shift->next::method } sub next_then_c3 { shift->NEXT::next_then_c3 } } 1; Class-C3-Adopt-NEXT-0.12/t/disable.t0000644000175000017500000000057411147124557015267 0ustar raflrafluse strict; use warnings; use Test::More tests => 2; use Class::C3::Adopt::NEXT; use FindBin; use lib "$FindBin::Bin/lib"; use C3NT; no Class::C3::Adopt::NEXT qw/C3NT::Quux C3NT::Bar C3NT::Foo/; my $obj = C3NT::Quux->new; my @warnings; $SIG{__WARN__} = sub { push @warnings, @_ }; is($obj->basic, 42); is(scalar @warnings, 0, 'no warnings after disabling NEXT adoption'); Class-C3-Adopt-NEXT-0.12/Makefile.PL0000644000175000017500000000104011213200662015155 0ustar raflrafluse strict; use warnings; use inc::Module::Install; name 'Class-C3-Adopt-NEXT'; all_from 'lib/Class/C3/Adopt/NEXT.pm'; requires 'MRO::Compat'; requires 'NEXT'; requires 'List::MoreUtils'; test_requires 'Test::Exception' => '0.27'; repository 'git://github.com/rafl/class-c3-adopt-next.git'; bugtracker 'http://rt.cpan.org/Public/Dist/Display.html?Name=Class-C3-Adopt-NEXT'; extra_tests; postamble(<<"EOM"); testcover: pm_to_blib \tcover -delete \tAUTHOR_TESTING=0 HARNESS_PERL_SWITCHES=-MDevel::Cover \$(MAKE) test \tcover EOM WriteAll; Class-C3-Adopt-NEXT-0.12/META.yml0000644000175000017500000000131611213200667014467 0ustar raflrafl--- abstract: 'make NEXT suck less' author: - 'Florian Ragwitz C' build_requires: ExtUtils::MakeMaker: 6.42 Test::Exception: 0.27 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-Adopt-NEXT no_index: directory: - inc - t - xt requires: List::MoreUtils: 0 MRO::Compat: 0 NEXT: 0 resources: bugtracker: http://rt.cpan.org/Public/Dist/Display.html?Name=Class-C3-Adopt-NEXT license: http://dev.perl.org/licenses/ repository: git://github.com/rafl/class-c3-adopt-next.git version: 0.12 Class-C3-Adopt-NEXT-0.12/xt/0000711000175000017500000000000011213200741013631 5ustar raflraflClass-C3-Adopt-NEXT-0.12/xt/release/0000711000175000017500000000000011213200741015251 5ustar raflraflClass-C3-Adopt-NEXT-0.12/xt/release/meta_yml.t0000644000175000017500000000010111124541733017257 0ustar raflrafluse strict; use warnings; use Test::CPAN::Meta; meta_yaml_ok(); Class-C3-Adopt-NEXT-0.12/xt/author/0000711000175000017500000000000011213200741015133 5ustar raflraflClass-C3-Adopt-NEXT-0.12/xt/author/pod_spelling.t0000644000175000017500000000034311112570313020012 0ustar raflrafluse strict; use warnings; use Test::Spelling; set_spell_cmd('aspell list'); add_stopwords( grep { defined $_ && length $_ } ); all_pod_files_spelling_ok(); __DATA__ Florian Ragwitz plugins MRO practices runtime Doran Class-C3-Adopt-NEXT-0.12/xt/author/pod.t0000644000175000017500000000007611112570203016116 0ustar raflrafluse strict; use warnings; use Test::Pod; all_pod_files_ok(); Class-C3-Adopt-NEXT-0.12/MANIFEST0000644000175000017500000000104311213200673014341 0ustar raflraflChanges inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/ExtraTests.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/Adopt/NEXT.pm Makefile.PL MANIFEST This list of files META.yml README t/basic.t t/disable.t t/disable_regex.t t/import.t t/incompatible.t t/lib/C3NT.pm t/lib/C3NT_nowarn.pm t/nowarn.t t/warning_package.t xt/author/pod.t xt/author/pod_spelling.t xt/release/meta_yml.t Class-C3-Adopt-NEXT-0.12/lib/0000711000175000017500000000000011213200741013744 5ustar raflraflClass-C3-Adopt-NEXT-0.12/lib/Class/0000711000175000017500000000000011213200741015011 5ustar raflraflClass-C3-Adopt-NEXT-0.12/lib/Class/C3/0000711000175000017500000000000011213200741015256 5ustar raflraflClass-C3-Adopt-NEXT-0.12/lib/Class/C3/Adopt/0000711000175000017500000000000011213200741016325 5ustar raflraflClass-C3-Adopt-NEXT-0.12/lib/Class/C3/Adopt/NEXT.pm0000644000175000017500000001576311213200433017463 0ustar raflrafluse strict; use warnings; package Class::C3::Adopt::NEXT; use NEXT; use MRO::Compat; use List::MoreUtils qw/none/; use warnings::register; our $VERSION = '0.12'; { my %c3_mro_ok; my %warned_for; my @no_warn_regexes; { my $orig = NEXT->can('AUTOLOAD'); no warnings 'redefine'; *NEXT::AUTOLOAD = sub { my $class = ref $_[0] || $_[0]; my $caller = caller(); # 'NEXT::AUTOLOAD' is cargo-culted from C::P::C3, I have no idea if/why it's needed my $wanted = our $AUTOLOAD || 'NEXT::AUTOLOAD'; my ($wanted_class) = $wanted =~ m{(.*)::}; unless (exists $c3_mro_ok{$class}) { eval { mro::get_linear_isa($class, 'c3') }; if (my $error = $@) { warn "Class::C3::calculateMRO('${class}') Error: '${error}';" . ' Falling back to plain NEXT.pm behaviour for this class'; $c3_mro_ok{$class} = 0; } else { $c3_mro_ok{$class} = 1; } } if (length $c3_mro_ok{$class} && $c3_mro_ok{$class}) { unless ($warned_for{$caller}) { $warned_for{$caller} = 1; if (!@no_warn_regexes || none { $caller =~ $_ } @no_warn_regexes) { warnings::warnif("${caller} uses NEXT, which is deprecated. Please see " . "the Class::C3::Adopt::NEXT documentation for details. NEXT used "); } } } unless ($c3_mro_ok{$class}) { $NEXT::AUTOLOAD = $wanted; goto &$orig; } goto &next::method if $wanted_class =~ /^NEXT:.*:ACTUAL/; goto &maybe::next::method; }; *NEXT::ACTUAL::AUTOLOAD = \&NEXT::AUTOLOAD; } sub import { my ($class, @args) = @_; my $target = caller(); for my $arg (@args) { $warned_for{$target} = 1 if $arg eq '-no_warn'; } } sub unimport { my $class = shift; my @strings = grep { !ref $_ || ref($_) ne 'Regexp' } @_; my @regexes = grep { ref($_) && ref($_) eq 'Regexp' } @_; @c3_mro_ok{@strings} = ('') x @strings; push @no_warn_regexes, @regexes; } } 1; __END__ =head1 NAME Class::C3::Adopt::NEXT - make NEXT suck less =head1 SYNOPSIS package MyApp::Plugin::FooBar; #use NEXT; use Class::C3::Adopt::NEXT; # or 'use Class::C3::Adopt::NEXT -no_warn;' to suppress warnings # Or use warnings::register # no warnings 'Class::C3::Adopt::NEXT'; # Or suppress warnings in a set of modules from one place # no Class::C3::Adopt::NEXT qw/ Module1 Module2 Module3 /; # Or suppress using a regex # no Class::C3::Adopt::NEXT qr/^Module\d$/; sub a_method { my ($self) = @_; # Do some stuff # Re-dispatch method # Note that this will generate a warning the _first_ time the package # uses NEXT unless you un comment the 'no warnings' line above. $self->NEXT::method(); } =head1 DESCRIPTION L was a good solution a few years ago, but isn't any more. It's slow, and the order in which it re-dispatches methods appears random at times. It also encourages bad programming practices, as you end up with code to re-dispatch methods when all you really wanted to do was run some code before or after a method fired. However, if you have a large application, then weaning yourself off C isn't easy. This module is intended as a drop-in replacement for NEXT, supporting the same interface, but using L to do the hard work. You can then write new code without C, and migrate individual source files to use C or method modifiers as appropriate, at whatever pace you're comfortable with. =head1 WARNINGS This module will warn once for each package using NEXT. It uses L, and so can be disabled like by adding C to each package which generates a warning, or adding C, or disable multiple modules at once by saying: no Class::C3::Adopt::NEXT qw/ Module1 Module2 Module3 /; somewhere before the warnings are first triggered. You can also setup entire name spaces of modules which will not warn using a regex, e.g. no Class::C3::Adopt::NEXT qr/^Module\d$/; =head1 MIGRATING =head2 Current code using NEXT You add C to the top of a package as you start converting it, and gradually replace your calls to C with C, and calls to C with C. Example: sub yourmethod { my $self = shift; # $self->NEXT::yourmethod(@_); becomes $self->maybe::next::method(); } sub othermethod { my $self = shift; # $self->NEXT::ACTUAL::yourmethodname(); becomes $self->next::method(); } On systems with L present, this will automatically be used to speed up method re-dispatch. If you are running perl version 5.9.5 or greater then the C3 method resolution algorithm is included in perl. Correct use of L as shown above allows your code to be seamlessly forward and backwards compatible, taking advantage of native versions if available, but falling back to using pure perl C. =head2 Writing new code Use L and make all of your plugins L, then use method modifiers to wrap methods. Example: package MyApp::Role::FooBar; use Moose::Role; before 'a_method' => sub { my ($self) = @_; # Do some stuff }; around 'a_method' => sub { my $orig = shift; my $self = shift; # Do some stuff before my $ret = $self->$orig(@_); # Run wrapped method (or not!) # Do some stuff after return $ret; }; package MyApp; use Moose; with 'MyApp::Role::FooBar'; =head1 CAVEATS There are some inheritance hierarchies that it is possible to create which cannot be resolved to a simple C3 hierarchy. In that case, this module will fall back to using C. In this case a warning will be emitted. Because calculating the MRO of every class every time C<< ->NEXT::foo >> is used from within it is too expensive, runtime manipulations of C<@ISA> are prohibited. =head1 FUNCTIONS This module replaces C with it's own version. If warnings are enabled then a warning will be emitted on the first use of C by each package. =head1 SEE ALSO L and L for method re-dispatch and L for method modifiers and L. L for documentation on the functionality you'll be removing. =head1 AUTHORS Florian Ragwitz C Tomas Doran C =head1 COPYRIGHT AND LICENSE Copyright (c) 2008, 2009 Florian Ragwitz You may distribute this code under the same terms as Perl itself. =cut Class-C3-Adopt-NEXT-0.12/README0000644000175000017500000001152711213200671014076 0ustar raflraflNAME Class::C3::Adopt::NEXT - make NEXT suck less SYNOPSIS package MyApp::Plugin::FooBar; #use NEXT; use Class::C3::Adopt::NEXT; # or 'use Class::C3::Adopt::NEXT -no_warn;' to suppress warnings # Or use warnings::register # no warnings 'Class::C3::Adopt::NEXT'; # Or suppress warnings in a set of modules from one place # no Class::C3::Adopt::NEXT qw/ Module1 Module2 Module3 /; # Or suppress using a regex # no Class::C3::Adopt::NEXT qr/^Module\d$/; sub a_method { my ($self) = @_; # Do some stuff # Re-dispatch method # Note that this will generate a warning the _first_ time the package # uses NEXT unless you un comment the 'no warnings' line above. $self->NEXT::method(); } DESCRIPTION NEXT was a good solution a few years ago, but isn't any more. It's slow, and the order in which it re-dispatches methods appears random at times. It also encourages bad programming practices, as you end up with code to re-dispatch methods when all you really wanted to do was run some code before or after a method fired. However, if you have a large application, then weaning yourself off "NEXT" isn't easy. This module is intended as a drop-in replacement for NEXT, supporting the same interface, but using Class::C3 to do the hard work. You can then write new code without "NEXT", and migrate individual source files to use "Class::C3" or method modifiers as appropriate, at whatever pace you're comfortable with. WARNINGS This module will warn once for each package using NEXT. It uses warnings::register, and so can be disabled like by adding "no warnings 'Class::C3::Adopt::NEXT';" to each package which generates a warning, or adding "use Class::C3::Adopt::NEXT -no_warn;", or disable multiple modules at once by saying: no Class::C3::Adopt::NEXT qw/ Module1 Module2 Module3 /; somewhere before the warnings are first triggered. You can also setup entire name spaces of modules which will not warn using a regex, e.g. no Class::C3::Adopt::NEXT qr/^Module\d$/; MIGRATING Current code using NEXT You add "use MRO::Compat" to the top of a package as you start converting it, and gradually replace your calls to "NEXT::method()" with "maybe::next::method()", and calls to "NEXT::ACTUAL::method()" with "next::method()". Example: sub yourmethod { my $self = shift; # $self->NEXT::yourmethod(@_); becomes $self->maybe::next::method(); } sub othermethod { my $self = shift; # $self->NEXT::ACTUAL::yourmethodname(); becomes $self->next::method(); } On systems with Class::C3::XS present, this will automatically be used to speed up method re-dispatch. If you are running perl version 5.9.5 or greater then the C3 method resolution algorithm is included in perl. Correct use of MRO::Compat as shown above allows your code to be seamlessly forward and backwards compatible, taking advantage of native versions if available, but falling back to using pure perl "Class::C3". Writing new code Use Moose and make all of your plugins Moose::Roles, then use method modifiers to wrap methods. Example: package MyApp::Role::FooBar; use Moose::Role; before 'a_method' => sub { my ($self) = @_; # Do some stuff }; around 'a_method' => sub { my $orig = shift; my $self = shift; # Do some stuff before my $ret = $self->$orig(@_); # Run wrapped method (or not!) # Do some stuff after return $ret; }; package MyApp; use Moose; with 'MyApp::Role::FooBar'; CAVEATS There are some inheritance hierarchies that it is possible to create which cannot be resolved to a simple C3 hierarchy. In that case, this module will fall back to using "NEXT". In this case a warning will be emitted. Because calculating the MRO of every class every time "->NEXT::foo" is used from within it is too expensive, runtime manipulations of @ISA are prohibited. FUNCTIONS This module replaces "NEXT::AUTOLOAD" with it's own version. If warnings are enabled then a warning will be emitted on the first use of "NEXT" by each package. SEE ALSO MRO::Compat and Class::C3 for method re-dispatch and Moose for method modifiers and roles. NEXT for documentation on the functionality you'll be removing. AUTHORS Florian Ragwitz "rafl@debian.org" Tomas Doran "bobtfish@bobtfish.net" COPYRIGHT AND LICENSE Copyright (c) 2008, 2009 Florian Ragwitz You may distribute this code under the same terms as Perl itself.