view release on metacpan or  search on metacpan

lib/Server/Control.pm  view on Meta::CPAN

sub _perform_cli_action {
    my ($self) = @_;
    my $action = $self->action;

    if ( !defined $action ) {
        $self->_cli_usage("must specify -k");
    }
    elsif ( !grep { $_ eq $action } $self->valid_cli_actions ) {
        $self->_cli_usage(
            sprintf(
                "invalid action '%s' - valid actions are %s",
                $action,
                join( ", ",
                    ( map { "'$_'" } sort( $self->valid_cli_actions ) ) )
            )
        );
    }
    else {
        ( my $action_method = $action ) =~ s/\-/_/g;
        $self->$action_method();
    }
}

sub _cli_usage {
    my ( $class, $msg, $verbose ) = @_;

    $msg     ||= "";
    $verbose ||= 0;
    my $usage = Capture::Tiny::capture_merged {
        pod2usage( -msg => $msg, -verbose => $verbose, -exitval => "NOEXIT" );
    };
    if ( $usage !~ /\S/ ) {
        die "could not get usage from pod2usage for $0";
    }
    else {
        print STDERR $usage;
        exit(2);
    }
}

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

    my $proc = $self->is_running();
    unless ($proc) {
        $log->warn( $self->status_as_string() );
    }
    return $proc;
}

sub _warn_if_different_user {
    my ( $self, $proc ) = @_;

    my ( $uid, $eid ) = ( $<, $> );
    if ( ( $eid || $uid ) && $proc->uid != $uid && !$self->use_sudo() ) {
        $log->warnf(
            "warning: process %d is owned by uid %d ('%s'), different than current user %d ('%s'); may not be able to stop server",
            $proc->pid,
            $proc->uid,
            scalar( getpwuid( $proc->uid ) ),
            $uid,
            scalar( getpwuid($uid) )
        );
    }
}

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

    my $ptable = process_table();
    my ($proc) = grep { $_->pid == $pid } @{ $ptable->table };
    return $proc;
}

sub _read_pid_file {
    my ( $self, $pid_file ) = @_;

    my $pid_contents = eval { read_file($pid_file) };
    if ($@) {
        $log->debugf( "pid file '%s' does not exist", $pid_file )
          if $log->is_debug && !$self->{_suppress_logs};
        return undef;
    }
    else {
        my ($pid) = ( $pid_contents =~ /^\s*(\d+)\s*$/ );
        unless ( defined($pid) ) {
            $log->infof( "pid file '%s' does not contain a valid process id!",
                $pid_file );
            $self->_handle_corrupt_pid_file();
            return undef;
        }
        return $pid;
    }
}

1;



=pod

=head1 NAME

Server::Control -- Flexible apachectl style control for servers

=head1 VERSION

version 0.20

=head1 SYNOPSIS

    use Server::Control::Apache;

    my $apache = Server::Control::Apache->new(
        conf_file => '/my/apache/dir/conf/httpd.conf'
    );
    if ( !$apache->is_running() ) {
        $apache->start();
    }

=head1 DESCRIPTION