Daemon-Control-0.001010/0000755000175000017500000000000013434300021014774 5ustar catalystcatalystDaemon-Control-0.001010/inc/0000755000175000017500000000000013434300021015545 5ustar catalystcatalystDaemon-Control-0.001010/inc/Module/0000755000175000017500000000000013434300021016772 5ustar catalystcatalystDaemon-Control-0.001010/inc/Module/Install/0000755000175000017500000000000013434300021020400 5ustar catalystcatalystDaemon-Control-0.001010/inc/Module/Install/Fetch.pm0000644000175000017500000000462713434277736022032 0ustar catalystcatalyst#line 1 package Module::Install::Fetch; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @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; Daemon-Control-0.001010/inc/Module/Install/Metadata.pm0000644000175000017500000004330213434277736022512 0ustar catalystcatalyst#line 1 package Module::Install::Metadata; use strict 'vars'; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @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; Daemon-Control-0.001010/inc/Module/Install/Win32.pm0000644000175000017500000000340313434277736021672 0ustar catalystcatalyst#line 1 package Module::Install::Win32; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @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; Daemon-Control-0.001010/inc/Module/Install/WriteAll.pm0000644000175000017500000000237613434277736022523 0ustar catalystcatalyst#line 1 package Module::Install::WriteAll; use strict; use Module::Install::Base (); use vars qw{$VERSION @ISA $ISCORE}; BEGIN { $VERSION = '1.19'; @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; Daemon-Control-0.001010/inc/Module/Install/Can.pm0000644000175000017500000000640513434277736021476 0ustar catalystcatalyst#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.19'; @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; if ($^O eq 'VMS') { require ExtUtils::CBuilder; my $builder = ExtUtils::CBuilder->new( quiet => 1, ); return $builder->have_compiler; } 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 245 Daemon-Control-0.001010/inc/Module/Install/Makefile.pm0000644000175000017500000002743713434277736022522 0ustar catalystcatalyst#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.19'; @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 Daemon-Control-0.001010/inc/Module/Install/Base.pm0000644000175000017500000000214713434277736021646 0ustar catalystcatalyst#line 1 package Module::Install::Base; use strict 'vars'; use vars qw{$VERSION}; BEGIN { $VERSION = '1.19'; } # 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 Daemon-Control-0.001010/inc/Module/Install.pm0000644000175000017500000002714513434277736021001 0ustar catalystcatalyst#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.19'; # 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}; $base_path = VMS::Filespec::unixify($base_path) if $^O eq 'VMS'; $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( {no_chdir => 1, wanted => 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($File::Find::name); 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; } 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; } sub _readperl { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; $string =~ s/(\n)\n*__(?:DATA|END)__\b.*\z/$1/s; $string =~ s/\n\n=\w+.+?\n\n=cut\b.+?\n+/\n\n/sg; return $string; } sub _readpod { my $string = Module::Install::_read($_[0]); $string =~ s/(?:\015{1,2}\012|\015|\012)/\n/sg; return $string if $_[0] =~ /\.pod\z/; $string =~ s/(^|\n=cut\b.+?\n+)[^=\s].+?\n(\n=\w+|\z)/$1$2/sg; $string =~ s/\n*=pod\b[^\n]*\n+/\n\n/sg; $string =~ s/\n*=cut\b[^\n]*\n+/\n\n/sg; $string =~ s/^\n+//s; return $string; } sub _write { local *FH; open( FH, '>', $_[0] ) or die "open($_[0]): $!"; binmode FH; foreach ( 1 .. $#_ ) { print FH $_[$_] or die "print($_[0]): $!"; } close FH or die "close($_[0]): $!"; } # _version is for processing module versions (eg, 1.03_05) not # Perl versions (eg, 5.8.1). sub _version { my $s = shift || 0; my $d =()= $s =~ /(\.)/g; if ( $d >= 2 ) { # Normalise multipart versions $s =~ s/(\.)(\d{1,3})/sprintf("$1%03d",$2)/eg; } $s =~ s/^(\d+)\.?//; my $l = $1 || 0; my @v = map { $_ . '0' x (3 - length $_) } $s =~ /(\d{1,3})\D?/g; $l = $l . '.' . join '', @v if @v; return $l + 0; } sub _cmp { _version($_[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. Daemon-Control-0.001010/Changes0000644000175000017500000001173213434276646016324 0ustar catalystcatalyst0.001010 2019-02-23 SymKat * Add '.' to @INC so Module::Install continues to work, thank you Gregor Herrmann (gregoa) (PR: #97) 0.001009 2019-02-19 SymKat * Add '.' to @INC so Module::Install continues to work. 0.001008 2015-08-07 * Fix issue with author name * Allow for custom open() args for stdout_file and stderr_file 0.001007 2015-07-26 SymKat * Module name POD format fixed (RT 93280) * Add "forground" to --help (by marcusramberg) * Add with_plugins to support a simple plugin system * symlink readme.POD to support GitHub readme from the lib itself 0.001005 2014-02-19 SymKat * Constructor now accepts a list as well as a hashref * New method added: run_command, allows multiple instances of D::C in the same script. Accepts the action as an argument and returns the exit code the user should exit with. * do_foreground added to allow running the code ref or program w/o forking * DC_FOREGROUND env will force foreground, regardless of compile-time settings * foreground added to constructor -- shortcut to fork => 0, quiet => 1 * Calling the script without an argument results in the syntax being displayed * Stray exit removed for run_command * Updated documentation 0.001004 2013-08-27 SymKat * Abort the kill loop when PID changes; Thanks, atomicstac 0.001003 2013-06-12 SymKat * Add quiet accessor to supress pretty_print (github#51) 0.001002 2013-06-11 SymKat * Due to checking for true values instead of define it was possible to start a daemon as root by setting uid/gid to 0/0, but not user/group to root/root, which would resolve to 0/0 and be considered an invalid user, which it's not. * Fix an encoding error in the POD resulting from Ævar Arnfjörð Bjarmason contributing to the project. * Tests that invoke Perl now use $^X instead of the $PATH's perl. * properly write the pid file in single fork mode (github#49) 0.001001 2013-04-29 SymKat * All 0.001001 changes brought to you by Karen Etheridge; Thanks, ether! * create dir for pid_file if it does not exist * fix uninitialized warning in error when exec fails * 'stop' is now faster when kill_timeout is set to high values, by checking every second if the daemon has terminated rather than waiting for the full kill_timeout duration * new option: prereq_no_process * stdout is flushed immediately when diagnostic output is printed 0.001000 2013-02-26 SymKat * fixed a warning on "uninitialized value $called_with in substitution" (Kromg) * include the date and module version in the generated init file (Karen Etheridge) * warn is used rather than printing to STDERR * new commands: help, reload * new options: kill_timeout, umask, init_code, do_help * new functions: do_help, do_reload, trace * pid file is now written as the current user, then chowned to the target user * pid file is now written when single-forking * gid is calculated when not provided but the uid is, avoiding some warnings 0.000009 2012-04-19 SymKat * Stole Moo's MANIFEST.SKIP 0.000008 2012-04-19 SymKat * Added Makefile to MANIFEST.SKIP 0.000007 2012-04-15 SymKat * Added user and group accessors to set uid/gid based on names * Updated docs. 0.000006 2012-04-15 SymKat * PID file will be deleted on do_stop * PID file will be created by the target user when ->uid set * uid() and gid() now take strings as well (doherty) * Kill signal order changed to TERM TERM INT KILL * init_config option added, gives LSB script a file to source. * Typo fixes * Mike Doherty (doherty) added to contrib (Thank you!) 0.000005 2012-02-18 SymKat * Fixed an issue with the inital PID being invalid. * Added directory accessor to support chdir before exec. * Minor documentation changes 0.000004 2012-02-18 SymKat * First release to cpan. * Refactoring and review by Matt S. Trout * I really changed the version this time! 0.000003 2012-02-18 SymKat * Test added for show_warnings. * Documentation updated for 0.0.2 changes. * Version changed this time. 0.000002 2012-02-18 SymKat * Default fork mode changed to double. * Added show_warnings command instead of alerting about DWIM actions. * Fatal warnings changed from warn+exit to die (exits non-zero) * _fork handles undef/cannot fork. * $self->redirect_filehandles added * redirect_before_fork added (default 1) * With a code ref, $self is passed (can $control->redriect_filehandles) 0.000001 2012-02-02 SymKat * Inital Commit Daemon-Control-0.001010/MANIFEST0000644000175000017500000000136513434277740016157 0ustar catalystcatalystChanges inc/Module/Install.pm inc/Module/Install/Base.pm inc/Module/Install/Can.pm inc/Module/Install/Fetch.pm inc/Module/Install/Makefile.pm inc/Module/Install/Metadata.pm inc/Module/Install/Win32.pm inc/Module/Install/WriteAll.pm lib/Daemon/Control.pm Makefile.PL MANIFEST This list of files META.yml t/00_load.t t/01_lsb_file.t t/01_lsb_file_with_init_code.t t/01_lsb_file_with_init_config.t t/02_sleep_perl.t t/02_sleep_perl_array.t t/02_sleep_system.t t/03_perl_gets_control.t t/04_show_warnings.t t/05_user_group.t t/06_stderr_stdout.t t/bin/01_lsb.pl t/bin/01_lsb_02.pl t/bin/01_lsb_03.pl t/bin/02_sleep_perl.pl t/bin/02_sleep_perl_array.pl t/bin/02_sleep_system.pl t/bin/03_perl_gets_control.pl t/bin/04_show_warnings.pl t/bin/05_stderr_stdout.pl Daemon-Control-0.001010/t/0000755000175000017500000000000013434300021015237 5ustar catalystcatalystDaemon-Control-0.001010/t/02_sleep_system.t0000644000175000017500000000364713433032637020471 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; my ( $file, $ilib ); # Let's make it so people can test in t/ or in the dist directory. if ( -f 't/bin/02_sleep_system.pl' ) { # Dist Directory. $file = "t/bin/02_sleep_system.pl"; $ilib = "lib"; } elsif ( -f 'bin/02_sleep_system.pl' ) { $file = "bin/02_sleep_system.pl"; $ilib = "../lib"; } else { die "Tests should be run in the dist directory or t/"; } sub get_command_output { my ( @command ) = @_; open my $lf, "-|", @command or die "Couldn't get pipe to '@command': $!"; my $content = do { local $/; <$lf> }; close $lf; return $content; } my $out; ok $out = get_command_output( "$^X -I$ilib $file start" ), "Started system daemon"; like $out, qr/\[Started\]/, "Daemon started."; ok $out = get_command_output( "$^X -I$ilib $file status" ), "Get status of system daemon."; like $out, qr/\[Running\]/, "Daemon running."; ok $? >> 8 == 0, "Exit Status = 0"; sleep 10; ok $out = get_command_output( "$^X -I$ilib $file status" ), "Get status of system daemon."; like $out, qr/\[Not Running\]/, "Daemon not running."; ok $? >> 8 == 3, "Exit Status = 3"; # Testing restart. ok $out = get_command_output( "$^X -I$ilib $file start" ), "Started system daemon"; like $out, qr/\[Started\]/, "Daemon started for restarting"; ok $out = get_command_output( "$^X -I$ilib $file status" ), "Get status of system daemon."; like $out, qr/\[Running\]/, "Daemon running for restarting."; ok $out = get_command_output( "$^X -I$ilib $file restart" ), "Get status of system daemon."; like $out, qr/\[Stopped\].*\[Started\]/s, "Daemon restarted."; ok $out = get_command_output( "$^X -I$ilib $file status" ), "Get status of system daemon."; like $out, qr/\[Running\]/, "Daemon running after restart."; ok $out = get_command_output( "$^X -I$ilib $file stop" ), "Get status of system daemon."; like $out, qr/\[Stopped\]/, "Daemon stopped after restart."; done_testing; Daemon-Control-0.001010/t/06_stderr_stdout.t0000644000175000017500000000741713433032637020665 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; use File::Temp; my ( $file, $ilib ); # Let's make it so people can test in t/ or in the dist directory. my $daemon = '05_stderr_stdout.pl'; if ( -f "t/bin/$daemon" ) { # Dist Directory. $file = "t/bin/$daemon"; $ilib = "lib"; } elsif ( -f "bin/$daemon" ) { $file = "bin/$daemon"; $ilib = "../lib"; } else { die "Tests should be run in the dist directory or t/"; } sub get_command_output { my ( @command ) = @_; open my $lf, "-|", @command or die "Couldn't get pipe to '@command': $!"; my $content = do { local $/; <$lf> }; close $lf; return $content; } { diag 'Test STDOUT and STDERR when we use plain strings as arguments'; my $out; my $stdout = File::Temp->new; # object stringifies to the filename my $stderr = File::Temp->new; my $cmd = "$^X -I$ilib $file $stdout $stderr"; ok $out = get_command_output("$cmd start"), "Started perl daemon"; like $out, qr/\[Started\]/, "Daemon started."; sleep 2; # chill out for a bit, or we might miss writes to files ok $out = get_command_output("$cmd status" ), "Get status of system daemon."; like $out, qr/\[Not Running\]/, "Daemon is stopped."; # Check data written by the daemon open my $fh, '<', $stdout or die "Failed to open stdout file ($stdout) for inspection: $!"; like do { local $/; <$fh>; }, qr/STDOUT output success/, "STDOUT file contains expected data"; open $fh, '<', $stderr or die "Failed to open stderr file ($stderr) for inspection: $!"; is do { local $/; <$fh>; }, "STDERR output success\n", "STDERR file contains expected data"; } { diag 'Test STDOUT and STDERR when we use custom arrayrefs as arguments'; # We're passing 'custom' argument so our daemon knows to use arrayrefs # Consult the code of the daemon for details my $out; my $stdout = File::Temp->new; # object stringifies to the filename my $stderr = File::Temp->new; my $cmd = "$^X -I$ilib $file custom $stdout $stderr"; ok $out = get_command_output("$cmd start"), "Started perl daemon"; like $out, qr/\[Started\]/, "Daemon started."; sleep 2; # chill out for a bit, or we might miss writes to files ok $out = get_command_output("$cmd status" ), "Get status of system daemon."; like $out, qr/\[Not Running\]/, "Daemon is stopped."; # Check daemon's first write open my $fh, '<', $stdout or die "Failed to open stdout file ($stdout) for inspection: $!"; like do { local $/; <$fh>; }, qr/STDOUT output success/, "STDOUT file contains expected data"; open $fh, '<', $stderr or die "Failed to open stderr file ($stderr) for inspection: $!"; is do { local $/; <$fh>; }, "STDERR output success\n", "STDERR file contains expected data"; # Restart so we'd get a second STD[OUT|ERR] write ok $out = get_command_output("$cmd start"), "Get status of system daemon."; like $out, qr/\[Started\]/s, "Daemon restarted."; sleep 2; # chill out for a bit, or we might miss writes to files ok $out = get_command_output("$cmd status" ), "Get status of system daemon."; like $out, qr/\[Not Running\]/, "Daemon is stopped."; # Check daemon's second write open $fh, '<', $stdout or die "Failed to open stdout file ($stdout) for inspection: $!"; like do { local $/; <$fh>; }, qr/^STDOUT output success(?!.*STDOUT output success)/s, "STDOUT file contains expected data"; open $fh, '<', $stderr or die "Failed to open stderr file ($stderr) for inspection: $!"; like do { local $/; <$fh>; }, qr/^STDERR output success(?!.*STDERR output success)/s, "STDERR file contains expected data"; } unlink 'pid_tmp'; done_testing; Daemon-Control-0.001010/t/04_show_warnings.t0000644000175000017500000000163313433032637020640 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; my ( $file, $ilib ); # Let's make it so people can test in t/ or in the dist directory. my $stub = "04_show_warnings.pl"; if ( -f "t/bin/$stub" ) { # Dist Directory. $file = "t/bin/$stub"; $ilib = "lib"; } elsif ( -f "bin/$stub" ) { $file = "bin/$stub"; $ilib = "../lib"; } else { die "Tests should be run in the dist directory or t/"; } sub get_command_output { my ( @command ) = @_; open my $lf, "-|", @command or die "Couldn't get pipe to '@command': $!"; my $content = do { local $/; <$lf> }; close $lf; return $content; } my $out; ok $out = get_command_output( "$^X -I$ilib $file show_warnings 2>&1" ), "Get warnings"; is $out, do { local $/; }, "Got warnings."; done_testing; __DATA__ stdout_file undefined. Will not redirect file handle. stderr_file undefined. Will not redirect file handle. Daemon-Control-0.001010/t/01_lsb_file_with_init_config.t0000644000175000017500000000243713433032637023132 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; my ( $file, $ilib ); # Let's make it so people can test in t/ or in the dist directory. if ( -f 't/bin/01_lsb_02.pl' ) { # Dist Directory. $file = "t/bin/01_lsb_02.pl"; $ilib = "lib"; } elsif ( -f 'bin/01_lsb_02.pl' ) { $file = "bin/01_lsb_02.pl"; $ilib = "../lib"; } else { die "Tests should be run in the dist directory or t/"; } open my $lf, "-|", $^X, "-I$ilib", $file, "get_init_file" or die "Failed to open pipe to $file: $!"; my $content = do { local $/; <$lf> }; close $lf; my $content_expected = do { local $/; }; like $content, qr/$content_expected/, "LSB File Generation Works."; done_testing; __DATA__ #!/bin/sh # Generated at [\w: ]+ with Daemon::Control (?:DEV|[\d.]+) ### BEGIN INIT INFO # Provides: My Daemon # Required-Start: \$syslog \$remote_fs # Required-Stop: \$syslog # Default-Start: 2 3 4 5 # Default-Stop: 0 1 6 # Short-Description: My Daemon Short # Description: My Daemon controls the My Daemon daemon. ### END INIT INFO` \[ -r /etc/default/my_program \] && . /etc/default/my_program if \[ -x /usr/sbin/mydaemon/init.pl \]; then /usr/sbin/mydaemon/init.pl \$1 else echo "Required program /usr/sbin/mydaemon/init.pl not found!" exit 1; fi Daemon-Control-0.001010/t/00_load.t0000644000175000017500000000020313433032637016653 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; use_ok( $_ ) for qw| Daemon::Control File::Spec POSIX |; done_testing; Daemon-Control-0.001010/t/bin/0000755000175000017500000000000013434300021016007 5ustar catalystcatalystDaemon-Control-0.001010/t/bin/05_stderr_stdout.pl0000644000175000017500000000135013433032637021572 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Daemon::Control; my $custom = $ARGV[0] eq 'custom' ? shift : undef; my $stdout = shift; my $stderr = shift; Daemon::Control->new({ name => "My Daemon", lsb_start => '$syslog $remote_fs', lsb_stop => '$syslog', lsb_sdesc => 'My Daemon Short', lsb_desc => 'My Daemon controls the My Daemon daemon.', path => '/usr/sbin/mydaemon/init.pl', program => sub { print STDOUT "STDOUT output success\n"; print STDERR "STDERR output success\n"; }, pid_file => 'pid_tmp', stderr_file => ($custom ? [ '>', $stderr ] : $stderr), stdout_file => ($custom ? [ "> $stdout" ] : $stdout), fork => 2, })->run; Daemon-Control-0.001010/t/bin/01_lsb.pl0000644000175000017500000000101413433032637017436 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Daemon::Control; Daemon::Control->new({ name => "My Daemon", lsb_start => '$syslog $remote_fs', lsb_stop => '$syslog', lsb_sdesc => 'My Daemon Short', lsb_desc => 'My Daemon controls the My Daemon daemon.', path => '/usr/sbin/mydaemon/init.pl', program => sub { sleep shift }, program_args => [ 10 ], pid_file => '/tmp/mydaemon.pid', stderr_file => '/dev/null', stdout_file => '/dev/null', })->run; Daemon-Control-0.001010/t/bin/04_show_warnings.pl0000644000175000017500000000103413433032637021553 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Daemon::Control; Daemon::Control->new({ name => "My Daemon", lsb_start => '$syslog $remote_fs', lsb_stop => '$syslog', lsb_sdesc => 'My Daemon Short', lsb_desc => 'My Daemon controls the My Daemon daemon.', path => '/usr/sbin/mydaemon/init.pl', program => sub { 1 }, program_args => [ ], redirect_before_fork => 0, pid_file => '/dev/null', # I don't want to leave tmp files for testing. fork => 2, })->run; Daemon-Control-0.001010/t/bin/02_sleep_perl.pl0000644000175000017500000000103113433032637021010 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Daemon::Control; Daemon::Control->new({ name => "My Daemon", lsb_start => '$syslog $remote_fs', lsb_stop => '$syslog', lsb_sdesc => 'My Daemon Short', lsb_desc => 'My Daemon controls the My Daemon daemon.', path => '/usr/sbin/mydaemon/init.pl', program => sub { sleep $_[1] }, program_args => [ 10 ], pid_file => 'pid_tmp', stderr_file => '/dev/null', stdout_file => '/dev/null', fork => 2, })->run; Daemon-Control-0.001010/t/bin/02_sleep_perl_array.pl0000644000175000017500000000102713433032637022213 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Daemon::Control; Daemon::Control->new( name => "My Daemon", lsb_start => '$syslog $remote_fs', lsb_stop => '$syslog', lsb_sdesc => 'My Daemon Short', lsb_desc => 'My Daemon controls the My Daemon daemon.', path => '/usr/sbin/mydaemon/init.pl', program => sub { sleep $_[1] }, program_args => [ 10 ], pid_file => 'pid_tmp', stderr_file => '/dev/null', stdout_file => '/dev/null', fork => 2, )->run; Daemon-Control-0.001010/t/bin/01_lsb_03.pl0000644000175000017500000000106713433032637017750 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Daemon::Control; Daemon::Control->new({ name => "My Daemon", lsb_start => '$syslog $remote_fs', lsb_stop => '$syslog', lsb_sdesc => 'My Daemon Short', lsb_desc => 'My Daemon controls the My Daemon daemon.', path => '/usr/sbin/mydaemon/init.pl', init_code => "Test This\nOne Block", program => sub { sleep shift }, program_args => [ 10 ], pid_file => '/tmp/mydaemon.pid', stderr_file => '/dev/null', stdout_file => '/dev/null', })->run; Daemon-Control-0.001010/t/bin/01_lsb_02.pl0000644000175000017500000000107213433032637017743 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Daemon::Control; Daemon::Control->new({ name => "My Daemon", lsb_start => '$syslog $remote_fs', lsb_stop => '$syslog', lsb_sdesc => 'My Daemon Short', lsb_desc => 'My Daemon controls the My Daemon daemon.', path => '/usr/sbin/mydaemon/init.pl', init_config => '/etc/default/my_program', program => sub { sleep shift }, program_args => [ 10 ], pid_file => '/tmp/mydaemon.pid', stderr_file => '/dev/null', stdout_file => '/dev/null', })->run; Daemon-Control-0.001010/t/bin/03_perl_gets_control.pl0000644000175000017500000000126613433032637022415 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Daemon::Control; Daemon::Control->new({ name => "My Daemon", lsb_start => '$syslog $remote_fs', lsb_stop => '$syslog', lsb_sdesc => 'My Daemon Short', lsb_desc => 'My Daemon controls the My Daemon daemon.', path => '/usr/sbin/mydaemon/init.pl', program => sub { if ( ref $_[0] ne 'Daemon::Control' ) { print "FAILED\n"; } }, program_args => [ ], redirect_before_fork => 0, pid_file => '/dev/null', # I don't want to leave tmp files for testing. stderr_file => '/dev/null', stdout_file => '/dev/null', fork => 2, })->run; Daemon-Control-0.001010/t/bin/02_sleep_system.pl0000644000175000017500000000101613433032637021375 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Daemon::Control; Daemon::Control->new({ name => "My Daemon", lsb_start => '$syslog $remote_fs', lsb_stop => '$syslog', lsb_sdesc => 'My Daemon Short', lsb_desc => 'My Daemon controls the My Daemon daemon.', path => '/usr/sbin/mydaemon/init.pl', program => 'sleep', program_args => [ 10 ], pid_file => 'pid_tmp', stderr_file => '/dev/null', stdout_file => '/dev/null', fork => 2, })->run; Daemon-Control-0.001010/t/02_sleep_perl.t0000644000175000017500000000352313433032637020100 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; my ( $file, $ilib ); # Let's make it so people can test in t/ or in the dist directory. if ( -f 't/bin/02_sleep_perl.pl' ) { # Dist Directory. $file = "t/bin/02_sleep_perl.pl"; $ilib = "lib"; } elsif ( -f 'bin/02_sleep_perl.pl' ) { $file = "bin/02_sleep_perl.pl"; $ilib = "../lib"; } else { die "Tests should be run in the dist directory or t/"; } sub get_command_output { my ( @command ) = @_; open my $lf, "-|", @command or die "Couldn't get pipe to '@command': $!"; my $content = do { local $/; <$lf> }; close $lf; return $content; } my $out; ok $out = get_command_output( "$^X -I$ilib $file start" ), "Started perl daemon"; like $out, qr/\[Started\]/, "Daemon started."; ok $out = get_command_output( "$^X -I$ilib $file status" ), "Get status of perl daemon."; like $out, qr/\[Running\]/, "Daemon running."; sleep 10; ok $out = get_command_output( "$^X -I$ilib $file status" ), "Get status of perl daemon."; like $out, qr/\[Not Running\]/, "Daemon not running"; # Testing restart. ok $out = get_command_output( "$^X -I$ilib $file start" ), "Started system daemon"; like $out, qr/\[Started\]/, "Daemon started for restarting."; ok $out = get_command_output( "$^X -I$ilib $file status" ), "Get status of system daemon."; like $out, qr/\[Running\]/, "Daemon running for restarting."; ok $out = get_command_output( "$^X -I$ilib $file restart" ), "Get status of system daemon."; like $out, qr/\[Stopped\].*\[Started\]/s, "Daemon restarted."; ok $out = get_command_output( "$^X -I$ilib $file status" ), "Get status of system daemon."; like $out, qr/\[Running\]/, "Daemon running after restart."; ok $out = get_command_output( "$^X -I$ilib $file stop" ), "Get status of system daemon."; like $out, qr/\[Stopped\]/, "Daemon stopped after restart."; done_testing; Daemon-Control-0.001010/t/03_perl_gets_control.t0000644000175000017500000000152313433032637021471 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; my ( $file, $ilib ); # Let's make it so people can test in t/ or in the dist directory. if ( -f 't/bin/03_perl_gets_control.pl' ) { # Dist Directory. $file = "t/bin/03_perl_gets_control.pl"; $ilib = "lib"; } elsif ( -f 'bin/03_perl_gets_control.pl' ) { $file = "bin/03_perl_gets_control.pl"; $ilib = "../lib"; } else { die "Tests should be run in the dist directory or t/"; } sub get_command_output { my ( @command ) = @_; open my $lf, "-|", @command or die "Couldn't get pipe to '@command': $!"; my $content = do { local $/; <$lf> }; close $lf; return $content; } my $out; ok $out = get_command_output( "$^X -I$ilib $file start" ), "Started perl daemon"; unlike $out, qr/FAILED/, "Code ref gets Daemon::Control instance."; done_testing; Daemon-Control-0.001010/t/02_sleep_perl_array.t0000644000175000017500000000355313433032637021301 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; my ( $file, $ilib ); # Let's make it so people can test in t/ or in the dist directory. if ( -f 't/bin/02_sleep_perl_array.pl' ) { # Dist Directory. $file = "t/bin/02_sleep_perl_array.pl"; $ilib = "lib"; } elsif ( -f 'bin/02_sleep_perl_array.pl' ) { $file = "bin/02_sleep_perl_array.pl"; $ilib = "../lib"; } else { die "Tests should be run in the dist directory or t/"; } sub get_command_output { my ( @command ) = @_; open my $lf, "-|", @command or die "Couldn't get pipe to '@command': $!"; my $content = do { local $/; <$lf> }; close $lf; return $content; } my $out; ok $out = get_command_output( "$^X -I$ilib $file start" ), "Started perl daemon"; like $out, qr/\[Started\]/, "Daemon started."; ok $out = get_command_output( "$^X -I$ilib $file status" ), "Get status of perl daemon."; like $out, qr/\[Running\]/, "Daemon running."; sleep 10; ok $out = get_command_output( "$^X -I$ilib $file status" ), "Get status of perl daemon."; like $out, qr/\[Not Running\]/, "Daemon not running"; # Testing restart. ok $out = get_command_output( "$^X -I$ilib $file start" ), "Started system daemon"; like $out, qr/\[Started\]/, "Daemon started for restarting."; ok $out = get_command_output( "$^X -I$ilib $file status" ), "Get status of system daemon."; like $out, qr/\[Running\]/, "Daemon running for restarting."; ok $out = get_command_output( "$^X -I$ilib $file restart" ), "Get status of system daemon."; like $out, qr/\[Stopped\].*\[Started\]/s, "Daemon restarted."; ok $out = get_command_output( "$^X -I$ilib $file status" ), "Get status of system daemon."; like $out, qr/\[Running\]/, "Daemon running after restart."; ok $out = get_command_output( "$^X -I$ilib $file stop" ), "Get status of system daemon."; like $out, qr/\[Stopped\]/, "Daemon stopped after restart."; done_testing; Daemon-Control-0.001010/t/01_lsb_file.t0000644000175000017500000000232613433032637017524 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; my ( $file, $ilib ); # Let's make it so people can test in t/ or in the dist directory. if ( -f 't/bin/01_lsb.pl' ) { # Dist Directory. $file = "t/bin/01_lsb.pl"; $ilib = "lib"; } elsif ( -f 'bin/01_lsb.pl' ) { $file = "bin/01_lsb.pl"; $ilib = "../lib"; } else { die "Tests should be run in the dist directory or t/"; } open my $lf, "-|", $^X, "-I$ilib", $file, "get_init_file" or die "Failed to open pipe to $file: $!"; my $content = do { local $/; <$lf> }; close $lf; my $content_expected = do { local $/; }; like $content, qr/$content_expected/, "LSB File Generation Works."; done_testing; __DATA__ #!/bin/sh # Generated at [\w: ]+ with Daemon::Control (?:DEV|[\d.]+) ### BEGIN INIT INFO # Provides: My Daemon # Required-Start: \$syslog \$remote_fs # Required-Stop: \$syslog # Default-Start: 2 3 4 5 # Default-Stop: 0 1 6 # Short-Description: My Daemon Short # Description: My Daemon controls the My Daemon daemon. ### END INIT INFO` if \[ -x /usr/sbin/mydaemon/init.pl \]; then /usr/sbin/mydaemon/init.pl \$1 else echo "Required program /usr/sbin/mydaemon/init.pl not found!" exit 1; fi Daemon-Control-0.001010/t/01_lsb_file_with_init_code.t0000644000175000017500000000236513433032637022577 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; my ( $file, $ilib ); # Let's make it so people can test in t/ or in the dist directory. if ( -f 't/bin/01_lsb_03.pl' ) { # Dist Directory. $file = "t/bin/01_lsb_03.pl"; $ilib = "lib"; } elsif ( -f 'bin/01_lsb_03.pl' ) { $file = "bin/01_lsb_03.pl"; $ilib = "../lib"; } else { die "Tests should be run in the dist directory or t/"; } open my $lf, "-|", $^X, "-I$ilib", $file, "get_init_file" or die "Failed to open pipe to $file: $!"; my $content = do { local $/; <$lf> }; close $lf; my $content_expected = do { local $/; }; like $content, qr/$content_expected/, "LSB File Generation Works."; done_testing; __DATA__ #!/bin/sh # Generated at [\w: ]+ with Daemon::Control (?:DEV|[\d.]+) ### BEGIN INIT INFO # Provides: My Daemon # Required-Start: \$syslog \$remote_fs # Required-Stop: \$syslog # Default-Start: 2 3 4 5 # Default-Stop: 0 1 6 # Short-Description: My Daemon Short # Description: My Daemon controls the My Daemon daemon. ### END INIT INFO` Test This One Block if \[ -x /usr/sbin/mydaemon/init.pl \]; then /usr/sbin/mydaemon/init.pl \$1 else echo "Required program /usr/sbin/mydaemon/init.pl not found!" exit 1; fi Daemon-Control-0.001010/t/05_user_group.t0000644000175000017500000000274313433032637020146 0ustar catalystcatalyst#!/usr/bin/perl use warnings; use strict; use Test::More; use Daemon::Control; # Make sure the user and group don't exist my $user = 'bogus1'; $user++ while getpwnam( $user ); my $group = 'bogus1'; $group++ while getgrnam( $group ); my $dc = eval { Daemon::Control->new({ name => "My Daemon", lsb_start => '$syslog $remote_fs', lsb_stop => '$syslog', lsb_sdesc => 'My Daemon Short', lsb_desc => 'My Daemon controls the My Daemon daemon.', path => '/usr/sbin/mydaemon/init.pl', program => sub { sleep shift }, program_args => [ 10 ], user => $user, group => $group, pid_file => '/tmp/mydaemon.pid', stderr_file => '/dev/null', stdout_file => '/dev/null', }) }; isa_ok( $dc, 'Daemon::Control' ); for my $method (qw(do_help do_show_warnings do_get_init_file)) { local( *STDOUT, *STDERR ); my ($stdout, $stderr) = ("", ""); open( STDOUT, '>', \$stdout ) or die "can't redirect stdout: $!"; open( STDERR, '>', \$stderr ) or die "can't redirect stderr: $!"; eval { $dc->$method }; is( $@, "", "calling $method with bogus user + group lives" ); isnt( $method =~ /warnings/ ? $stderr : $stdout, "", "calling $method with bogus user + group generates output" ); } for my $method (qw(uid gid)) { eval { $dc->$method }; like( $@, qr/Couldn't get $method for non-existent (?:user|group)/, "getting $method with bogus user + group dies" ); } done_testing; Daemon-Control-0.001010/META.yml0000644000175000017500000000142113434277736016275 0ustar catalystcatalyst--- abstract: 'Create init scripts in Perl' author: - 'Kaitlyn Parkhurst (SymKat) I<> ( Blog: L )' build_requires: ExtUtils::MakeMaker: 6.59 File::Temp: 0.14 Test::More: 0.88 configure_requires: ExtUtils::MakeMaker: 6.59 distribution_type: module dynamic_config: 1 generated_by: 'Module::Install version 1.19' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Daemon-Control no_index: directory: - inc - t requires: Cwd: 0 File::Path: 2.08 File::Spec: 0 POSIX: 0 perl: 5.8.1 resources: IRC: irc://irc.freenode.org/#perl-daemon-control bugtracker: http://github.com/symkat/Daemon-Control/issues license: http://dev.perl.org/licenses/ version: 0.001010 Daemon-Control-0.001010/lib/0000755000175000017500000000000013434300021015542 5ustar catalystcatalystDaemon-Control-0.001010/lib/Daemon/0000755000175000017500000000000013434300021016745 5ustar catalystcatalystDaemon-Control-0.001010/lib/Daemon/Control.pm0000644000175000017500000010317313434276424020753 0ustar catalystcatalystpackage Daemon::Control; use strict; use warnings; use POSIX qw(_exit setsid setuid setgid getuid getgid); use File::Spec; use File::Path qw( make_path ); use Cwd 'abs_path'; require 5.008001; # Supporting 5.8.1+ our $VERSION = '0.001010'; # 0.1.10 $VERSION = eval $VERSION; my @accessors = qw( pid color_map name program program_args directory quiet path scan_name stdout_file stderr_file pid_file fork data lsb_start lsb_stop lsb_sdesc lsb_desc redirect_before_fork init_config kill_timeout umask resource_dir help init_code prereq_no_process foreground reload_signal stop_signals ); my $cmd_opt = "[start|stop|restart|reload|status|foreground|show_warnings|get_init_file|help]"; # Accessor building for my $method ( @accessors ) { my $accessor = sub { my $self = shift; $self->{$method} = shift if @_; return $self->{$method}; }; { no strict 'refs'; *$method = $accessor; } } # As a result of not using a real object system for # this, I don't get after user => sub { } style things, # so I'm making my own triggers for user and group. sub user { my $self = shift; if ( @_ ) { $self->{user} = shift; delete $self->{uid}; } return $self->{user}; } sub group { my $self = shift; if ( @_ ) { $self->{group} = shift; delete $self->{gid}; } return $self->{group}; } sub uid { my $self = shift; return $self->{uid} = shift if @_; $self->_set_uid_from_name unless exists $self->{uid}; return $self->{uid} } sub gid { my $self = shift; return $self->{gid} = shift if @_; $self->_set_gid_from_name unless exists $self->{gid}; return $self->{gid} } sub new { my ( $class, @in ) = @_; my $args = ref $in[0] eq 'HASH' ? $in[0] : { @in }; # Create the object with defaults. my $self = bless { color_map => { red => 31, green => 32 }, redirect_before_fork => 1, kill_timeout => 1, quiet => 0, umask => 0, foreground => 0, reload_signal => 'HUP', stop_signals => [ qw(TERM TERM INT KILL) ], }, $class; for my $accessor ( @accessors, qw(uid gid user group) ) { if ( exists $args->{$accessor} ) { $self->{$accessor} = delete $args->{$accessor}; } } # Shortcut caused by setting foreground or using the ENV to do it. if ( ( $self->foreground == 1 ) || ( $ENV{DC_FOREGROUND} ) ) { $self->fork( 0 ); $self->quiet( 1 ); } die "Unknown arguments to the constructor: " . join( " ", keys %$args ) if keys( %$args ); return $self; } sub with_plugins { my ( $class, @in ) = @_; # ->with_plugins()->new is just ->new... return $class unless @in; # Make sure we have Role::Tiny installed. local $@; eval "require Role::Tiny"; if ( $@ ) { die "Error: Role::Tiny is required for with_plugins to function.\n"; } # Take an array or arrayref as an argument # and mutate it into a list like this: # 'Module' -> Becomes -> 'Root::Module' # '+Module' -> Becomes -> 'Module' my @plugins = map { substr( $_, 0, 1 ) eq '+' ? substr( $_, 1 ) : "Daemon::Control::Plugin::$_" } ref $in[0] eq 'ARRAY' ? @{ $in[0] } : @in; # Compose the plugins into our class, and return for the user # to call ->new(). return Role::Tiny->create_class_with_roles( $class, @plugins ); } # Set the uid, triggered from getting the uid if the user has changed. sub _set_uid_from_name { my ( $self ) = @_; return unless defined $self->user; my $uid = getpwnam( $self->user ); die "Error: Couldn't get uid for non-existent user " . $self->user unless defined $uid; $self->trace( "Set UID => $uid" ); $self->uid( $uid ); } # Set the uid, triggered from getting the gid if the group has changed. sub _set_gid_from_name { my ( $self ) = @_; # Grab the GID if we have a UID but no GID. if ( !defined $self->group && defined $self->uid ) { my ( $gid ) = ( (getpwuid( $self->uid ))[3] ); $self->gid( $gid ); $self->trace( "Implicit GID => $gid" ); return $gid; } return unless defined $self->group; my $gid = getgrnam( $self->group ); die "Error: Couldn't get gid for non-existent group " . $self->group unless defined $gid; $self->trace( "Set GID => $gid" ); $self->gid( $gid ); } sub redirect_filehandles { my ( $self ) = @_; if ( $self->stdout_file ) { my $file = $self->stdout_file; $file = $file eq '/dev/null' ? File::Spec->devnull : $file; if ( ref $file eq 'ARRAY' ) { my $mode = shift @$file; open STDOUT, $mode, @$file ? @$file : () or die "Failed to open STDOUT with args $mode @$file: $!"; $self->trace("STDOUT redirected to open(STDOUT $mode @$file)"); } else { open STDOUT, ">>", $file or die "Failed to open STDOUT to $file: $!"; $self->trace( "STDOUT redirected to $file" ); } } if ( $self->stderr_file ) { my $file = $self->stderr_file; $file = $file eq '/dev/null' ? File::Spec->devnull : $file; if ( ref $file eq 'ARRAY' ) { my $mode = shift @$file; open STDERR, $mode, @$file ? @$file : () or die "Failed to open STDERR with args $mode @$file: $!"; $self->trace("STDERR redirected to open(STDERR $mode @$file)"); } else { open STDERR, ">>", $file or die "Failed to open STDERR to $file: $!"; $self->trace("STDERR redirected to $file"); } } } sub _create_resource_dir { my ( $self ) = @_; $self->_create_dir($self->resource_dir); } sub _create_dir { my ( $self, $dir ) = @_; return 0 unless defined $dir; return 1 unless length($dir); if ( -d $dir ) { $self->trace( "Dir exists (" . $dir . ") - no need to create" ); return 1; } my ( $created ) = make_path( $dir, { uid => $self->uid, group => $self->gid, error => \my $errors, } ); if ( @$errors ) { for my $error ( @$errors ) { my ( $file, $msg ) = %$error; die "Error creating $file: $msg"; } } if ( $created eq $dir ) { $self->trace( "Created dir (" . $dir . ")" ); return 1; } $self->trace( "_create_dir() for $dir failed and I don't know why" ); return 0; } sub _double_fork { my ( $self ) = @_; my $pid = fork(); $self->trace( "_double_fork()" ); if ( $pid == 0 ) { # Child, launch the process here. setsid(); # Become the process leader. my $new_pid = fork(); if ( $new_pid == 0 ) { # Our double fork. if ( $self->gid ) { setgid( $self->gid ); $self->trace( "setgid(" . $self->gid . ")" ); } if ( $self->uid ) { setuid( $self->uid ); $ENV{USER} = $self->user || getpwuid($self->uid); $ENV{HOME} = ((getpwuid($self->uid))[7]); $self->trace( "setuid(" . $self->uid . ")" ); $self->trace( "\$ENV{USER} => " . $ENV{USER} ); $self->trace( "\$ENV{HOME} => " . $ENV{HOME} ); } if ( $self->umask ) { umask( $self->umask); $self->trace( "umask(" . $self->umask . ")" ); } open( STDIN, "<", File::Spec->devnull ); if ( $self->redirect_before_fork ) { $self->redirect_filehandles; } $self->_launch_program; } elsif ( not defined $new_pid ) { warn "Cannot fork: $!"; } else { $self->pid( $new_pid ); $self->trace("Set PID => $new_pid" ); $self->write_pid; _exit 0; } } elsif ( not defined $pid ) { # We couldn't fork. =( warn "Cannot fork: $!"; } else { # In the parent, $pid = child's PID, return it. waitpid( $pid, 0 ); } return $self; } sub _foreground { shift->_launch_program } sub _fork { my ( $self ) = @_; my $pid = fork(); $self->trace( "_fork()" ); if ( $pid == 0 ) { # Child, launch the process here. $self->_launch_program; } elsif ( not defined $pid ) { warn "Cannot fork: $!"; } else { # In the parent, $pid = child's PID, return it. $self->pid( $pid ); $self->trace("Set PID => $pid" ); $self->write_pid; } return $self; } sub _launch_program { my ($self) = @_; if ( $self->directory ) { chdir( $self->directory ); $self->trace( "chdir(" . $self->directory . ")" ); } my @args = @{$self->program_args || [ ]}; if ( ref $self->program eq 'CODE' ) { $self->program->( $self, @args ); } else { exec ( $self->program, @args ) or die "Failed to exec " . $self->program . " " . join( " ", @args ) . ": $!"; } return 0; } sub write_pid { my ( $self ) = @_; # Create the PID file as the user we currently are, # and change the permissions to our target UID/GID. $self->_write_pid; if ( $self->uid && $self->gid ) { chown $self->uid, $self->gid, $self->pid_file; $self->trace("PID => chown(" . $self->uid . ", " . $self->gid .")"); } } sub _write_pid { my ( $self ) = @_; my ($volume, $dir, $file) = File::Spec->splitpath($self->pid_file); return 0 if not $self->_create_dir($dir); open my $sf, ">", $self->pid_file or die "Failed to write " . $self->pid_file . ": $!"; print $sf $self->pid; close $sf; $self->trace( "Wrote pid (" . $self->pid . ") to pid file (" . $self->pid_file . ")" ); return $self; } sub read_pid { my ( $self ) = @_; # If we don't have a PID file, we're going to set it # to 0 -- this will prevent killing normal processes, # and make is_running return false. if ( ! -f $self->pid_file ) { $self->pid( 0 ); return 0; } open my $lf, "<", $self->pid_file or die "Failed to read " . $self->pid_file . ": $!"; my $pid = do { local $/; <$lf> }; close $lf; $self->pid( $pid ); return $pid; } sub pid_running { my ( $self, $pid ) = @_; $pid ||= $self->read_pid; return 0 unless $self->pid >= 1; return 0 unless kill 0, $self->pid; if ( $self->scan_name ) { open my $lf, "-|", "ps", "-w", "-w", "-p", $self->pid, "-o", "command=" or die "Failed to get pipe to ps for scan_name."; while ( my $line = <$lf> ) { return 1 if $line =~ $self->scan_name; } return 0; } # Scan name wasn't used, testing normal PID. return kill 0, $self->pid; } sub process_running { my ( $self, $pattern ) = @_; my $psopt = $^O =~ m/bsd$/ ? '-ax' : '-u ' . $self->user; my $ps = `LC_ALL=C command ps $psopt -o pid,args`; $ps =~ s/^\s+//mg; my @pids; for my $line (split /\n/, $ps) { next if $line =~ m/^\D/; my ($pid, $command, $args) = split /\s+/, $line, 3; next if $pid eq $$; push @pids, $pid if $command =~ $pattern or defined $args and $args =~ $pattern; } return @pids; } sub pretty_print { my ( $self, $message, $color ) = @_; return if $self->quiet; $color ||= "green"; # Green is no color. my $code = $self->color_map->{$color} ||= "32"; # Green is invalid. local $| = 1; printf( "%-49s %30s\n", $self->name, "\033[$code" ."m[$message]\033[0m" ); } # Callable Functions sub do_foreground { my ( $self ) = @_; # Short cut to... $self->fork( 0 ); $self->quiet( 1 ); return $self->do_start; } sub do_start { my ( $self ) = @_; # Optionally check if a process is already running with the same name if ($self->prereq_no_process) { my $program = $self->program; my $pattern = $self->prereq_no_process eq '1' ? qr/\b${program}\b/ : $self->prereq_no_process; my @pids = $self->process_running($pattern); if (@pids) { $self->pretty_print( 'Duplicate Running? (pid ' . join(', ', @pids) . ')', "red" ); return 1; } } # Make sure the PID file exists. if ( ! -f $self->pid_file ) { $self->pid( 0 ); # Make PID invalid. $self->write_pid(); } # Duplicate Check $self->read_pid; if ( $self->pid && $self->pid_running ) { $self->pretty_print( "Duplicate Running", "red" ); return 1; } $self->_create_resource_dir; $self->fork( 2 ) unless defined $self->fork; $self->_double_fork if $self->fork == 2; $self->_fork if $self->fork == 1; $self->_foreground if $self->fork == 0; $self->pretty_print( "Started" ); return 0; } sub do_show_warnings { my ( $self ) = @_; if ( ! $self->fork ) { warn "Fork undefined. Defaulting to fork => 2.\n"; } if ( ! $self->stdout_file ) { warn "stdout_file undefined. Will not redirect file handle.\n"; } if ( ! $self->stderr_file ) { warn "stderr_file undefined. Will not redirect file handle.\n"; } } sub do_stop { my ( $self ) = @_; $self->read_pid; my $start_pid = $self->pid; # Probably don't want to send anything to init(1). return 1 unless $start_pid > 1; if ( $self->pid_running($start_pid) ) { SIGNAL: foreach my $signal (@{ $self->stop_signals }) { $self->trace( "Sending $signal signal to pid $start_pid..." ); kill $signal => $start_pid; for (1..$self->kill_timeout) { # abort early if the process is now stopped $self->trace("checking if pid $start_pid is still running..."); last if not $self->pid_running($start_pid); sleep 1; } last unless $self->pid_running($start_pid); } if ( $self->pid_running($start_pid) ) { $self->pretty_print( "Failed to Stop", "red" ); return 1; } $self->pretty_print( "Stopped" ); } else { $self->pretty_print( "Not Running", "red" ); } # Clean up the PID file on stop, unless the pid # doesn't match $start_pid (perhaps a standby # worker stepped in to take over from the one # that was just terminated). if ( $self->pid_file ) { unlink($self->pid_file) if $self->read_pid == $start_pid; } return 0; } sub do_restart { my ( $self ) = @_; $self->read_pid; if ( $self->pid_running ) { $self->do_stop; } $self->do_start; return 0; } sub do_status { my ( $self ) = @_; $self->read_pid; if ( $self->pid && $self->pid_running ) { $self->pretty_print( "Running" ); return 0; } else { $self->pretty_print( "Not Running", "red" ); return 3; } } sub do_reload { my ( $self ) = @_; $self->read_pid; if ( $self->pid && $self->pid_running ) { kill $self->reload_signal, $self->pid; $self->pretty_print( "Reloaded" ); return 0; } else { $self->pretty_print( "Not Running", "red" ); return 1; } } sub do_get_init_file { shift->dump_init_script; return 0; } sub do_help { my ( $self ) = @_; print "Syntax: $0 $cmd_opt\n\n"; print $self->help if $self->help; return 0; } sub dump_init_script { my ( $self ) = @_; if ( ! $self->data ) { my $data; while ( my $line = ) { last if $line =~ /^__END__$/; $data .= $line; } $self->data( $data ); } # So, instead of expanding run_template to use a real DSL # or making TT a dependancy, I'm just going to fake template # IF logic. my $init_source_file = $self->init_config ? $self->run_template( '[ -r [% FILE %] ] && . [% FILE %]', { FILE => $self->init_config } ) : ""; $self->data( $self->run_template( $self->data, { HEADER => 'Generated at ' . scalar(localtime) . ' with Daemon::Control ' . ($self->VERSION || 'DEV'), NAME => $self->name ? $self->name : "", REQUIRED_START => $self->lsb_start ? $self->lsb_start : "", REQUIRED_STOP => $self->lsb_stop ? $self->lsb_stop : "", SHORT_DESCRIPTION => $self->lsb_sdesc ? $self->lsb_sdesc : "", DESCRIPTION => $self->lsb_desc ? $self->lsb_desc : "", SCRIPT => $self->path ? $self->path : abs_path($0), INIT_SOURCE_FILE => $init_source_file, INIT_CODE_BLOCK => $self->init_code ? $self->init_code : "", } )); print $self->data; } sub run_template { my ( $self, $content, $config ) = @_; $content =~ s/\[% (.*?) %\]/$config->{$1}/g; return $content; } sub run_command { my ( $self, $arg ) = @_; # Error Checking. if ( ! $self->program ) { die "Error: program must be defined."; } if ( ! $self->pid_file ) { die "Error: pid_file must be defined."; } if ( ! $self->name ) { die "Error: name must be defined."; } my $called_with = $arg || "help"; $called_with =~ s/^[-]+//g; # Allow people to do --command too. my $action = "do_" . ($called_with ? $called_with : "" ); my $allowed_actions = "Must be called with an action: $cmd_opt"; if ( $self->can($action) ) { return $self->$action; } elsif ( ! $called_with ) { die $allowed_actions } else { die "Error: undefined action $called_with. $allowed_actions"; } } # Application Code. sub run { exit shift->run_command( @ARGV ); } sub trace { my ( $self, $message ) = @_; return unless $ENV{DC_TRACE}; print "[TRACE] $message\n" if $ENV{DC_TRACE} == 1; print STDERR "[TRACE] $message\n" if $ENV{DC_TRACE} == 2; } 1; __DATA__ #!/bin/sh # [% HEADER %] ### BEGIN INIT INFO # Provides: [% NAME %] # Required-Start: [% REQUIRED_START %] # Required-Stop: [% REQUIRED_STOP %] # Default-Start: 2 3 4 5 # Default-Stop: 0 1 6 # Short-Description: [% SHORT_DESCRIPTION %] # Description: [% DESCRIPTION %] ### END INIT INFO` [% INIT_SOURCE_FILE %] [% INIT_CODE_BLOCK %] if [ -x [% SCRIPT %] ]; then [% SCRIPT %] $1 else echo "Required program [% SCRIPT %] not found!" exit 1; fi __END__ =encoding utf8 =head1 NAME Daemon::Control - Create init scripts in Perl =head1 DESCRIPTION Daemon::Control provides a library for creating init scripts in perl. Your perl script just needs to set the accessors for what and how you want something to run and the library takes care of the rest. You can launch programs through the shell (C) or launch Perl code itself into a daemon mode. Single and double fork methods are supported, and in double-fork mode all the things you would expect such as reopening STDOUT/STDERR, switching UID/GID etc are supported. =head1 SYNOPSIS Write a program that describes the daemon: #!/usr/bin/perl use warnings; use strict; use Daemon::Control; exit Daemon::Control->new( name => "My Daemon", lsb_start => '$syslog $remote_fs', lsb_stop => '$syslog', lsb_sdesc => 'My Daemon Short', lsb_desc => 'My Daemon controls the My Daemon daemon.', path => '/home/symkat/etc/init.d/program', program => '/home/symkat/bin/program', program_args => [ '-a', 'orange', '--verbose' ], pid_file => '/tmp/mydaemon.pid', stderr_file => '/tmp/mydaemon.out', stdout_file => '/tmp/mydaemon.out', fork => 2, )->run; By default C will use @ARGV for the action, and exit with an LSB compatible exit code. For finer control, you can use C, which will return the exit code, and accepts the action as an argument. This enables more programatic control, as well as running multiple instances of L from one script. my $daemon = Daemon::Control->new( ... ); my $exit = $daemon->run_command(“start”); You can then call the program: /home/symkat/etc/init.d/program start You can also make an LSB compatible init script: /home/symkat/etc/init.d/program get_init_file > /etc/init.d/program =head1 CONSTRUCTOR The constructor takes the following arguments as a list or a hash ref. =head2 name The name of the program the daemon is controlling. This will be used in status messages "name [Started]" and the name for the LSB init script that is generated. =head2 program This can be a coderef or the path to a shell program that is to be run. $daemon->program( sub { ... } ); $daemon->program( "/usr/sbin/http" ); =head2 program_args This is an array ref of the arguments for the program. In the context of a coderef being executed this will be given to the coderef as @_, the Daemon::Control instance that called the coderef will be passed as the first arguments. Your arguments start at $_[1]. In the context of a shell program, it will be given as arguments to be executed. $daemon->program_args( [ 'foo', 'bar' ] ); $daemon->program_args( [ '--switch', 'argument' ] ); =head2 user When set, the username supplied to this accessor will be used to set the UID attribute. When this is used, C will be changed from its initial settings if you set it (which you shouldn't, since you're using usernames instead of UIDs). See L for setting numerical user ids. $daemon->user('www-data'); =head2 group When set, the groupname supplied to this accessor will be used to set the GID attribute. When this is used, C will be changed from its initial settings if you set it (which you shouldn't, since you're using groupnames instead of GIDs). See L for setting numerical group ids. $daemon->group('www-data'); =head2 uid If provided, the UID that the program will drop to when forked. This is ONLY supported in double-fork mode and will only work if you are running as root. Accepts numeric UID. For usernames please see L. $daemon->uid( 1001 ); =head2 gid If provided, the GID that the program will drop to when forked. This is ONLY supported in double-fork mode and will only work if you are running as root. Accepts numeric GID, for groupnames please see L. $daemon->gid( 1001 ); =head2 umask If provided, the umask of the daemon will be set to the umask provided, note that the umask must be in oct. By default the umask will not be changed. $daemon->umask( 022 ); Or: $daemon->umask( oct("022") ); =head2 directory If provided, chdir to this directory before execution. =head2 path The path of the script you are using Daemon::Control in. This will be used in the LSB file generation to point it to the location of the script. If this is not provided, the absolute path of $0 will be used. =head2 init_config The name of the init config file to load. When provided your init script will source this file to include the environment variables. This is useful for setting a C and such things. $daemon->init_config( "/etc/default/my_program" ); If you are using perlbrew, you probably want to set your init_config to C<$ENV{PERLBREW_ROOT} . '/etc/bashrc'>. =head2 init_code When given, whatever text is in this field will be dumped directly into the generated init file. $daemon->init_code( "Arbitrary code goes here." ) =head2 help Any text in this accessor will be printed when the script is called with the argument C<--help> or . $daemon->help( "Read The Friendly Source." ); =head2 redirect_before_fork By default this is set to true. STDOUT will be redirected to C, and STDERR will be redirected to C. Setting this to 0 will disable redirecting before a double fork. This is useful when you are using a code reference and would like to leave the filehandles alone until you're in control. Call C<< ->redirect_filehandles >> on the Daemon::Control instance your coderef is passed to redirect the filehandles. =head2 stdout_file If provided stdout will be redirected to the given file. This is only supported in double fork mode. $daemon->stdout_file( "/tmp/mydaemon.stdout" ); Alternatively, you can specify an arrayref of arguments to C: $daemon->stdout_file( [ '>', '/tmp/overwrite-every-run' ] ); $daemon->stdout_file( [ '|-', 'my_pipe_program', '-a foo' ] ); =head2 stderr_file If provided stderr will be redirected to the given file. This is only supported in double fork mode. $daemon->stderr_file( "/tmp/mydaemon.stderr" ); Alternatively, you can specify an arrayref of arguments to C: $daemon->stderr_file( [ '>', '/tmp/overwrite-every-run' ] ); $daemon->stderr_file( [ '|-', 'my_pipe_program', '-a foo' ] ); =head2 pid_file The location of the PID file to use. Warning: if using single-fork mode, it is recommended to set this to the file which the daemon launching in single-fork mode will put its PID. Failure to follow this will most likely result in status, stop, and restart not working. $daemon->pid_file( "/var/run/mydaemon/mydaemon.pid" ); =head2 resource_dir This directory will be created, and chowned to the user/group provided in C, and C. $daemon->resource_dir( "/var/run/mydaemon" ); =head2 prereq_no_process -- EXPERIMENTAL This option is EXPERIMENTAL and defaults to OFF. If this is set, then the C list will be checked at startup for any processes that look like the daemon to be started. By default the pattern used is C<< /\b\b/ >>, but you can pass an override regexp in this field instead (to use the default pattern, just pass C<< prereq_no_process => 1 >>). If matching processes are found, those pids are output, and the daemon will not start. This may produce some false positives on your system, depending on what else is running on your system, but it may still be of some use, e.g. if you seem to have daemons left running where the associated pid file is getting deleted somehow. =head2 fork The mode to use for fork. By default a double-fork will be used. In double-fork, uid, gid, std*_file, and a number of other things are supported. A traditional double-fork is used and setsid is called. In single-fork none of the above are called, and it is the responsibility of whatever you're forking to reopen files, associate with the init process and do all that fun stuff. This mode is recommended when the program you want to control has its own daemonizing code. It is important to note that the PID file should be set to whatever PID file is used by the daemon. In no-fork mode, C, the program is run in the foreground. By default quiet is still turned off, so status updates will be shown on the screen such as that the daemon started. A shortcut to turn status off and go into foreground mode is C being set to 1, or C being set as an environment variable. Additionally, calling C instead of C will override the forking mode at run-time. $daemon->fork( 0 ); $daemon->fork( 1 ); $daemon->fork( 2 ); # Default =head2 scan_name This provides an extra check to see if the program is running. Normally we only check that the PID listed in the PID file is running. When given a regular expression, we will also match the name of the program as shown in ps. $daemon->scan_name( qr|mydaemon| ); =head2 kill_timeout This provides an amount of time in seconds between kill signals being sent to the daemon. This value should be increased if your daemon has a longer shutdown period. By default 1 second is used. $daemon->kill_timeout( 7 ); =head2 lsb_start The value of this string is used for the 'Required-Start' value of the generated LSB init script. See L for more information. $daemon->lsb_start( '$remote_fs $syslog' ); =head2 lsb_stop The value of this string is used for the 'Required-Stop' value of the generated LSB init script. See L for more information. $daemon->lsb_stop( '$remote_fs $syslog' ); =head2 lsb_sdesc The value of this string is used for the 'Short-Description' value of the generated LSB init script. See L for more information. $daemon->lsb_sdesc( 'My program...' ); =head2 lsb_desc The value of this string is used for the 'Description' value of the generated LSB init script. See L for more information. $daemon->lsb_desc( 'My program controls a thing that does a thing.' ); =head2 quiet If this boolean flag is set to a true value all output from the init script (NOT your daemon) to STDOUT will be suppressed. $daemon->quiet( 1 ); =head2 reload_signal The signal to send to the daemon when reloading it. Default signal is C. =head2 stop_signals An array ref of signals that should be tried (in order) when stopping the daemon. Default signals are C, C, C and C (yes, C is tried twice). =head1 PLUGINS Daemon Control supports a simple plugin system using L. =head2 with_plugins With plugins adds the plugins to Daemon::Control. Daemon::Control->with_plugins( qw( MyFirstPlugin +MySecondPlugin) )->new( ... ); Note: MyFirstPlugin will load Daemon::Control::Plugin::MyFirstPlugin +MySecondPlugin will load MySecondPlugin =head2 Writing A Plugin Your plugin should use the name Daemon::Control::Plugin::YourModuleName and YourModuleName should reasonably match the effect your plugin has on Daemon::Control. You can replace Daemon::Control methods by writing your own and using Role::Tiny within your class to allow it to be composed into Daemon::Control. The default Daemon::Control ships with no dependancies and supports Perl 5.8.1+, to use the plugin system your module MUST declare dependency on L and if you wish to use the C, C and C your module MUST declare dependance on L in your package. =head1 METHODS =head2 run_command This function will process an action on the Daemon::Control instance. Valid arguments are those which a C method exists for, such as B, B, B. Returns the LSB exit code for the action processed. =head2 run This will make your program act as an init file, accepting input from the command line. Run will exit with 0 for success and uses LSB exit codes. As such no code should be used after ->run is called. Any code in your file should be before this. This is a shortcut for exit Daemon::Control->new(...)->run_command( @ARGV ); =head2 do_start Is called when start is given as an argument. Starts the forking and exits. Called by: /usr/bin/my_program_launcher.pl start =head2 do_foreground Is called when B is given as an argument. Starts the program or code reference and stays in the foreground -- no forking is done, regardless of the compile-time arguments. Additionally, turns C on to avoid showing L output. /usr/bin/my_program_launcher.pl foreground =head2 do_stop Is called when stop is given as an argument. Stops the running program if it can. Called by: /usr/bin/my_program_launcher.pl stop =head2 do_restart Is called when restart is given as an argument. Calls do_stop and do_start. Called by: /usr/bin/my_program_launcher.pl restart =head2 do_reload Is called when reload is given as an argument. Sends the signal C to the daemon. /usr/bin/my_program_launcher.pl reload =head2 do_status Is called when status is given as an argument. Displays the status of the program, basic on the PID file. Called by: /usr/bin/my_program_launcher.pl status =head2 do_get_init_file Is called when get_init_file is given as an argument. Dumps an LSB compatible init file, for use in /etc/init.d/. Called by: /usr/bin/my_program_launcher.pl get_init_file =head2 pretty_print This is used to display status to the user. It accepts a message and a color. It will default to green text, if no color is explicitly given. Only supports red and green. $daemon->pretty_print( "My Status", "red" ); =head2 write_pid This will write the PID to the file in pid_file. =head2 read_pid This will read the PID from the file in pid_file and set it in pid. =head2 pid An accessor for the PID. Set by read_pid, or when the program is started. =head2 dump_init_script A function to dump the LSB compatible init script. Used by do_get_init_file. =head1 AUTHOR Kaitlyn Parkhurst (SymKat) Isymkat@symkat.comE> ( Blog: L ) =head2 CONTRIBUTORS =over 4 =item * Matt S. Trout (mst) Imst@shadowcat.co.ukE> =item * Mike Doherty (doherty) Idoherty@cpan.orgE> =item * Karen Etheridge (ether) Iether@cpan.orgE> =item * Ævar Arnfjörð Bjarmason (avar) Iavar@cpan.orgE> =item * Kieren Diment Izarquon@cpan.org> =item * Mark Curtis Imark.curtis@affinitylive.com> =item * Zoffix Znet Izoffix@cpan.org> =back =head2 SPONSORS Parts of this code were paid for by =over 4 =item (mt) Media Temple L =back =head1 COPYRIGHT Copyright (c) 2012 the Daemon::Control L, L, and L as listed above. =head1 LICENSE This library is free software and may be distributed under the same terms as perl itself. =head2 AVAILABILITY The most current version of Daemon::Control can be found at L Daemon-Control-0.001010/Makefile.PL0000644000175000017500000000115313434276144016770 0ustar catalystcatalystBEGIN { push @INC, '.' unless $INC[-1] eq '.' } use inc::Module::Install; # Define metadata name 'Daemon-Control'; all_from 'lib/Daemon/Control.pm'; license 'perl'; resources bugtracker => 'http://github.com/symkat/Daemon-Control/issues', IRC => 'irc://irc.freenode.org/#perl-daemon-control'; # Specific dependencies requires 'File::Spec' => '0'; requires 'POSIX' => '0'; requires 'Cwd' => '0'; requires 'File::Path' => '2.08'; test_requires 'Test::More' => '0.88'; test_requires 'File::Temp' => '0.14'; WriteAll;