File Coverage

blib/lib/Proc/Launcher.pm

Criterion	Covered	Total	%
statement	181	205	88.2
branch	66	94	70.2
condition	3	3	100.0
subroutine	24	24	100.0
pod	15	15	100.0
total	289	341	84.7

package Proc::Launcher;
use strict;
use warnings;

our $VERSION = '0.0.35'; # VERSION

use Mouse;

#_* Libraries

use File::Path;
use File::Tail;
use POSIX qw(setsid :sys_wait_h);

#_* POD

=head1 NAME

Proc::Launcher - yet another forking process controller


=head1 VERSION

version 0.0.35

=head1 SYNOPSIS

    use Proc::Launcher;

    # define a method to start your application if it isn't already running
    use MyApp;
    my $start_myapp = sub { MyApp->new( context => $some_shared_data )->run() };

    # create a new launcher object
    my $launcher = Proc::Launcher->new( start_method => $start_myapp,
                                        daemon_name  => 'myapp',
                                      );

    # an alternate version of the same thing without the subroutine reference
    my $launcher = Proc::Launcher->new( class        => 'MyApp',
                                        start_method => 'run'
                                        context      => $some_shared_data,
                                        daemon_name  => 'myapp',
                                      );

    # check if the process was already running
    if ( $launcher->is_running() ) { warn "Already running!\n" }

    # start the process if there isn't already one running
    $launcher->start();

    # shut down the process if it is already running.  start a new process.
    $launcher->restart();

    # get the process pid
    my $pid = $launcher->pid();

    # kill -HUP
    $launcher->stop();

    # kill -9
    $launcher->force_stop();

    # get the process log file path
    my $log = $launcher->log_file;

=head1 DESCRIPTION

This library is designed to fork one or more long-running background
processes and to manage them.  This includes starting, stopping, and
automatically restarting processes--even those that don't behave well.

The pid of the forked child processes are written to pid files and
persist across multiple restarts of the launcher.  This means that
stdout/stderr/stdin of the children are not directly connected to the
launching process.  All stdout and stderr from the child processes is
written to a log file.

For more useful functions (e.g. a supervisor to restart processes that
die), see L.

=head1 RELATED WORK

There are a large number of modules already on CPAN for forking and
managing child processes, and also for managing daemon processes
(apachectl style).  After doing a lot of reading and experimentation,
I unfortunately ended up deciding to write yet another one.  Here is a
bit of information on related modules and how this one differs.

While it is possible to exec() and manage external executables in the
child processes, that is merely an afterthought in this module.  If
you are looking for a module to start and manage external executables,
you might also want to check out L, L,
L, or L on CPAN, or ControlFreak on github.

If you are looking to investigate and/or kill running processes IDs,
see L, L, or L.  This
module only manages processes that have been forked by this module.

If you only want to read and write a PID file, see L.

On the other hand, if you're looking for a library to fork dependent
child processes that maintain stdout/stderr/stdin connected to the
child, check out L, L, L,
L, L, etc.  This module assumes that all
child processes will close stdin/stdout/stderr and will continue to
live even after the launching process has exited.  Furthermore the
launched process will be manageable by launchers that are started
after the launched process is already running.

This library does not do anything like forking/pre-forking multiple
processes for a single daemon (e.g. for a high-volume server, see
L) or limiting the maximum number of running
child processes (see L or L).  Instead
it is assumed that you are dealing with is a fixed set of named
daemons, each of which is associated with a single process to be
managed.  Of course any managed processes could fork it's own
children.  Note that only the process id of the immediate child will
be managed--any child processes created by child process
(grandchildren of the launcher) are not tracked.

Similarly your child process should never do a fork() and exit() or
otherwise daemonize on it's own.  When the child does this, the
launcher will lose track of the grandchild pid and assume it has shut
down.  This may result in restarting your service while it is already
running.

This library does not handle command line options--that is left to
your application/script.  It does not export any methods nor require
you to inherit from any classes or to build any subclasses.  This
means that you can launch a process from any normal perl subroutine or
object method--the launched class/method/subroutine does not have to
be modified to be daemonized.

This library does not use or require an event loop (e.g. AnyEvent,
POE, etc.), but is fully usable from with an event loop since objects
of this class avoid calling sleep() (doing so inside a single-threaded
event loop causes everything else running in the event loop to wait).
This does mean that methods such as stop() will return immediately
without providing a status.  See more about this in the note below in
rm_zombies().

For compatibility with the planned upcoming L module
(which uses L), this module and it's dependencies are
written in pure perl.

The intended use for this library is that a supervising process will
acquire some (immutable) global configuration data which is then
passed (at fork time) to one or more long-running component daemon
processes.  In the Panoptes project, this library is used for starting
and managing the various Panoptes components on each node
(L, L, L,
etc.) and also for managing connections to the remote agents.

If you are aware of any other noteworthy modules in this vein, please
let me know!

=cut

#_* Roles

with 'Proc::Launcher::Roles::Launchable';

#_* Attributes

=head1 CONSTRUCTOR OPTIONS

The constructor supports the following options, e.g.:

  my $launcher = Proc::Launcher->new( debug => 1, ... );

Each of these attributes will also have a getter, e.g.:

  if ( $launcher->debug ) { print "DEBUGGING ENABLED!\n" }

All attributes are read-only unless otherwise specified.  Read/write
attributes may be set like so:

  $launcher->debug( 1 );

=over 8

=item debug => 0

Enable debugging messages to STDOUT.  This attribute is read/write.

=cut

has 'debug'        => ( is => 'rw', isa => 'Bool', default => 0 );

=item daemon_name => 'somename'

Specify the name of the daemon.  This will be used as the prefix for
the log file, pid file, etc.

=cut

has 'daemon_name'  => ( is => 'ro', isa => 'Str', required => 1 );

=item context => $data

Context data to be passed to the forked processes.  This could be any
complex data structure and may contain things like configuration data.

=cut

has 'context'      => ( is => 'ro', default => sub { {} } );

=item class => 'My::App'

Name of the class where the start method is located.  An object of
this class will be created, passing in your context data.  Then the
start_method will be called on the object.

=cut

has 'class'        => ( is => 'ro', isa => 'Str' );

=item start_method => 'start_me'

If a class is specified, this is the name of the start method in that
class.

If no class is specified, this must be a subroutine reference.

=cut

has 'start_method' => ( is => 'ro', required => 1 );

=item pid_dir => "$ENV{HOME}/logs"

Specify the directory where the pid file should live.

=cut

has 'pid_dir'      => ( is => 'ro',
                        isa => 'Str',
                        lazy => 1,
                        default => sub {
                            my $dir = join "/", $ENV{HOME}, "logs";
                            unless ( -d $dir ) {  mkpath( $dir ); }
                            return $dir;
                        },
                    );

=item pid_file => "$pid_dir/$daemon_name.pid"

Name of the pid file.

=cut

has 'pid_file'     => ( is => 'ro',
                        isa => 'Str',
                        lazy => 1,
                        default => sub {
                            my ( $self ) = @_;
                            my $daemon = $self->daemon_name;
                            return join "/", $self->pid_dir, "$daemon.pid";
                        },
                    );

=item disable_file => "$pid_dir/$daemon_name.disabled"

Location to the 'disable' file.  If this file exists, the daemon will
not be started when start() is called.

=cut

has 'disable_file' => ( is => 'ro',
                        isa => 'Str',
                        lazy => 1,
                        default => sub {
                            my ( $self ) = @_;
                            my $daemon = $self->daemon_name;
                            return join "/", $self->pid_dir, "$daemon.disabled";
                        },
                    );

=item log_file => "$pid_dir/$daemon_name.log"

Path to the daemon log file.  The daemon process will have both stdout
and stderr redirected to this log file.

=cut

has 'log_file'     => ( is => 'ro',
                        isa => 'Str',
                        lazy => 1,
                        default => sub {
                            my $self = shift;
                            my $daemon = $self->daemon_name;
                            return join "/", $self->pid_dir, "$daemon.log";
                        },
                    );

has 'file_tail'    => ( is => 'ro',
                        isa => 'File::Tail',
                        lazy => 1,
                        default => sub {
                            my $self = shift;
                            unless ( -r $self->log_file ) { system( 'touch', $self->log_file ) }
                            return File::Tail->new( name        => $self->log_file,
                                                    nowait      => 1,
                                                    interval    => 1,
                                                    maxinterval => 1,
                                                    resetafter  => 600,
                                                );
                        },
                    );


=item pipe => 0

If set to true, specifies that the forked process should create a
named pipe.  The forked process can then read from the named pipe on
STDIN.  If your forked process does not read from and process STDIN,
then there's no use in enabling this option.

=cut

has 'pipe'         => ( is => 'ro',
                        isa => 'Bool',
                        default => 0,
                    );

=item pipe_file => "$pid_dir/$daemon_name.cmd"

Path to the named pipe.

=cut

has 'pipe_file'    => ( is => 'ro',
                        isa => 'Str',
                        lazy => 1,
                        default => sub {
                            my $self = shift;
                            my $daemon = $self->daemon_name;
                            return join "/", $self->pid_dir, "$daemon.cmd";
                        },
                    );

#_* Methods

=back

=head1 METHODS

=over 8

=item start( $data )

Fork a child process.  The process id of the forked child will be
written to a pid file.

The child process will close STDIN and redirect all stdout and stderr
to a log file, and then will execute the child start method and will
be passed any optional $data that was passed to the start method.

Note that there is no ongoing communication channel set up with the
child process.  Changes to $data in the supervising process will never
be available to the child process(es).  In order to force the child to
pick up the new data, you must stop the child process and then start a
new process with a copy of the new data.

If the process is found already running, then the method will
immediately return null.  If a process was successfully forked,
success will be returned.  Success does not imply that the daemon was
started successfully--for that, check is_running().

=cut

sub start {
    my ( $self, $args ) = @_;

    unless ( $self->is_enabled ) {
        print $self->daemon_name, " daemon disabled, not starting\n";
        return;
    }

    if ( $self->is_running() ) {
        $self->_debug( "Already running, no start needed" );
        return;
    }

    my $log = $self->log_file;

    if ( my $pid = fork ) {    # PARENT

        print "LAUNCHED CHILD PROCESS: pid=$pid log=$log\n";

      CHECK_PID:
        for ( 1 .. 5 ) {

            $self->_debug( "Checking if our child locked the pidfile" );

            # attempt to read the pidfile
            my $locked_pid = $self->pid();

            $self->_debug( "Got locked pid: $locked_pid" );

            # check if the pidfile is locked by a valid process
            if ( $locked_pid && $self->is_running( $pid ) ) {

                $self->_debug( "Pid is running: $pid" );

                # check if the pid that has the lock is our child process
                if ( $locked_pid == $pid ) {

                    $self->_debug( "Locked pid is our child pid: $pid" );
                    return $pid;
                }
                else {
                    $self->_debug( "Locked pid is NOT our child pid: $pid" );
                    print "CHILD PROCESS ALREADY RUNNING\n";
                    return;
                }
            }

            sleep 1;
        }
    }
    else {                     # CHILD

        unless ( $self->write_my_pid( $$ ) ) {
            $self->_debug( "CHILD FAILED TO LOCK PIDFILE: $pid" );
            exit 1;
        }

        #chdir '/'                          or die "Can't chdir to /: $!";

        # wu - ugly bug fix - when closing STDIN, it becomes free and
        # may later get reused when calling open (resulting in error
        # 'Filehandle STDIN reopened as $fh only for output'). :/ So
        # instead of closing, just re-open to /dev/null.
        open STDIN, '<', '/dev/null'       or die "$!";

        open STDOUT, '>>', $self->log_file or die "Can't write stdout to $log: $!";
        open STDERR, '>>', $self->log_file or die "Can't write stderr to $log: $!";

        setsid                             or die "Can't start a new session: $!";

        #umask 0;

        # this doesn't work on most platforms
        $0 = join " - ", "perl", "Proc::Launcher", $self->daemon_name;

        print "\n\n", ">" x 77, "\n";
        print "Starting process: pid = $$: ", scalar localtime, "\n\n";

        if ( $self->pipe ) {
            my $named_pipe = $self->pipe_file;
            print "CREATING NAMED PIPE: $named_pipe\n";
            unless (-p $named_pipe) {
                unlink $named_pipe;
                POSIX::mkfifo( $named_pipe, 0700) or die "can't mkfifo $named_pipe: $!"; ## no critic - leading zero
            }
            open STDIN, '<', $named_pipe or die "$!";
        }

        # child
        if ( $self->class ) {

            my $class = $self->class;
            print "Loading Class: $class\n";

            eval "require $class"; ## no critic

            my $error = $@;
            if ( $error ) {
                $self->stopped();
                die "FATAL ERROR LOADING $class: $error\n";
            }
            else {
                print "Successfully loaded class\n";
            }

            print "Creating an instance of $class\n";
            my $obj;
            eval {                          # try
                $obj = $class->new( context => $self->context );
                1;
            } or do {                       # catch
                $self->stopped();
                die "FATAL: unable to create an instance: $@\n";
            };
            print "Created\n";

            my $method = $self->start_method;
            print "Calling method on instance: $method\n";

            eval {                          # try
                $obj->$method( $args );
                1;
            } or do {                       # catch
                $self->stopped();
                die "FATAL: $@\n";
            };

        }
        else {
            print "STARTING\n";
            eval {                          # try
                $self->start_method->( $args );
                1;
            } or do {                       # catch
                # error
                print "ERROR: $@\n";
            };

        }

        # cleanup
        print "EXITED\n";
        $self->stopped();

        exit;
    }
}

=item stop()

If the process id is active, send it a kill -HUP.

=cut

sub stop {
    my ( $self ) = @_;

    if ( ! $self->is_running() ) {
        $self->_debug( "Process not found running" );
        return 1;
    }

    my $pid = $self->pid();

    $self->_debug( "Killing process: $pid" );
    my $status = kill 1 => $pid;

    return $status;
}

=item restart( $data, $sleep )

Calls the stop() method, followed by the start() method, optionally
passing some $data to the start() method.

This method is not recommended since it doesn't check the status of
stop().  Instead, call stop(), wait a bit, and then check that the
process has shut down before trying to start it again.

WARNING: this method calls sleep to allow a process to shut down
before trying to start it again.  If sleep is set to 0, the child
process won't have time to exit, and thus the start() method will
never run.  As a result, this method is not recommended for use in a
single-threaded cooperative multitasking environments such as POE.

=cut

sub restart {
    my ( $self, $data, $sleep ) = @_;

    $self->stop();

    $sleep = $sleep ? $sleep : 1;
    sleep $sleep;

    $self->start( $data );
}


=item is_running()

Check if a process is running by sending it a 'kill -0' and checking
the return status.

Before checking the process, rm_zombies() will be called to allow any
child processes that have exited to be reaped.  See a note at the
rm_zombies() method about the leaky abstraction here.

If the pid is not active, the stopped() method will also be called to
ensure the pid file has been removed.

=cut

sub is_running {
    my ( $self, $pid ) = @_;

    unless ( $pid ) { $pid = $self->pid() }

    return unless $pid;

    # clean up deceased child processes before checking if processes
    # are running.
    $self->rm_zombies();

    $self->_debug( "CHECKING PID: $pid" );

    if ( kill 0 => $pid ) {
        if ( $!{EPERM} ) {
            # if process id isn't owned by us, it is assumed to have
            # been recycled, i.e. our process died and the process id
            # was assigned to another process.
            $self->_debug( "Process id active but owned by someone else" );
        }
        else {
            $self->_debug( "STILL RUNNING" );
            return $self->daemon_name;
        }
    }

    $self->_debug( "PROCESS NOT RUNNING" );

    # process is not running, ensure the pidfile has been cleaned up
    $self->stopped();

    return;
}

=item rm_zombies()

Calls waitpid to clean up any child processes that have exited.

waitpid is called with the WNOHANG option so that it will always
return instantly to prevent hanging.

Normally this is called when the is_running() method is called (to
allow child processes to exit before polling if they are still
active).  If you are using a Proc::Launcher in a long-lived process,
after stopping a daemon you should always call is_running() until you
get a false response (i.e. the process has successfully stopped).  If
you do not call is_running() until the process exits, you will create
zombies.

=cut

sub rm_zombies {
    waitpid(-1, WNOHANG);
}

=item force_stop()

If the process id is active, then send a 'kill -9'.

=cut

sub force_stop {
    my ( $self ) = @_;

    if ( ! $self->is_running() ) {
        $self->_debug( "Process not found running" );
        return 1;
    }

    $self->_debug( "Process still running, executing with kill -9" );
    my $status = kill 9 => $self->pid();

    return $status;
}


=item stopped()

This method is called when a process has been detected as successfully
shut down.  The pidfile will be removed if it still exists.

=cut

sub stopped {
    my ( $self ) = @_;

    $self->_debug( "Process exited" );

    # remove the pidfile
    $self->remove_pidfile();

    # remove the named pipe if one was enabled
    if ( $self->pipe ) { unlink $self->pipe_file }
}

=item pid()

Read and return the pid from the pidfile.

The pid is validated to ensure it is a number.  If an invalid pid is
found, 0 is returned.

=cut

sub pid {
    my ( $self ) = @_;

    my $path = $self->pid_file;

    unless ( -r $path ) {
        return 0;
    }

    $self->_debug( "READING PID FROM: $path" );

    open(my $fh, "<", $path)
        or die "Couldn't open $path for reading: $!\n";

    my $line = <$fh>;

    close $fh or die "Error closing file: $!\n";

    return 0 unless $line;
    chomp $line;
    return 0 unless $line;

    unless ( $line =~ m|^\d+$| ) {
        warn "ERROR: PID doesn't look like a number: $line";
        return 0;
    }

    return $line;
}

=item write_my_pid()

Write the pid to the pid file.

This operation involves checking a couple of times to make sure that
no other process is running or trying to start another process at the
same time.  The pid is actually written to a temporary file and then
renamed.  Since rename() is an atomic operation on most filesystems,
this serves as a basic but effective locking mechanism that doesn't
require OS-level locking.  This should prevent two processes from both
starting a daemon at the same time.

=cut

sub write_my_pid {
    my ( $self, $pid ) = @_;

    unless ( $pid ) { $pid = $$ }

    # try to read the pidfile and see if the pid therein is active
    return if $self->is_running();

    # write the pid to a temporary file
    my $path = join ".", $self->pid_file, $pid;
    $self->_debug( "WRITING PID TO: $path" );
    open(my $pid_fh, ">", $path)
        or die "Couldn't open $path for writing: $!\n";
    print $pid_fh $pid;
    close $pid_fh or die "Error closing file: $!\n";

    # if some other process has created a pidfile since we last
    # checked, then it won and we lost
    if ( -r $self->pid_file ) {
        $self->_debug( "Pidfile already created by another process" );
        return
    }

    # atomic operation
    unless ( rename $path, $self->pid_file ) {
        $self->_debug( "Unable to lock pidfile $path for $pid" );
        return;
    }

    $self->_debug( "Successfully renamed pidfile to $path: $pid" );

    return 1;
}

=item remove_pidfile

Remove the pidfile.  This should only be done after the process has
been verified as shut down.

Failure to remove the pidfile is not a fatal error.

=cut

sub remove_pidfile {
    my ( $self ) = @_;

    return unless -r $self->pid_file;

    $self->_debug( "REMOVING PIDFILE: " . $self->pid_file );
    unlink $self->pid_file;
}

=item read_log

Return any new log data since the last offset was written.  If there
was no offset, set the offset to the current end of file.

You may want to call this before performing any operation on the
daemon in order to set the position to the end of the file.  Then
perform your operation, wait a moment, and then call read_log() to get
any output generated from your command while you waited.

=cut

sub read_log {
    my ( $self, $subref ) = @_;

    my $name = $self->daemon_name;

    while ( my $line=$self->file_tail->read ) {
        chomp $line;
        $subref->( "$name: $line" );
    }

    return 1;
}

=item write_pipe( $string )

Write text to the process's named pipe.  The child can then read this
data from it's STDIN.

Simply returns false if a named pipe was not enabled.

=cut

sub write_pipe {
    my ( $self, $string ) = @_;

    return unless $self->pipe;
    $self->_debug( "Writing to pipe" );

    unless ( -r $self->pipe_file ) {
        $self->_debug( "Pipe found but not readable" );
        return;
    }

    # remove any trailing whitespace
    chomp $string;

    # blast the string out to the named pipe
    print { sysopen (my $fh , $self->pipe_file, &POSIX::O_WRONLY) or die "$!\n"; $fh } $string, "\n";

    return 1;
}

=item disable()

Create the disable flag file unless it already exists.

=cut

sub disable {
    my ( $self ) = @_;

    if ( $self->is_enabled() ) {
        system( "touch", $self->disable_file );
    }

    return 1;
}

=item enable()

If the disable flag file exists, remove it.

=cut

sub enable {
    my ( $self ) = @_;

    unless ( $self->is_enabled() ) {
        unlink $self->disable_file;
    }

    return 1;
}

=item is_enabled()

Check if the launcher is enabled.

If the disable flag file exists, then the launcher will be considered
disabled.

=cut

sub is_enabled {
    my ( $self ) = @_;

    return if -r $self->disable_file;

    return 1;
}

# debugging output
sub _debug {
    my ( $self, @lines ) = @_;

    return unless $self->debug;

    for my $line ( @lines ) {
        chomp $line;
        print "$line\n";
    }
}

no Mouse;

1;

__END__