view release on metacpan or  search on metacpan

lib/Apache/TestServer.pm  view on Meta::CPAN

        error "$opts->{debugger} is not a supported debugger",
              "These are the supported debuggers: ".
              join ", ", sort keys %debuggers;
        die("\n");
    }

    my $debugger = $opts->{debugger};
    $debugger =~ s/\d+$//;

    my $method = "start_" . $debuggers{$debugger};

    ## $opts->{debugger} is passed through unchanged
    ## so when we try to run it next, its found.
    $self->$method($opts);
}

sub pid {
    my $self = shift;
    my $file = $self->pid_file;
    my $fh = Symbol::gensym();
    open $fh, $file or do {
        return 0;
    };

    # try to avoid the race condition when the pid file was created
    # but not yet written to
    for (1..8) {
        last if -s $file > 0;
        select undef, undef, undef, 0.25;
    }

    chomp(my $pid = <$fh> || '');
    $pid;
}

sub select_next_port {
    my $self = shift;

    my $max_tries = 100; #XXX
    while ($max_tries-- > 0) {
        return $self->{port_counter}
            if $self->port_available(++$self->{port_counter});
    }

    return 0;
}

sub port_available {
    my $self = shift;
    my $port = shift || $self->{config}->{vars}->{port};
    local *S;

    my $proto = getprotobyname('tcp');

    socket(S, Socket::PF_INET(),
           Socket::SOCK_STREAM(), $proto) || die "socket: $!";
    setsockopt(S, Socket::SOL_SOCKET(),
               Socket::SO_REUSEADDR(),
               pack("l", 1)) || die "setsockopt: $!";

    if (bind(S, Socket::sockaddr_in($port, Socket::INADDR_ANY()))) {
        close S;
        return 1;
    }
    else {
        return 0;
    }
}

=head2 stop()

attempt to stop the server.

returns:

  on success: $pid of the server
  on failure: -1

=cut

sub stop {
    my $self = shift;
    my $aborted = shift;

    if (WIN32) {
        require Win32::Process;
        my $obj = $self->{config}->{win32obj};
        my $pid = -1;
        if ($pid = $obj ? $obj->GetProcessID : $self->pid) {
            if (kill(0, $pid)) {
                Win32::Process::KillProcess($pid, 0);
                warning "server $self->{name} shutdown";
            }
        }
        unlink $self->pid_file if -e $self->pid_file;
        return $pid;
    }

    my $pid = 0;
    my $tries = 3;
    my $tried_kill = 0;

    my $port = $self->{config}->{vars}->{port};

    while ($self->ping) {
        #my $state = $tried_kill ? "still" : "already";
        #print "Port $port $state in use\n";

        if ($pid = $self->pid and !$tried_kill++) {
            if (kill TERM => $pid) {
                warning "server $self->{name} shutdown";
                sleep 1;

                for (1..6) {
                    if (! $self->ping) {
                        if ($_ == 1) {
                            unlink $self->pid_file if -e $self->pid_file;
                            return $pid;
                        }
                        last;
                    }