view release on metacpan or  search on metacpan

lib/Message/Passing/Role/Script.pm  view on Meta::CPAN

option daemonize => (
    is => 'ro',
    isa => Bool,
    default => sub { 0 },
    doc => 'pass 1 to daemonize',
);

option io_priority => (
    isa => sub { $_[0] =~ /^(none|be|rt|idle)$/ },
    coerce => sub { lc $_[0] },
    is => 'ro',
    predicate => "_has_io_priority",
    format => 's',
    doc => 'the IO priority to run the script at: none, be, rt, idle',
);

option user => (
    isa => Str,
    is => 'ro',
    predicate => "_has_user",
    format => 's',
    doc => 'changes the user the script is running as',
);

option pid_file => (
    isa => Str,
    is => 'ro',
    predicate => "_has_pid_file",
    format => 's',
    doc => 'the name of the pid file including the directory',
);

sub daemonize_if_needed {
    my ($self) = @_;
    my $fh;
    if ($self->_has_pid_file) {
        open($fh, '>', $self->pid_file)
            or confess("Could not open pid file '". $self->pid_file . "': $?");
    }
    if ($self->daemonize) {
        fork && exit;
        POSIX::setsid();
        fork && exit;
        chdir '/';
        umask 0;
    }
    if ($fh) {
        print $fh $$ . "\n";
        close($fh);
    }
}

sub change_uid_if_needed {
    my $self = shift;
    my ($uid, $gid);
    if ($self->_has_user) {
        my $user = $self->user;
        $uid = getpwnam($user) ||
            die("User '$user' does not exist, cannot become that user!\n");
        (undef, undef, undef, $gid ) = getpwuid($uid);
    }
    if ($gid) {
        setgid($gid) || die("Could not setgid to '$gid' are you root? : $!\n");
    }
    if ($uid) {
        setuid($uid) || die("Could not setuid to '$uid' are you root? : $!\n");
    }
}

sub set_io_priority_if_needed {
    my $self = shift;
    return unless $self->_has_io_priority;
    require Linux::IO_Prio;
    my $sym = do {
        no strict 'refs';
        &{"Linux::IO_Prio::IOPRIO_CLASS_" . uc($self->io_priority)}();
    };
    Linux::IO_Prio::ioprio_set(Linux::IO_Prio::IOPRIO_WHO_PROCESS(), $$,
        Linux::IO_Prio::IOPRIO_PRIO_VALUE($sym, 0)
    );
}

sub start {
    my $class = shift;
    my $instance = $class->new_with_options(@_);
    $instance->set_io_priority_if_needed;
    $instance->change_uid_if_needed;
    $instance->daemonize_if_needed;
    run_message_server $instance->build_chain;
}

1;

=head1 NAME

Message::Passing::Role::Script - Handy role for building messaging scripts.

=head1 SYNOPSIS

    # my_message_passer.pl
    package My::Message::Passer;
    use Moo;
    use MooX::Options;
    use MooX::Types::MooseLike::Base qw/ Bool /;
    use Message::Passing::DSL;

    with 'Message::Passing::Role::Script';

    option foo => (
        is => 'ro',
        isa => Bool,
    );

    sub build_chain {
        my $self = shift;
        message_chain {
            input example => ( output_to => 'test_out', .... );
            output test_out => ( foo => $self->foo, ... );
        };
    }