Parallel-Prefork-0.14/0000755000175000017500000000000012147005021014154 5ustar kazuhokazuhoParallel-Prefork-0.14/inc/0000755000175000017500000000000012147005021014725 5ustar kazuhokazuhoParallel-Prefork-0.14/inc/Module/0000755000175000017500000000000012147005021016152 5ustar kazuhokazuhoParallel-Prefork-0.14/inc/Module/Install/0000755000175000017500000000000012147005021017560 5ustar kazuhokazuhoParallel-Prefork-0.14/inc/Module/Install/Makefile.pm0000644000175000017500000002703212147004556021653 0ustar kazuhokazuho#line 1 package Module::Install::Makefile; use strict 'vars'; use ExtUtils::MakeMaker (); use Module::Install::Base (); use Fcntl qw/:flock :seek/; use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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 or non-interactive session, always use defaults if ( ($ENV{AUTOMATED_TESTING} or -! -t STDIN) and ! $ENV{PERL_MM_USE_DEFAULT} ) { local $ENV{PERL_MM_USE_DEFAULT} = 1; goto &ExtUtils::MakeMaker::prompt; } else { goto &ExtUtils::MakeMaker::prompt; } } # Store a cleaned up version of the MakeMaker version, # since we need to behave differently in a variety of # ways based on the MM version. my $makemaker = eval $ExtUtils::MakeMaker::VERSION; # If we are passed a param, do a "newer than" comparison. # Otherwise, just return the MakeMaker version. sub makemaker { ( @_ < 2 or $makemaker >= eval($_[1]) ) ? $makemaker : 0 } # Ripped from ExtUtils::MakeMaker 6.56, and slightly modified # as we only need to know here whether the attribute is an array # or a hash or something else (which may or may not be appendable). my %makemaker_argtype = ( C => 'ARRAY', CONFIG => 'ARRAY', # CONFIGURE => 'CODE', # ignore DIR => 'ARRAY', DL_FUNCS => 'HASH', DL_VARS => 'ARRAY', EXCLUDE_EXT => 'ARRAY', EXE_FILES => 'ARRAY', FUNCLIST => 'ARRAY', H => 'ARRAY', IMPORTS => 'HASH', INCLUDE_EXT => 'ARRAY', LIBS => 'ARRAY', # ignore '' MAN1PODS => 'HASH', MAN3PODS => 'HASH', META_ADD => 'HASH', META_MERGE => 'HASH', PL_FILES => 'HASH', PM => 'HASH', PMLIBDIRS => 'ARRAY', PMLIBPARENTDIRS => 'ARRAY', PREREQ_PM => 'HASH', CONFIGURE_REQUIRES => 'HASH', SKIP => 'ARRAY', TYPEMAPS => 'ARRAY', XS => 'HASH', # VERSION => ['version',''], # ignore # _KEEP_AFTER_FLUSH => '', clean => 'HASH', depend => 'HASH', dist => 'HASH', dynamic_lib=> 'HASH', linkext => 'HASH', macro => 'HASH', postamble => 'HASH', realclean => 'HASH', test => 'HASH', tool_autosplit => 'HASH', # special cases where you can use makemaker_append CCFLAGS => 'APPENDABLE', DEFINE => 'APPENDABLE', INC => 'APPENDABLE', LDDLFLAGS => 'APPENDABLE', LDFROM => 'APPENDABLE', ); sub makemaker_args { my ($self, %new_args) = @_; my $args = ( $self->{makemaker_args} ||= {} ); foreach my $key (keys %new_args) { if ($makemaker_argtype{$key}) { if ($makemaker_argtype{$key} eq 'ARRAY') { $args->{$key} = [] unless defined $args->{$key}; unless (ref $args->{$key} eq 'ARRAY') { $args->{$key} = [$args->{$key}] } push @{$args->{$key}}, ref $new_args{$key} eq 'ARRAY' ? @{$new_args{$key}} : $new_args{$key}; } elsif ($makemaker_argtype{$key} eq 'HASH') { $args->{$key} = {} unless defined $args->{$key}; foreach my $skey (keys %{ $new_args{$key} }) { $args->{$key}{$skey} = $new_args{$key}{$skey}; } } elsif ($makemaker_argtype{$key} eq 'APPENDABLE') { $self->makemaker_append($key => $new_args{$key}); } } else { if (defined $args->{$key}) { warn qq{MakeMaker attribute "$key" is overriden; use "makemaker_append" to append values\n}; } $args->{$key} = $new_args{$key}; } } return $args; } # For mm args that take multiple space-seperated args, # append an argument to the current list. sub makemaker_append { my $self = shift; 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 ); } sub _wanted_t { } sub tests_recursive { my $self = shift; my $dir = shift || 't'; unless ( -d $dir ) { die "tests_recursive dir '$dir' does not exist"; } my %tests = map { $_ => 1 } split / /, ($self->tests || ''); require File::Find; File::Find::find( sub { /\.t$/ and -f $_ and $tests{"$File::Find::dir/*.t"} = 1 }, $dir ); $self->tests( join ' ', sort keys %tests ); } 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. my $v = $ExtUtils::MakeMaker::VERSION =~ /^(\d+\.\d+)/; $self->build_requires( 'ExtUtils::MakeMaker' => $v ); $self->configure_requires( 'ExtUtils::MakeMaker' => $v ); } 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->{NAME} =~ s/-/::/g; $args->{VERSION} = $self->version or die <<'EOT'; ERROR: Can't determine distribution version. Please specify it explicitly via 'version' in Makefile.PL, or set a valid $VERSION in a module, and provide its file path via 'version_from' (or 'all_from' if you prefer) in Makefile.PL. EOT $DB::single = 1; if ( $self->tests ) { my @tests = split ' ', $self->tests; my %seen; $args->{test} = { TESTS => (join ' ', grep {!$seen{$_}++} @tests), }; } elsif ( $Module::Install::ExtraTests::use_extratests ) { # Module::Install::ExtraTests doesn't set $self->tests and does its own tests via harness. # So, just ignore our xt tests here. } elsif ( -d 'xt' and ($Module::Install::AUTHOR or $ENV{RELEASE_TESTING}) ) { $args->{test} = { TESTS => join( ' ', map { "$_/*.t" } grep { -d $_ } qw{ t xt } ), }; } if ( $] >= 5.005 ) { $args->{ABSTRACT} = $self->abstract; $args->{AUTHOR} = join ', ', @{$self->author || []}; } if ( $self->makemaker(6.10) ) { $args->{NO_META} = 1; #$args->{NO_MYMETA} = 1; } if ( $self->makemaker(6.17) and $self->sign ) { $args->{SIGN} = 1; } unless ( $self->is_admin ) { delete $args->{SIGN}; } if ( $self->makemaker(6.31) and $self->license ) { $args->{LICENSE} = $self->license; } my $prereq = ($args->{PREREQ_PM} ||= {}); %$prereq = ( %$prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->requires) ); # Remove any reference to perl, PREREQ_PM doesn't support it delete $args->{PREREQ_PM}->{perl}; # Merge both kinds of requires into BUILD_REQUIRES my $build_prereq = ($args->{BUILD_REQUIRES} ||= {}); %$build_prereq = ( %$build_prereq, map { @$_ } # flatten [module => version] map { @$_ } grep $_, ($self->configure_requires, $self->build_requires) ); # Remove any reference to perl, BUILD_REQUIRES doesn't support it delete $args->{BUILD_REQUIRES}->{perl}; # Delete bundled dists from prereq_pm, add it to Makefile DIR my $subdirs = ($args->{DIR} || []); if ($self->bundles) { my %processed; foreach my $bundle (@{ $self->bundles }) { my ($mod_name, $dist_dir) = @$bundle; delete $prereq->{$mod_name}; $dist_dir = File::Basename::basename($dist_dir); # dir for building this module if (not exists $processed{$dist_dir}) { if (-d $dist_dir) { # List as sub-directory to be processed by make push @$subdirs, $dist_dir; } # Else do nothing: the module is already present on the system $processed{$dist_dir} = undef; } } } unless ( $self->makemaker('6.55_03') ) { %$prereq = (%$prereq,%$build_prereq); delete $args->{BUILD_REQUIRES}; } 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"; if ( $self->makemaker(6.48) ) { $args->{MIN_PERL_VERSION} = $perl_version; } } if ($self->installdirs) { warn qq{old INSTALLDIRS (probably set by makemaker_args) is overriden by installdirs\n} if $args->{INSTALLDIRS}; $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: $!"; eval { flock MAKEFILE, LOCK_EX }; my $makefile = do { local $/; }; $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; seek MAKEFILE, 0, SEEK_SET; truncate MAKEFILE, 0; 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 541 Parallel-Prefork-0.14/inc/Module/Install/Fetch.pm0000644000175000017500000000462712147004556021174 0ustar kazuhokazuho#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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; Parallel-Prefork-0.14/inc/Module/Install/ReadmeFromPod.pm0000644000175000017500000000162412147004556022621 0ustar kazuhokazuho#line 1 package Module::Install::ReadmeFromPod; use 5.006; use strict; use warnings; use base qw(Module::Install::Base); use vars qw($VERSION); $VERSION = '0.12'; sub readme_from { my $self = shift; return unless $self->is_admin; my $file = shift || $self->_all_from or die "Can't determine file to make readme_from"; my $clean = shift; print "Writing README from $file\n"; require Pod::Text; my $parser = Pod::Text->new(); open README, '> README' or die "$!\n"; $parser->output_fh( *README ); $parser->parse_file( $file ); if ($clean) { $self->clean_files('README'); } return 1; } sub _all_from { my $self = shift; return unless $self->admin->{extensions}; my ($metadata) = grep { ref($_) eq 'Module::Install::Metadata'; } @{$self->admin->{extensions}}; return unless $metadata; return $metadata->{values}{all_from} || ''; } 'Readme!'; __END__ #line 112 Parallel-Prefork-0.14/inc/Module/Install/Win32.pm0000644000175000017500000000340312147004556021034 0ustar kazuhokazuho#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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; Parallel-Prefork-0.14/inc/Module/Install/WriteAll.pm0000644000175000017500000000237612147004556021665 0ustar kazuhokazuho#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @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} ) { # XXX: This still may be a bit over-defensive... unless ($self->makemaker(6.25)) { $self->makemaker_args( PL_FILES => {} ) if -f 'Build.PL'; } } # 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; Parallel-Prefork-0.14/inc/Module/Install/Metadata.pm0000644000175000017500000004302012147004556021651 0ustar kazuhokazuho#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.00'; @ISA = 'Module::Install::Base'; $ISCORE = 1; } my @boolean_keys = qw{ sign }; my @scalar_keys = qw{ name module_name abstract 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 author }; *authors = \&author; 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; } 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"); } $self->{values}{all_from} = $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) ); # for version integrity check $self->makemaker_args( VERSION_FROM => $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 _extract_perl_version { if ( $_[0] =~ m/ ^\s* (?:use|require) \s* v? ([\d_\.]+) \s* ; /ixms ) { my $perl_version = $1; $perl_version =~ s{_}{}g; return $perl_version; } else { return; } } sub perl_version_from { my $self = shift; my $perl_version=_extract_perl_version(Module::Install::_read($_[0])); if ($perl_version) { $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; # XXX: ugly but should work anyway... if (eval "require Pod::Escapes; 1") { # Pod::Escapes has a mapping table. # It's in core of perl >= 5.9.3, and should be installed # as one of the Pod::Simple's prereqs, which is a prereq # of Pod::Text 3.x (see also below). $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $Pod::Escapes::Name2character_number{$1} ? chr($Pod::Escapes::Name2character_number{$1}) : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } elsif (eval "require Pod::Text; 1" && $Pod::Text::VERSION < 3) { # Pod::Text < 3.0 has yet another mapping table, # though the table name of 2.x and 1.x are different. # (1.x is in core of Perl < 5.6, 2.x is in core of # Perl < 5.9.3) my $mapping = ($Pod::Text::VERSION < 2) ? \%Pod::Text::HTML_Escapes : \%Pod::Text::ESCAPES; $author =~ s{ E<( (\d+) | ([A-Za-z]+) )> } { defined $2 ? chr($2) : defined $mapping->{$1} ? $mapping->{$1} : do { warn "Unknown escape: E<$1>"; "E<$1>"; }; }gex; } else { $author =~ s{E}{<}g; $author =~ s{E}{>}g; } $self->author($author); } else { warn "Cannot determine author info from $_[0]\n"; } } #Stolen from M::B my %license_urls = ( perl => 'http://dev.perl.org/licenses/', apache => 'http://apache.org/licenses/LICENSE-2.0', apache_1_1 => 'http://apache.org/licenses/LICENSE-1.1', 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()' ); $license = __extract_license($license) || lc $license; $self->{values}->{license} = $license; # Automatically fill in license URLs if ( $license_urls{$license} ) { $self->resources( license => $license_urls{$license} ); } return 1; } sub _extract_license { my $pod = shift; my $matched; return __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ L(?i:ICEN[CS]E|ICENSING)\b.*?) (=head \d.*|=cut.*|)\z /xms ) || __extract_license( ($matched) = $pod =~ m/ (=head \d \s+ (?:C(?i:OPYRIGHTS?)|L(?i:EGAL))\b.*?) (=head \d.*|=cut.*|)\z /xms ); } sub __extract_license { my $license_text = shift or return; my @phrases = ( '(?:under )?the same (?:terms|license) as (?:perl|the perl (?:\d )?programming language)' => 'perl', 1, '(?:under )?the terms of (?:perl|the perl programming language) itself' => 'perl', 1, 'Artistic and GPL' => '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, 'GNU Free Documentation license' => 'unrestricted', 1, 'GNU Affero General Public License' => 'open_source', 1, '(?:Free)?BSD license' => 'bsd', 1, 'Artistic license' => 'artistic', 1, 'Apache (?:Software )?license' => 'apache', 1, 'GPL' => 'gpl', 1, 'LGPL' => 'lgpl', 1, 'BSD' => 'bsd', 1, 'Artistic' => 'artistic', 1, 'MIT' => 'mit', 1, 'Mozilla Public License' => 'mozilla', 1, 'Q Public License' => 'open_source', 1, 'OpenSSL License' => 'unrestricted', 1, 'SSLeay License' => 'unrestricted', 1, 'zlib License' => 'open_source', 1, 'proprietary' => 'proprietary', 0, ); while ( my ($pattern, $license, $osi) = splice(@phrases, 0, 3) ) { $pattern =~ s#\s+#\\s+#gs; if ( $license_text =~ /\b$pattern\b/i ) { return $license; } } return ''; } sub license_from { my $self = shift; if (my $license=_extract_license(Module::Install::_read($_[0]))) { $self->license($license); } else { warn "Cannot determine license info from $_[0]\n"; return 'unknown'; } } sub _extract_bugtracker { my @links = $_[0] =~ m#L<( \Qhttp://rt.cpan.org/\E[^>]+| \Qhttp://github.com/\E[\w_]+/[\w_]+/issues| \Qhttp://code.google.com/p/\E[\w_\-]+/issues/list )>#gx; 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 one bugtracker 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; } sub add_metadata { my $self = shift; my %hash = @_; for my $key (keys %hash) { warn "add_metadata: $key is not prefixed with 'x_'.\n" . "Use appopriate function to add non-private metadata.\n" unless $key =~ /^x_/; $self->{values}->{$key} = $hash{$key}; } } ###################################################################### # 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; Parallel-Prefork-0.14/inc/Module/Install/Can.pm0000644000175000017500000000333312147004556020635 0ustar kazuhokazuho#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 = '1.00'; @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 Parallel-Prefork-0.14/inc/Module/Install/Base.pm0000644000175000017500000000214712147004556021010 0ustar kazuhokazuho#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.00'; } # 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->isa('Module::Install::Base::FakeAdmin'); } sub DESTROY {} package Module::Install::Base::FakeAdmin; use vars qw{$VERSION}; BEGIN { $VERSION = $Module::Install::Base::VERSION; } my $fake; sub new { $fake ||= bless(\@_, $_[0]); } sub AUTOLOAD {} sub DESTROY {} # Restore warning handler BEGIN { $SIG{__WARN__} = $SIG{__WARN__}->(); } 1; #line 159 Parallel-Prefork-0.14/inc/Module/Install.pm0000644000175000017500000003013512147004556020134 0ustar kazuhokazuho#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 Cwd (); use File::Find (); use File::Path (); 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 = '1.00'; # Storage for the pseudo-singleton $MAIN = undef; *inc::Module::Install::VERSION = *VERSION; @inc::Module::Install::ISA = __PACKAGE__; } sub import { my $class = shift; my $self = $class->new(@_); my $who = $self->_caller; #------------------------------------------------------------- # all of the following checks should be included in import(), # to allow "eval 'require Module::Install; 1' to test # installation of Module::Install. (RT #51267) #------------------------------------------------------------- # 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 # This reportedly fixes a rare Win32 UTC file time issue, but # as this is a non-cross-platform XS module not in the core, # we shouldn't really depend on it. See RT #24194 for detail. # (Also, this module only supports Perl 5.6 and above). eval "use Win32::UTCFileTime" if $^O eq 'MSWin32' && $] >= 5.006; # 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)); #------------------------------------------------------------- unless ( -f $self->{file} ) { foreach my $key (keys %INC) { delete $INC{$key} if $key =~ /Module\/Install/; } local $^W; 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"}; } local $^W; *{"${who}::AUTOLOAD"} = $self->autoload; $self->preload; # Unregister loader and worker packages so subdirs can use them again delete $INC{'inc/Module/Install.pm'}; delete $INC{'Module/Install.pm'}; # Save to the singleton $MAIN = $self; return 1; } 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; } unless ($$sym =~ s/([^:]+)$//) { # XXX: it looks like we can't retrieve the missing function # via $$sym (usually $main::AUTOLOAD) in this case. # I'm still wondering if we should slurp Makefile.PL to # get some context or not ... my ($package, $file, $line) = caller; die <<"EOT"; Unknown function is found at $file line $line. Execution of $file aborted due to runtime errors. If you're a contributor to a project, you may need to install some Module::Install extensions from CPAN (or other repository). If you're a user of a module, please contact the author. EOT } 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 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 ) { local $^W; *{"${who}::$name"} = sub { ${"${who}::AUTOLOAD"} = "${who}::$name"; goto &{"${who}::AUTOLOAD"}; }; } } sub new { my ($class, %args) = @_; delete $INC{'FindBin.pm'}; { # to suppress the redefine warning local $SIG{__WARN__} = sub {}; require FindBin; } # 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) = @_; my $should_reload = 0; unless ( grep { ! ref $_ and lc $_ eq lc $self->{prefix} } @INC ) { unshift @INC, $self->{prefix}; $should_reload = 1; } foreach my $rv ( $self->find_extensions($path) ) { my ($file, $pkg) = @{$rv}; next if $self->{pathnames}{$pkg}; local $@; my $new = eval { local $^W; require $file; $pkg->can('new') }; unless ( $new ) { warn $@ if $@; next; } $self->{pathnames}{$pkg} = $should_reload ? delete $INC{$file} : $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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _read { local *FH; open( FH, '<', $_[0] ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_NEW sub _read { local *FH; open( FH, "< $_[0]" ) or die "open($_[0]): $!"; my $string = do { local $/; }; close FH or die "close($_[0]): $!"; return $string; } END_OLD 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; } # Done in evals to avoid confusing Perl::MinimumVersion eval( $] >= 5.006 ? <<'END_NEW' : <<'END_OLD' ); die $@ if $@; sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_NEW sub _write { local *FH; open( FH, "> $_[0]" ) or die "open($_[0]): $!"; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } END_OLD # _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 - 2010 Adam Kennedy. Parallel-Prefork-0.14/MANIFEST0000644000175000017500000000101712147005010015302 0ustar kazuhokazuhoChanges 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/ReadmeFromPod.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Parallel/Prefork.pm lib/Parallel/Prefork/SpareWorkers.pm lib/Parallel/Prefork/SpareWorkers/Scoreboard.pm Makefile.PL MANIFEST This list of files META.yml README t/01-base.t t/02-reconfigure.t t/03-spareworkers.t t/04-interval.t t/05-before_after_fork.t Parallel-Prefork-0.14/lib/0000755000175000017500000000000012147005021014722 5ustar kazuhokazuhoParallel-Prefork-0.14/lib/Parallel/0000755000175000017500000000000012147005021016456 5ustar kazuhokazuhoParallel-Prefork-0.14/lib/Parallel/Prefork.pm0000644000175000017500000002372212147004552020442 0ustar kazuhokazuhopackage Parallel::Prefork; use strict; use warnings; use 5.008_001; use base qw/Class::Accessor::Lite/; use List::Util qw/first max min/; use Proc::Wait3 (); use Time::HiRes (); use Class::Accessor::Lite ( rw => [ qw/max_workers spawn_interval err_respawn_interval trap_signals signal_received manager_pid on_child_reap before_fork after_fork/ ], ); our $VERSION = '0.14'; sub new { my $klass = shift; my $opts = @_ == 1 ? $_[0] : +{ @_ }; my $self = bless { worker_pids => {}, max_workers => 10, spawn_interval => 0, err_respawn_interval => 1, trap_signals => { TERM => 'TERM', }, signal_received => '', manager_pid => undef, generation => 0, %$opts, _no_adjust_until => 0, # becomes undef in wait_all_children }, $klass; $SIG{$_} = sub { $self->signal_received($_[0]); } for keys %{$self->trap_signals}; $SIG{CHLD} = sub {}; $self; } sub start { my ($self, $cb) = @_; $self->manager_pid($$); $self->signal_received(''); $self->{generation}++; die 'cannot start another process while you are in child process' if $self->{in_child}; # main loop while (! $self->signal_received) { my $action = $self->{_no_adjust_until} <= Time::HiRes::time() && $self->_decide_action; if ($action > 0) { # start a new worker if (my $subref = $self->before_fork) { $subref->($self); } my $pid = fork; unless (defined $pid) { warn "fork failed:$!"; $self->_update_spawn_delay($self->err_respawn_interval); next; } unless ($pid) { # child process $self->{in_child} = 1; $SIG{$_} = 'DEFAULT' for keys %{$self->trap_signals}; $SIG{CHLD} = 'DEFAULT'; # revert to original exit 0 if $self->signal_received; if ($cb) { $cb->(); $self->finish(); } return; } if (my $subref = $self->after_fork) { $subref->($self, $pid); } $self->{worker_pids}{$pid} = $self->{generation}; $self->_update_spawn_delay($self->spawn_interval); } elsif ($action < 0) { # stop an existing worker kill( $self->_action_for('TERM')->[0], (keys %{$self->{worker_pids}})[0], ); $self->_update_spawn_delay($self->spawn_interval); } $self->{__dbg_callback}->() if $self->{__dbg_callback}; if (my ($exit_pid, $status) = $self->_wait(! $self->{__dbg_callback} && $action <= 0)) { $self->_on_child_reap($exit_pid, $status); if (delete($self->{worker_pids}{$exit_pid}) == $self->{generation} && $status != 0) { $self->_update_spawn_delay($self->err_respawn_interval); } } } # send signals to workers if (my $action = $self->_action_for($self->signal_received)) { my ($sig, $interval) = @$action; if ($interval) { # fortunately we are the only one using delayed_task, so implement # this setup code idempotent and replace the already-registered # callback (if any) my @pids = sort keys %{$self->{worker_pids}}; $self->{delayed_task} = sub { my $self = shift; my $pid = shift @pids; kill $sig, $pid; if (@pids == 0) { delete $self->{delayed_task}; delete $self->{delayed_task_at}; } else { $self->{delayed_task_at} = Time::HiRes::time() + $interval; } }; $self->{delayed_task_at} = 0; $self->{delayed_task}->($self); } else { $self->signal_all_children($sig); } } 1; # return from parent process } sub finish { my ($self, $exit_code) = @_; die "\$parallel_prefork->finish() shouln't be called within the manager process\n" if $self->manager_pid() == $$; exit($exit_code || 0); } sub signal_all_children { my ($self, $sig) = @_; foreach my $pid (sort keys %{$self->{worker_pids}}) { kill $sig, $pid; } } sub num_workers { my $self = shift; return scalar keys %{$self->{worker_pids}}; } sub _decide_action { my $self = shift; return 1 if $self->num_workers < $self->max_workers; return 0; } sub _on_child_reap { my ($self, $exit_pid, $status) = @_; my $cb = $self->on_child_reap; if ($cb) { eval { $cb->($self, $exit_pid, $status); }; # XXX - hmph, what to do here? } } # runs delayed tasks (if any) and returns how many seconds to wait sub _handle_delayed_task { my $self = shift; while (1) { return undef unless $self->{delayed_task}; my $timeleft = $self->{delayed_task_at} - Time::HiRes::time(); return $timeleft if $timeleft > 0; $self->{delayed_task}->($self); } } # returns [sig_to_send, interval_bet_procs] or undef for given recved signal sub _action_for { my ($self, $sig) = @_; my $t = $self->{trap_signals}{$sig} or return undef; $t = [$t, 0] unless ref $t; return $t; } sub wait_all_children { my $self = shift; $self->{_no_adjust_until} = undef; while (%{$self->{worker_pids}}) { if (my ($pid) = $self->_wait(1)) { if (delete $self->{worker_pids}{$pid}) { $self->_on_child_reap($pid, $?); } } } } sub _update_spawn_delay { my ($self, $secs) = @_; $self->{_no_adjust_until} = $secs ? Time::HiRes::time() + $secs : 0; } # wrapper function of Proc::Wait3::wait3 that executes delayed task if any. assumes wantarray == 1 sub _wait { my ($self, $blocking) = @_; if (! $blocking) { $self->_handle_delayed_task(); return Proc::Wait3::wait3(0); } else { my $delayed_task_sleep = $self->_handle_delayed_task(); my $delayed_fork_sleep = $self->_decide_action() > 0 && defined $self->{_no_adjust_until} ? max($self->{_no_adjust_until} - Time::HiRes::time(), 0) : undef; my $sleep_secs = min grep { defined $_ } ( $delayed_task_sleep, $delayed_fork_sleep, ); if (defined $sleep_secs) { # wait max sleep_secs or until signalled select(undef, undef, undef, $sleep_secs); if (my @r = Proc::Wait3::wait3(0)) { return @r; } } else { if (my @r = Proc::Wait3::wait3(1)) { return @r; } } return +(); } } 1; __END__ =head1 NAME Parallel::Prefork - A simple prefork server framework =head1 SYNOPSIS use Parallel::Prefork; my $pm = Parallel::Prefork->new({ max_workers => 10, trap_signals => { TERM => 'TERM', HUP => 'TERM', USR1 => undef, } }); while ($pm->signal_received ne 'TERM') { load_config(); $pm->start(sub { ... do some work within the child process ... }); } $pm->wait_all_children(); =head1 DESCRIPTION C is much like C, but supports graceful shutdown and run-time reconfiguration. =head1 METHODS =head2 new instantiation. Takes a hashref as an argument. Recognized attributes are as follows. =head3 max_workers number of worker processes (default: 10) =head3 spawn_interval interval in seconds between spawning child processes unless a child process exits abnormally (default: 0) =head3 err_respawn_interval number of seconds to deter spawning of child processes after a worker exits abnormally (default: 1) =head3 trap_signals hashref of signals to be trapped. Manager process will trap the signals listed in the keys of the hash, and send the signal specified in the associated value (if any) to all worker processes. If the associated value is a scalar then it is treated as the name of the signal to be sent immediately to all the worker processes. If the value is an arrayref the first value is treated the name of the signal and the second value is treated as the interval (in seconds) between sending the signal to each worker process. =head3 on_child_reap coderef that is called when a child is reaped. Receives the instance to the current Parallel::Prefork, the child's pid, and its exit status. =head3 before_fork =head3 after_fork coderefs that are called in the manager process before and after fork, if being set =head2 start The main routine. There are two ways to use the function. If given a subref as an argument, forks child processes and executes that subref within the child processes. The processes will exit with 0 status when the subref returns. The other way is to not give any arguments to the function. The function returns undef in child processes. Caller should execute the application logic and then call C to terminate the process. The C function returns true within manager process upon receiving a signal specified in the C hashref. =head2 finish Child processes (when executed by a zero-argument call to C) should call this function for termination. Takes exit code as an optional argument. Only usable from child processes. =head2 signal_all_children Sends signal to all worker processes. Only usable from manager process. =head2 wait_all_children Blocks until all worker processes exit. Only usable from manager process. =head1 AUTHOR Kazuho Oku =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Parallel-Prefork-0.14/lib/Parallel/Prefork/0000755000175000017500000000000012147005021020066 5ustar kazuhokazuhoParallel-Prefork-0.14/lib/Parallel/Prefork/SpareWorkers.pm0000644000175000017500000001056012147004120023054 0ustar kazuhokazuhopackage Parallel::Prefork::SpareWorkers; use strict; use warnings; use Exporter qw(import); use List::MoreUtils qw(uniq); use base qw/Parallel::Prefork/; use constant STATUS_NEXIST => '.'; use constant STATUS_IDLE => '_'; our %EXPORT_TAGS = ( status => [ qw(STATUS_NEXIST STATUS_IDLE) ], ); our @EXPORT_OK = uniq sort map { @$_ } values %EXPORT_TAGS; $EXPORT_TAGS{all} = \@EXPORT_OK; __PACKAGE__->mk_accessors(qw/min_spare_workers max_spare_workers scoreboard/); sub new { my $klass = shift; my $self = $klass->SUPER::new(@_); die "mandatory option min_spare_workers not set" unless $self->{min_spare_workers}; $self->{max_spare_workers} ||= $self->max_workers; $self->{scoreboard} ||= do { require 'Parallel/Prefork/SpareWorkers/Scoreboard.pm'; Parallel::Prefork::SpareWorkers::Scoreboard->new( $self->{scoreboard_file} || undef, $self->max_workers, ); }; $self; } sub start { my $self = shift; my $ret = $self->SUPER::start(); unless ($ret) { # child process $self->scoreboard->child_start(); return; } return 1; } sub num_active_workers { my $self = shift; scalar grep { $_ ne STATUS_NEXIST && $_ ne STATUS_IDLE } $self->scoreboard->get_statuses; } sub set_status { my ($self, $status) = @_; $self->scoreboard->set_status($status); } sub _decide_action { my $self = shift; my $spare_workers = $self->num_workers - $self->num_active_workers; return 1 if $spare_workers < $self->min_spare_workers && $self->num_workers < $self->max_workers; return -1 if $spare_workers > $self->max_spare_workers; return 0; } sub _on_child_reap { my ($self, $exit_pid, $status) = @_; $self->SUPER::_on_child_reap($exit_pid, $status); $self->scoreboard->clear_child($exit_pid); } 1; __END__ =head1 NAME Parallel::Prefork::SpareWorkers - A prefork server framework with support for (min|max)spareservers =head1 SYNOPSIS use Parallel::Prefork::SpareWorkers qw(:status); my $pm = Parallel::Prefork::SpareWorkers->new({ max_workers => 40, min_spare_workers => 5, max_spare_workers => 10, trap_signals => { TERM => 'TERM', HUP => 'TERM', USR1 => undef, }, }); while ($pm->signal_received ne 'TERM') { load_config(); $pm->start and next; # do what ever you like, as follows while (my $sock = $listener->accept()) { $pm->set_status('A'); ... $sock->close(); $pm->set_status(STATUS_IDLE); } $pm->finish; } $pm->wait_all_children; =head1 DESCRIPTION C is a subclass of C that supports setting minimum and maximum number of spare worker processes, a feature commonly found in network servers. The module adds to C several initialization parameters, constants, and a method to set state of the worker processes. =head1 METHODS =head2 new Instantiation. C recognizes the following parameters in addition to those defined by C. The parameters can be accessed using accessors with same names as well. =head3 min_spare_workers minimum number of spare workers (mandatory) =head3 max_spare_workers maxmum number of spare workers (default: max_workers) =head3 scoreboard_file filename of scoreboard. If not set, C will create a temporary file. =head2 set_status sets a single-byte character state of the worker process. Worker processes should set any character of their choice using the function (but not one of the reserved characters) to declare that it is running some kind of task. Or the state should be set to C '_' once the worker enters idle state. The other reserved character is C '.' which should never be set directly by applications. =head1 CONSTANTS =head2 STATUS_NEXIST scoreboard status character '.', meaning no worker process is assigned to the slot of the scoreboard. Applications should never set this value directly. =head2 STATUS_IDLE scoreboard status character '_', meaning that a worker process is in idle state =head1 LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html =cut Parallel-Prefork-0.14/lib/Parallel/Prefork/SpareWorkers/0000755000175000017500000000000012147005021022515 5ustar kazuhokazuhoParallel-Prefork-0.14/lib/Parallel/Prefork/SpareWorkers/Scoreboard.pm0000644000175000017500000000720511501347342025152 0ustar kazuhokazuhopackage Parallel::Prefork::SpareWorkers::Scoreboard; use strict; use warnings; use Fcntl qw(:DEFAULT :flock); use File::Temp qw(); use POSIX qw(SEEK_SET); use Scope::Guard; use Parallel::Prefork::SpareWorkers qw(:status); # format of each slot: STATUS_CHAR PID(15bytes,left-aligned) "\n" use constant SLOT_SIZE => 16; use constant EMPTY_SLOT => STATUS_NEXIST . (' ' x (SLOT_SIZE - 2)) . "\n"; sub _format_slot { my ($state, $pid) = @_; substr($state, 0, 1) . sprintf "%-14d\n", $pid; } sub new { my ($klass, $filename, $max_workers) = @_; # create scoreboard file $filename ||= File::Temp::tempdir(CLEANUP => 1) . '/scoreboard'; sysopen my $fh, $filename, O_RDWR | O_CREAT | O_EXCL or die "failed to create scoreboard file:$filename:$!"; my $wlen = syswrite $fh, EMPTY_SLOT x $max_workers; die "failed to initialize scoreboad file:$filename:$!" unless $wlen == SLOT_SIZE * $max_workers; my $self = bless { filename => $filename, fh => $fh, max_workers => $max_workers, slot => undef, }, $klass; $self; } sub get_statuses { my $self = shift; sysseek $self->{fh}, 0, SEEK_SET or die "seek failed:$!"; sysread($self->{fh}, my $sb, $self->{max_workers} * SLOT_SIZE) == $self->{max_workers} * SLOT_SIZE or die "failed to read status:$!"; my @s = map { $_ =~ /^(.)/ ? ($1) : () } split /\n/, $sb; } sub clear_child { my ($self, $pid) = @_; my $lock = $self->_lock_file; sysseek $self->{fh}, 0, SEEK_SET or die "seek failed:$!"; for (my $slot = 0; $slot < $self->{max_workers}; $slot++) { my $rlen = sysread($self->{fh}, my $data, SLOT_SIZE); die "unexpected eof while reading scoreboard file:$!" unless $rlen == SLOT_SIZE; if ($data =~ /^.$pid[ ]*\n$/) { # found sysseek $self->{fh}, SLOT_SIZE * $slot, SEEK_SET or die "seek failed:$!"; my $wlen = syswrite $self->{fh}, EMPTY_SLOT; die "failed to clear scoreboard file:$self->{filename}:$!" unless $wlen == SLOT_SIZE; last; } } } sub child_start { my $self = shift; die "child_start cannot be called twite" if defined $self->{slot}; close $self->{fh} or die "failed to close scoreboard file:$!"; sysopen $self->{fh}, $self->{filename}, O_RDWR or die "failed to create scoreboard file:$self->{filename}:$!"; my $lock = $self->_lock_file; for ($self->{slot} = 0; $self->{slot} < $self->{max_workers}; $self->{slot}++) { my $rlen = sysread $self->{fh}, my $data, SLOT_SIZE; die "unexpected response from sysread:$rlen, expected @{[SLOT_SIZE]}:$!" if $rlen != SLOT_SIZE; if ($data =~ /^.[ ]+\n$/o) { last; } } die "no empty slot in scoreboard" if $self->{slot} >= $self->{max_workers}; $self->set_status(STATUS_IDLE); } sub set_status { my ($self, $status) = @_; die "child_start not called?" unless defined $self->{slot}; sysseek $self->{fh}, $self->{slot} * SLOT_SIZE, SEEK_SET or die "seek failed:$!"; my $wlen = syswrite $self->{fh}, _format_slot($status, $$); die "failed to write status into scoreboard:$!" unless $wlen == SLOT_SIZE; } sub _lock_file { my $self = shift; my $fh = $self->{fh}; flock $fh, LOCK_EX or die "failed to lock scoreboard file:$!"; return Scope::Guard->new( sub { flock $fh, LOCK_UN or die "failed to unlock scoreboard file:$!"; }, ); } 1; Parallel-Prefork-0.14/t/0000755000175000017500000000000012147005021014417 5ustar kazuhokazuhoParallel-Prefork-0.14/t/01-base.t0000755000175000017500000000247711501347342015761 0ustar kazuhokazuho#! /usr/bin/perl use strict; use warnings; use Fcntl qw/:flock/; use File::Temp qw/tempfile/; use Test::More tests => 5; use_ok('Parallel::Prefork'); my $reaped = 0; my $pm; eval { $pm = Parallel::Prefork->new({ max_workers => 10, fork_delay => 0, on_child_reap => sub { $reaped++; } }); }; ok($pm); my ($fh, $filename) = tempfile; syswrite $fh, '0', 1; close $fh; my $ppid = $$; my $c; until ($pm->signal_received) { $pm->start and next; open $fh, '+<', $filename or die "failed to open temporary file: $filename: "; flock $fh, LOCK_EX; sysread $fh, $c, 10; $c++; seek $fh, 0, 0; syswrite $fh, $c, length($c); flock $fh, LOCK_UN; local $SIG{TERM} = sub { flock $fh, LOCK_EX; seek $fh, 0, 0; sysread $fh, $c, 10; $c++; seek $fh, 0, 0; syswrite $fh, $c, length($c); flock $fh, LOCK_UN; exit 0; }; if ($c == $pm->max_workers) { kill 'TERM', $ppid; } sleep 100; $pm->finish; } ok(1); $pm->wait_all_children; open $fh, '<', $filename or die "failed to open temporary file: $filename: "; sysread $fh, $c, 10; close $fh; is($c, $pm->max_workers * 2); is($reaped, $pm->max_workers, "properly called on_child_reap callback"); unlink $filename; Parallel-Prefork-0.14/t/03-spareworkers.t0000644000175000017500000000377511502351063017573 0ustar kazuhokazuhouse strict; use warnings; use File::Temp qw(); use Time::HiRes qw(sleep); use Test::More tests => 8; use_ok('Parallel::Prefork::SpareWorkers'); my $tempdir = File::Temp::tempdir(CLEANUP => 1); my $pm = Parallel::Prefork::SpareWorkers->new({ min_spare_workers => 3, max_spare_workers => 5, max_workers => 10, err_respawn_interval => 0, trap_signals => { TERM => 'TERM', }, }); is $pm->num_active_workers, 0, 'no active workers'; my @tests = ( wait_and_test( sub { is $pm->num_workers, 3, 'min_spare_workers'; is $pm->num_active_workers, 0, 'no active workers'; open my $fh, '>', "$tempdir/active" or die "failed to touch file $tempdir/active:$!"; close $fh; }, ), wait_and_test( sub { is $pm->num_workers, 10, 'max_workers'; is $pm->num_active_workers, 10, 'all workers active'; unlink "$tempdir/active" or die "failed to unlink file $tempdir/active:$!"; }, ), wait_and_test( sub { is $pm->num_workers, 5, 'max_spare_workers'; is $pm->num_active_workers, 0, 'no active workers'; }, ), ); next_test(); while ($pm->signal_received ne 'TERM') { $pm->start and next; while (1) { $pm->set_status( -e "$tempdir/active" ? 'A' : Parallel::Prefork::SpareWorkers::STATUS_IDLE(), ); sleep 1; } } $pm->wait_all_children; sub wait_and_test { my $check_func = shift; my $cnt = 0; return sub { sleep 0.1; $cnt++; return if $cnt < 30; # 1 second until all clients update their state, plus 10 invocations to min/max the process, plus 1 second bonus $check_func->(); next_test(); }; } sub next_test { if (@tests) { $pm->{__dbg_callback} = shift @tests; } else { $pm->{__dbg_callback} = sub {}; $pm->signal_received('TERM'); } } Parallel-Prefork-0.14/t/02-reconfigure.t0000755000175000017500000000115311506335504017350 0ustar kazuhokazuho#! /usr/bin/perl use strict; use warnings; use Test::More tests => 3; use_ok('Parallel::Prefork'); my $pm; eval { $pm = Parallel::Prefork->new({ max_workers => 1, trap_signals => { TERM => 'TERM', HUP => 'TERM', }, }); }; ok($pm); my $c = 0; while ($pm->signal_received ne 'TERM') { $c++; $pm->start( sub { sleep 1; if ($c == 1) { kill 'HUP', $pm->manager_pid; } else { kill 'TERM', $pm->manager_pid; } }, ); } $pm->wait_all_children; is($c, 2); Parallel-Prefork-0.14/t/05-before_after_fork.t0000644000175000017500000000135012147004120020470 0ustar kazuhokazuhouse strict; use warnings; use Test::More; use Test::SharedFork; use Parallel::Prefork; my $i = 0; my $j = 0; my $pm = Parallel::Prefork->new({ max_workers => 3, trap_signals => { TERM => 'TERM', }, before_fork => sub { my $pm = shift; $i++; }, after_fork => sub { my ($pm, $pid) = @_; $j++; }, }); while ( $pm->signal_received ne 'TERM' ) { $pm->start( sub { if ( $i == 10 ) { kill TERM => $pm->manager_pid; } } ); } $pm->wait_all_children; cmp_ok($i, '>=', 10, 'before_fork callback was called 10 times at least'); cmp_ok($j, '>=', 10, 'after_fork callback was called 10 times at least'); done_testing; Parallel-Prefork-0.14/t/04-interval.t0000644000175000017500000000247611502374104016667 0ustar kazuhokazuhouse strict; use warnings; use File::Temp (); use Parallel::Prefork; use Time::HiRes qw(sleep); use Test::Requires qw(Parallel::Scoreboard); use Test::More tests => 6; my $sb = Parallel::Scoreboard->new( base_dir => File::Temp::tempdir(CLEANUP => 1), ); if (my $pid = fork) { # parent sleep 0.5; is scalar(keys %{$sb->read_all}), 1, 'workers at 0.5 sec'; sleep 1; is scalar(keys %{$sb->read_all}), 2, 'workers at 1.5 sec'; sleep 1; is scalar(keys %{$sb->read_all}), 3, 'workers at 2.5 sec'; sleep 1; is scalar(keys %{$sb->read_all}), 3, 'workers at 3.5 sec'; kill 'TERM', $pid; sleep 0.5; is scalar(keys %{$sb->read_all}), 2, 'workers at 4 sec'; sleep 2; is scalar(keys %{$sb->read_all}), 1, 'workers at 6 sec'; while (wait == -1) {} } else { # child my $pm = Parallel::Prefork->new({ max_workers => 3, spawn_interval => 1, trap_signals => { TERM => [ 'TERM', 2 ], HUP => 'TERM', }, }); while ($pm->signal_received ne 'TERM') { $pm->start and next; # worker process my $term_req; $SIG{TERM} = sub { $term_req = 1 }; $sb->update('A'); sleep 1000 until $term_req; $pm->finish; } $pm->wait_all_children; exit 0; } Parallel-Prefork-0.14/Makefile.PL0000644000175000017500000000046312147004120016130 0ustar kazuhokazuhouse inc::Module::Install; all_from 'lib/Parallel/Prefork.pm'; readme_from 'lib/Parallel/Prefork.pm'; requires 'Class::Accessor::Lite' => 0.04; requires 'List::MoreUtils'; requires 'Proc::Wait3' => 0.03; requires 'Scope::Guard'; test_requires 'Test::Requires'; test_requires 'Test::SharedFork'; WriteAll; Parallel-Prefork-0.14/Changes0000644000175000017500000000233012147004543015455 0ustar kazuhokazuhoRevision history for Perl extension Parallel::Prefork. 0.14 - fix doc issues 0.13 - repackage 0.12 (tar xf fails with 0.12 on some platforms) 0.12 - support for pre/post fork callbacks 0.11 - suppress warning in perl < 5.10 0.10 - support new style: $pm->start(sub { ... }) (thanks to confound) - collect zombie processes without any delay when spawn_interval is nonzero - do not sleep spawn_interval seconds when a worker process exits non-zero and if err_repawn_interval < spawn_interval 0.09 - support for slow startup (with the new spawn_interval parameter) and slow shutdown (by passing arrayrefs as values of the trap_signals hashref) 0.08 - fix test (compatibility with older versions of Test::More, timing was too severe) 0.07 - fix compilation error on perl 5.10.0 0.06 - add Parallel::Prefork::SpareWorkers 0.05 - Wed Sep 23 20:25:00 JST 2009 - do not die on fork failure 0.04 - Mon Sep 29 13:04:00 JST 2008 - add on_child_reap callback (by lestrrat) 0.03 - Fri Apr 11 14:30:00 JST 2008 - declare dependency against Class::Accessor::Fast 0.02 - Mon Apr 07 00:00:00 JST 2008 - only delay respawning a new worker process if prev. exited abnormally 0.01 - Fri Apr 04 00:00:00 JST 2008 - initial release Parallel-Prefork-0.14/README0000644000175000017500000000611312147004556015051 0ustar kazuhokazuhoNAME Parallel::Prefork - A simple prefork server framework SYNOPSIS use Parallel::Prefork; my $pm = Parallel::Prefork->new({ max_workers => 10, trap_signals => { TERM => 'TERM', HUP => 'TERM', USR1 => undef, } }); while ($pm->signal_received ne 'TERM') { load_config(); $pm->start(sub { ... do some work within the child process ... }); } $pm->wait_all_children(); DESCRIPTION "Parallel::Prefork" is much like "Parallel::ForkManager", but supports graceful shutdown and run-time reconfiguration. METHODS new instantiation. Takes a hashref as an argument. Recognized attributes are as follows. max_workers number of worker processes (default: 10) spawn_interval interval in seconds between spawning child processes unless a child process exits abnormally (default: 0) err_respawn_interval number of seconds to deter spawning of child processes after a worker exits abnormally (default: 1) trap_signals hashref of signals to be trapped. Manager process will trap the signals listed in the keys of the hash, and send the signal specified in the associated value (if any) to all worker processes. If the associated value is a scalar then it is treated as the name of the signal to be sent immediately to all the worker processes. If the value is an arrayref the first value is treated the name of the signal and the second value is treated as the interval (in seconds) between sending the signal to each worker process. on_child_reap coderef that is called when a child is reaped. Receives the instance to the current Parallel::Prefork, the child's pid, and its exit status. before_fork after_fork coderefs that are called in the manager process before and after fork, if being set start The main routine. There are two ways to use the function. If given a subref as an argument, forks child processes and executes that subref within the child processes. The processes will exit with 0 status when the subref returns. The other way is to not give any arguments to the function. The function returns undef in child processes. Caller should execute the application logic and then call "finish" to terminate the process. The "start" function returns true within manager process upon receiving a signal specified in the "trap_signals" hashref. finish Child processes (when executed by a zero-argument call to "start") should call this function for termination. Takes exit code as an optional argument. Only usable from child processes. signal_all_children Sends signal to all worker processes. Only usable from manager process. wait_all_children Blocks until all worker processes exit. Only usable from manager process. AUTHOR Kazuho Oku LICENSE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://www.perl.com/perl/misc/Artistic.html Parallel-Prefork-0.14/META.yml0000644000175000017500000000122112147004557015436 0ustar kazuhokazuho--- abstract: 'A simple prefork server framework' author: - 'Kazuho Oku' build_requires: ExtUtils::MakeMaker: 6.42 Test::Requires: 0 Test::SharedFork: 0 configure_requires: ExtUtils::MakeMaker: 6.42 distribution_type: module generated_by: 'Module::Install version 1.00' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 module_name: Parallel::Prefork name: Parallel-Prefork no_index: directory: - inc - t requires: Class::Accessor::Lite: 0.04 List::MoreUtils: 0 Proc::Wait3: 0.03 Scope::Guard: 0 perl: 5.8.1 resources: license: http://dev.perl.org/licenses/ version: 0.14