Parallel-Prefork-0.18/0000755€–Rz€ZĂ);0000000000012656535775014714 5ustar kazuhokazuhoParallel-Prefork-0.18/Changes0000644€–Rz€ZĂ);0000000327512656533761016207 0ustar kazuhokazuhoRevision history for Perl extension Parallel::Prefork. 0.18 - fix the broken $pm->wait_all_children without timeout (by shogo82148) 0.17 - fix the broken $pm->wait_all_children with timeout 0.16 - $pm->wait_all_children takes an optional argument specifying a timeout value (in seconds) (by karupanerura) 0.15 - fix bug in Parallel::Prefork::SpareWorkers that did not spawn proceses up to the given maximum number - fix crash in Parallel::Prefork::SpareWorkers when it receives a signal while reading the status file (by Perlover) 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.18/inc/0000755€–Rz€ZĂ);0000000000012656535775015465 5ustar kazuhokazuhoParallel-Prefork-0.18/inc/Module/0000755€–Rz€ZĂ);0000000000012656535775016712 5ustar kazuhokazuhoParallel-Prefork-0.18/inc/Module/Install/0000755€–Rz€ZĂ);0000000000012656535775020320 5ustar kazuhokazuhoParallel-Prefork-0.18/inc/Module/Install/Base.pm0000644€–Rz€ZĂ);0000000214712656535172021523 0ustar kazuhokazuho#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.14'; } # 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.18/inc/Module/Install/Can.pm0000644€–Rz€ZĂ);0000000615712656535172021357 0ustar kazuhokazuho#line 1 package Module::Install::Can; use strict; use Config (); use ExtUtils::MakeMaker (); use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @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 ''; require File::Spec; my $abs = File::Spec->catfile($dir, $cmd); return $abs if (-x $abs or $abs = MM->maybe_command($abs)); } return; } # Can our C compiler environment build XS files sub can_xs { my $self = shift; # Ensure we have the CBuilder module $self->configure_requires( 'ExtUtils::CBuilder' => 0.27 ); # Do we have the configure_requires checker? local $@; eval "require ExtUtils::CBuilder;"; if ( $@ ) { # They don't obey configure_requires, so it is # someone old and delicate. Try to avoid hurting # them by falling back to an older simpler test. return $self->can_cc(); } # Do we have a working C compiler my $builder = ExtUtils::CBuilder->new( quiet => 1, ); unless ( $builder->have_compiler ) { # No working C compiler return 0; } # Write a C file representative of what XS becomes require File::Temp; my ( $FH, $tmpfile ) = File::Temp::tempfile( "compilexs-XXXXX", SUFFIX => '.c', ); binmode $FH; print $FH <<'END_C'; #include "EXTERN.h" #include "perl.h" #include "XSUB.h" int main(int argc, char **argv) { return 0; } int boot_sanexs() { return 1; } END_C close $FH; # Can the C compiler access the same headers XS does my @libs = (); my $object = undef; eval { local $^W = 0; $object = $builder->compile( source => $tmpfile, ); @libs = $builder->link( objects => $object, module_name => 'sanexs', ); }; my $result = $@ ? 0 : 1; # Clean up all the build files foreach ( $tmpfile, $object, @libs ) { next unless defined $_; 1 while unlink; } return $result; } # 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 236 Parallel-Prefork-0.18/inc/Module/Install/Fetch.pm0000644€–Rz€ZĂ);0000000462712656535172021707 0ustar kazuhokazuho#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @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.18/inc/Module/Install/Makefile.pm0000644€–Rz€ZĂ);0000002743712656535172022377 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.14'; @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-separated 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 ) { # This previous attempted to inherit the version of # ExtUtils::MakeMaker in use by the module author, but this # was found to be untenable as some authors build releases # using future dev versions of EU:MM that nobody else has. # Instead, #toolchain suggests we use 6.59 which is the most # stable version on CPAN at time of writing and is, to quote # ribasushi, "not terminally fucked, > and tested enough". # TODO: We will now need to maintain this over time to push # the version up as new versions are released. $self->build_requires( 'ExtUtils::MakeMaker' => 6.59 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.59 ); } 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.36 ); $self->configure_requires( 'ExtUtils::MakeMaker' => 6.36 ); } # 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 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 544 Parallel-Prefork-0.18/inc/Module/Install/Metadata.pm0000644€–Rz€ZĂ);0000004330212656535172022367 0ustar kazuhokazuho#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @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; my $value = @_ ? shift : 1; if ( $self->{values}->{dynamic_config} ) { # Once dynamic we never change to static, for safety return 0; } $self->{values}->{dynamic_config} = $value ? 1 : 0; return 1; } # Convenience command sub static_config { shift->dynamic_config(0); } 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 really 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 2\.0' => 'artistic_2', 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<( https?\Q://rt.cpan.org/\E[^>]+| https?\Q://github.com/\E[\w_]+/[\w_]+/issues| https?\Q://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+(v?[\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 hashes 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.18/inc/Module/Install/ReadmeFromPod.pm0000644€–Rz€ZĂ);0000000631112656535172023332 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.22'; sub readme_from { my $self = shift; return unless $self->is_admin; # Input file my $in_file = shift || $self->_all_from or die "Can't determine file to make readme_from"; # Get optional arguments my ($clean, $format, $out_file, $options); my $args = shift; if ( ref $args ) { # Arguments are in a hashref if ( ref($args) ne 'HASH' ) { die "Expected a hashref but got a ".ref($args)."\n"; } else { $clean = $args->{'clean'}; $format = $args->{'format'}; $out_file = $args->{'output_file'}; $options = $args->{'options'}; } } else { # Arguments are in a list $clean = $args; $format = shift; $out_file = shift; $options = \@_; } # Default values; $clean ||= 0; $format ||= 'txt'; # Generate README print "readme_from $in_file to $format\n"; if ($format =~ m/te?xt/) { $out_file = $self->_readme_txt($in_file, $out_file, $options); } elsif ($format =~ m/html?/) { $out_file = $self->_readme_htm($in_file, $out_file, $options); } elsif ($format eq 'man') { $out_file = $self->_readme_man($in_file, $out_file, $options); } elsif ($format eq 'pdf') { $out_file = $self->_readme_pdf($in_file, $out_file, $options); } if ($clean) { $self->clean_files($out_file); } return 1; } sub _readme_txt { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README'; require Pod::Text; my $parser = Pod::Text->new( @$options ); open my $out_fh, '>', $out_file or die "Could not write file $out_file:\n$!\n"; $parser->output_fh( *$out_fh ); $parser->parse_file( $in_file ); close $out_fh; return $out_file; } sub _readme_htm { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.htm'; require Pod::Html; Pod::Html::pod2html( "--infile=$in_file", "--outfile=$out_file", @$options, ); # Remove temporary files if needed for my $file ('pod2htmd.tmp', 'pod2htmi.tmp') { if (-e $file) { unlink $file or warn "Warning: Could not remove file '$file'.\n$!\n"; } } return $out_file; } sub _readme_man { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.1'; require Pod::Man; my $parser = Pod::Man->new( @$options ); $parser->parse_from_file($in_file, $out_file); return $out_file; } sub _readme_pdf { my ($self, $in_file, $out_file, $options) = @_; $out_file ||= 'README.pdf'; eval { require App::pod2pdf; } or die "Could not generate $out_file because pod2pdf could not be found\n"; my $parser = App::pod2pdf->new( @$options ); $parser->parse_from_file($in_file); open my $out_fh, '>', $out_file or die "Could not write file $out_file:\n$!\n"; select $out_fh; $parser->output; select STDOUT; close $out_fh; return $out_file; } 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 254 Parallel-Prefork-0.18/inc/Module/Install/Win32.pm0000644€–Rz€ZĂ);0000000340312656535172021547 0ustar kazuhokazuho#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @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.18/inc/Module/Install/WriteAll.pm0000644€–Rz€ZĂ);0000000237612656535172022400 0ustar kazuhokazuho#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.14'; @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.18/inc/Module/Install.pm0000644€–Rz€ZĂ);0000003021712656535172020650 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.006; 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.14'; # 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::getcwd(); my $sym = "${who}::AUTOLOAD"; $sym->{$cwd} = sub { my $pwd = Cwd::getcwd(); 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::getcwd()) 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 /\n/, $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]): $!"; binmode FH; 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]): $!"; binmode FH; 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]): $!"; binmode FH; 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]): $!"; binmode FH; 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($_[1]) <=> _version($_[2]); } # 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 - 2012 Adam Kennedy. Parallel-Prefork-0.18/lib/0000755€–Rz€ZĂ);0000000000012656535775015462 5ustar kazuhokazuhoParallel-Prefork-0.18/lib/Parallel/0000755€–Rz€ZĂ);0000000000012656535775017216 5ustar kazuhokazuhoParallel-Prefork-0.18/lib/Parallel/Prefork/0000755€–Rz€ZĂ);0000000000012656535775020626 5ustar kazuhokazuhoParallel-Prefork-0.18/lib/Parallel/Prefork/SpareWorkers/0000755€–Rz€ZĂ);0000000000012656535775023255 5ustar kazuhokazuhoParallel-Prefork-0.18/lib/Parallel/Prefork/SpareWorkers/Scoreboard.pm0000644€–Rz€ZĂ);0000000763412334353736025674 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 Signal::Mask; 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 { local ($Signal::Mask{CHLD}, $Signal::Mask{TERM}, $Signal::Mask{INT}) = (1, 1, 1); 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 { local ($Signal::Mask{CHLD}, $Signal::Mask{TERM}, $Signal::Mask{INT}) = (1, 1, 1); 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 { local ($Signal::Mask{CHLD}, $Signal::Mask{TERM}, $Signal::Mask{INT}) = (1, 1, 1); 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.18/lib/Parallel/Prefork/SpareWorkers.pm0000644€–Rz€ZĂ);0000001117412334353736023603 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 heartbeat/); 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->{heartbeat} ||= 0.25; $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); } sub _max_wait { my $self = shift; return $self->{heartbeat}; } 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 heartbeat a fractional period (in seconds) of child amount checking. Do not use very small numbers to avoid frequent use of CPU (default: 0.25) =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.18/lib/Parallel/Prefork.pm0000644€–Rz€ZĂ);0000002553112656533772021165 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.18'; 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, $timeout) = @_; $self->{_no_adjust_until} = undef; my $call_wait = sub { my $blocking = shift; if (my ($pid) = $self->_wait($blocking)) { if (delete $self->{worker_pids}{$pid}) { $self->_on_child_reap($pid, $?); } return $pid; } return; }; if ($timeout) { # the strategy is to use waitpid + sleep that gets interrupted by SIGCHLD # but since there is a race condition bet. waitpid and sleep, the argument # to sleep should be set to a small number (and we use 1 second). my $start_at = [Time::HiRes::gettimeofday]; while ($self->num_workers != 0 && Time::HiRes::tv_interval($start_at) < $timeout) { unless ($call_wait->(0)) { sleep 1; } } } else { while ($self->num_workers != 0) { $call_wait->(1); } } return $self->num_workers; } 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, $self->_max_wait(), ); 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 +(); } } sub _max_wait { return undef; } 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() =head2 wait_all_children($timeout) Waits until all worker processes exit or timeout (given as an optional argument in seconds) exceeds. The method returns the number of the worker processes still running. =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.18/Makefile.PL0000644€–Rz€ZĂ);0000000051412334353736016652 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'; requires 'Signal::Mask'; test_requires 'Test::Requires'; test_requires 'Test::SharedFork'; WriteAll; Parallel-Prefork-0.18/MANIFEST0000644€–Rz€ZĂ);0000000116412656535746016045 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 MYMETA.json MYMETA.yml README t/01-base.t t/02-reconfigure.t t/03-spareworkers.t t/04-interval.t t/05-before_after_fork.t t/06-wait-all-children-with-timeout.t t/07-wait-all-children-does-not-block.t Parallel-Prefork-0.18/META.yml0000644€–Rz€ZĂ);0000000126712656535173016163 0ustar kazuhokazuho--- abstract: 'A simple prefork server framework' author: - 'Kazuho Oku' build_requires: ExtUtils::MakeMaker: 6.59 Test::Requires: 0 Test::SharedFork: 0 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.14' 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 Signal::Mask: 0 perl: 5.8.1 resources: license: http://dev.perl.org/licenses/ version: '0.18' Parallel-Prefork-0.18/MYMETA.json0000644€–Rz€ZĂ);0000000235412656535172016576 0ustar kazuhokazuho{ "abstract" : "A simple prefork server framework", "author" : [ "Kazuho Oku" ], "dynamic_config" : 0, "generated_by" : "Module::Install version 1.08, CPAN::Meta::Converter version 2.150001", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Parallel-Prefork", "no_index" : { "directory" : [ "inc", "t" ] }, "prereqs" : { "build" : { "requires" : { "ExtUtils::MakeMaker" : "6.59", "Test::Requires" : "0", "Test::SharedFork" : "0" } }, "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "runtime" : { "requires" : { "Class::Accessor::Lite" : "0.04", "List::MoreUtils" : "0", "Proc::Wait3" : "0.03", "Scope::Guard" : "0", "Signal::Mask" : "0", "perl" : "5.008001" } } }, "release_status" : "stable", "resources" : { "license" : [ "http://dev.perl.org/licenses/" ] }, "version" : "0.17", "x_module_name" : "Parallel::Prefork" } Parallel-Prefork-0.18/MYMETA.yml0000644€–Rz€ZĂ);0000000133512656535172016424 0ustar kazuhokazuho--- abstract: 'A simple prefork server framework' author: - 'Kazuho Oku' build_requires: ExtUtils::MakeMaker: '6.59' Test::Requires: '0' Test::SharedFork: '0' configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Module::Install version 1.08, CPAN::Meta::Converter version 2.150001' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Parallel-Prefork no_index: directory: - inc - t requires: Class::Accessor::Lite: '0.04' List::MoreUtils: '0' Proc::Wait3: '0.03' Scope::Guard: '0' Signal::Mask: '0' perl: '5.008001' resources: license: http://dev.perl.org/licenses/ version: '0.17' x_module_name: Parallel::Prefork Parallel-Prefork-0.18/README0000644€–Rz€ZĂ);0000000631712656535172015572 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() wait_all_children($timeout) Waits until all worker processes exit or timeout (given as an optional argument in seconds) exceeds. The method returns the number of the worker processes still running. 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.18/t/0000755€–Rz€ZĂ);0000000000012656535775015157 5ustar kazuhokazuhoParallel-Prefork-0.18/t/01-base.t0000755€–Rz€ZĂ);0000000247712334353736016475 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.18/t/02-reconfigure.t0000755€–Rz€ZĂ);0000000115312334353736020062 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.18/t/03-spareworkers.t0000644€–Rz€ZĂ);0000000321712334353736020302 0ustar kazuhokazuhouse strict; use warnings; use File::Temp qw(); 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 = ( 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; }, 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:$!"; }, sub { is $pm->num_workers, 5, 'max_spare_workers'; is $pm->num_active_workers, 0, 'no active workers'; }, ); my $SLEEP_SECS = 3; # 1 second until all clients update their state, plus 10 invocations to min/max the process, plus 1 second bonus $SIG{ALRM} = sub { my $test = shift @tests; $test->(); if (@tests) { alarm $SLEEP_SECS; } else { $pm->signal_received('TERM'); } }; alarm $SLEEP_SECS; 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; Parallel-Prefork-0.18/t/04-interval.t0000644€–Rz€ZĂ);0000000247612334353736017406 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.18/t/05-before_after_fork.t0000644€–Rz€ZĂ);0000000135012334353736021215 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.18/t/06-wait-all-children-with-timeout.t0000644€–Rz€ZĂ);0000000244012360037034023475 0ustar kazuhokazuho#! /usr/bin/perl use strict; use warnings; use Fcntl qw/:flock/; use File::Temp qw/tempfile/; use Test::More tests => 4; use Parallel::Prefork; my $reaped = 0; my $pm = Parallel::Prefork->new({ max_workers => 30, fork_delay => 0, on_child_reap => sub { $reaped++; } }); my ($fh, $filename) = tempfile; syswrite $fh, '0', 1; close $fh; my $manager_pid = $$; until ($pm->signal_received) { $pm->start and next; open my $fh, '+<', $filename or die "failed to open temporary file: $filename: "; flock $fh, LOCK_EX; sysread $fh, my $worker_count, 10; $worker_count++; seek $fh, 0, 0; syswrite $fh, $worker_count, length($worker_count); flock $fh, LOCK_UN; close $fh; my $rcv = 0; local $SIG{TERM} = sub { $rcv++ }; if ($worker_count == $pm->max_workers) { kill 'TERM', $manager_pid; } sleep(100) while $rcv * 10 < $worker_count; $pm->finish; } is $pm->wait_all_children(1), 20, 'should reap one worker.'; $pm->signal_all_children('TERM'); is $pm->wait_all_children(1), 10, 'should reap one worker.'; $pm->signal_all_children('TERM'); $pm->wait_all_children(); is $pm->num_workers, 0, 'all workers reaped.'; is($reaped, $pm->max_workers, "properly called on_child_reap callback"); unlink $filename; Parallel-Prefork-0.18/t/07-wait-all-children-does-not-block.t0000644€–Rz€ZĂ);0000000277612656531236023706 0ustar kazuhokazuho#! /usr/bin/perl use strict; use warnings; use Fcntl qw/:flock/; use File::Temp qw/tempfile/; use Test::More tests => 1; use Time::HiRes qw/sleep/; use Parallel::Prefork; my $pid = fork; die $! unless defined $pid; if ($pid) { my $timeout = 0; local $SIG{ALRM} = sub { $timeout = 1; kill 'INT', $pid }; alarm 5; until(waitpid $pid, 0) {} alarm 0; ok !$timeout, "wait_all_children does not block"; } else { my ($fh, $filename) = tempfile; syswrite $fh, '0', 1; close $fh; my $manager_pid = $$; my $pm = Parallel::Prefork->new({ max_workers => 30, fork_delay => 0, }); until ($pm->signal_received) { $pm->start and next; open my $fh, '+<', $filename or die "failed to open temporary file: $filename: "; flock $fh, LOCK_EX; sysread $fh, my $worker_count, 10; $worker_count++; seek $fh, 0, 0; syswrite $fh, $worker_count, length($worker_count); flock $fh, LOCK_UN; close $fh; if ($worker_count == $pm->max_workers) { kill 'TERM', $manager_pid; } # wait for SIGTERM my $rcv = 0; eval { local $SIG{TERM} = sub { $rcv = 1; die "SIGTERM" }; sleep(100); }; die $@ if $@ && !$rcv; # sleep 1 +/- 0.01 seconds sleep(0.99 + 0.02 * $worker_count / $pm->max_workers); $pm->finish; } $pm->wait_all_children(1); $pm->wait_all_children(); exit 0; }