testserver.pm

视频监控网络部分的协议ddns,的模块的实现代码,请大家大胆指正.

    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;
                    }
                    if ($_ == 1) {
                        warning "port $port still in use...";
                    }
                    else {
                        print "...";
                    }
                    sleep $_;
                }

                if ($self->ping) {
                    error "\nserver was shutdown but port $port ".
                          "is still in use, please shutdown the service ".
                          "using this port or select another port ".
                          "for the tests";
                }
                else {
                    print "done\n";
                }
            }
            else {
                error "kill $pid failed: $!";
            }
        }
        else {
            error "port $port is in use, ".
                  "cannot determine server pid to shutdown";
            return -1;
        }

        if (--$tries <= 0) {
            error "cannot shutdown server on Port $port, ".
                  "please shutdown manually";
            unlink $self->pid_file if -e $self->pid_file;
            return -1;
        }
    }

    unlink $self->pid_file if -e $self->pid_file;
    return $pid;
}

sub ping {
    my $self = shift;
    my $pid = $self->pid;

    if ($pid and kill 0, $pid) {
        return $pid;
    }
    elsif (! $self->port_available) {
        return -1;
    }

    return 0;
}

sub failed_msg {
    my $self = shift;
    my($log, $rlog) = $self->{config}->error_log;
    my $log_file_info = -e $log ?
        "please examine $rlog" :
        "$rlog wasn't created, start the server in the debug mode";
    error "@_ ($log_file_info)";
}

#this doesn't work well on solaris or hpux at the moment
use constant USE_SIGCHLD => $^O eq 'linux';

sub start {
    my $self = shift;

    my $old_pid = -1;
    if (WIN32) {
        # Stale PID files (e.g. left behind from a previous test run
        # that crashed) cannot be trusted on Windows because PID's are
        # re-used too frequently, so just remove it. If there is an old
        # server still running then the attempt to start a new one below
        # will simply fail because the port will be unavailable.
        if (-f $self->pid_file) {
            error "Removing old PID file -- " .
                "Unclean shutdown of previous test run?\n";
            unlink $self->pid_file;
        }
        $old_pid = 0;
    }
    else {
        $old_pid = $self->stop;
    }
    my $cmd = $self->start_cmd;
    my $config = $self->{config};
    my $vars = $config->{vars};
    my $httpd = $vars->{httpd} || 'unknown';

    if ($old_pid == -1) {
        return 0;
    }

    local $| = 1;

    unless (-x $httpd) {
        my $why = -e $httpd ? "is not executable" : "does not exist";
        error "cannot start server: httpd ($httpd) $why";
        return 0;
    }

    print "$cmd\n";
    my $old_sig;

    if (WIN32) {
        #make sure only 1 process is started for win32
        #else Kill will only shutdown the parent
        my $one_process = $self->version_of(\%one_process);
        require Win32::Process;
        my $obj;
        # We need the "1" below to inherit the calling processes
        # handles when running Apache::TestSmoke so as to properly
        # dup STDOUT/STDERR
        Win32::Process::Create($obj,
                               $httpd,
                               "$cmd $one_process",
                               1,
                               Win32::Process::NORMAL_PRIORITY_CLASS(),
                               '.');
        unless ($obj) {
            die "Could not start the server: " .
                Win32::FormatMessage(Win32::GetLastError());
        }
        $config->{win32obj} = $obj;
    }
    else {
        $old_sig = $SIG{CHLD};

        if (USE_SIGCHLD) {
            # XXX: try not to be POSIX dependent
            require POSIX;

            #XXX: this is not working well on solaris or hpux
            $SIG{CHLD} = sub {
                while ((my $child = waitpid(-1, POSIX::WNOHANG())) > 0) {
                    my $status = $? >> 8;
                    #error "got child exit $status";
                    if ($status) {
                        my $msg = "server has died with status $status";
                        $self->failed_msg("\n$msg");
                        Apache::TestRun->new(test_config => $config)->scan_core;
                        kill SIGTERM => $$;
                    }
                }
            };
        }

        defined(my $pid = fork) or die "Can't fork: $!";
        unless ($pid) { # child
            my $status = system "$cmd";
            if ($status) {
                $status  = $? >> 8;
                #error "httpd didn't start! $status";
            }
            CORE::exit $status;
        }
    }

    while ($old_pid and $old_pid == $self->pid) {
        warning "old pid file ($old_pid) still exists";
        sleep 1;
    }

    my $version = $self->{version};
    my $mpm = $config->{mpm} || "";
    $mpm = "($mpm MPM)" if $mpm;
    print "using $version $mpm\n";

    my $timeout = $vars->{startup_timeout} ||
                  $ENV{APACHE_TEST_STARTUP_TIMEOUT} ||
                  60;

    my $start_time = time;
    my $preamble = "${CTRL_M}waiting $timeout seconds for server to start: ";
    print $preamble unless COLOR;
    while (1) {
        my $delta = time - $start_time;
        print COLOR
            ? ($preamble, sprintf "%02d:%02d", (gmtime $delta)[1,0])
            : '.';
        sleep 1;
        if ($self->pid) {
            print $preamble, "ok (waited $delta secs)\n";
            last;
        }
        elsif ($delta > $timeout) {
            my $suggestion = $timeout + 300;
            print $preamble, "not ok\n";
            error <<EOI;
giving up after $delta secs. If you think that your system
is slow or overloaded try again with a longer timeout value.
by setting the environment variable APACHE_TEST_STARTUP_TIMEOUT
to a high value (e.g. $suggestion) and repeat the last command.
EOI
            last;
        }
    }

    # now that the server has started don't abort the test run if it
    # dies
    $SIG{CHLD} = $old_sig || 'DEFAULT';

    if (my $pid = $self->pid) {
        print "server $self->{name} started\n";

        my $vh = $config->{vhosts};
        my $by_port = sub { $vh->{$a}->{port} <=> $vh->{$b}->{port} };

        for my $module (sort $by_port keys %$vh) {
            print "server $vh->{$module}->{name} listening ($module)\n",
        }

        if ($config->configure_proxy) {
            print "tests will be proxied through $vars->{proxy}\n";
        }
    }
    else {
        $self->failed_msg("server failed to start!");
        return 0;
    }

    return 1 if $self->wait_till_is_up($timeout);

    $self->failed_msg("failed to start server!");
    return 0;
}


# wait till the server is up and return 1
# if the waiting times out returns 0
sub wait_till_is_up {
    my($self, $timeout) = @_;
    my $config = $self->{config};
    my $sleep_interval = 1; # secs

    my $server_up = sub {
        local $SIG{__WARN__} = sub {}; #avoid "cannot connect ..." warnings
        # avoid fatal errors when LWP is not available
        my $r = eval { Apache::TestRequest::GET('/index.html') };
        return !$@ && defined $r ? $r->code : 0;
    };

    if ($server_up->()) {
        return 1;
    }

    my $start_time = time;
    my $preamble = "${CTRL_M}still waiting for server to warm up: ";
    print $preamble unless COLOR;
    while (1) {
        my $delta = time - $start_time;
        print COLOR
            ? ($preamble, sprintf "%02d:%02d", (gmtime $delta)[1,0])
            : '.';
        sleep $sleep_interval;
        if ($server_up->()) {
            print "${CTRL_M}the server is up (waited $delta secs)             \n";
            return 1;
        }
        elsif ($delta > $timeout) {
            print "${CTRL_M}the server is down, giving up after $delta secs\n";
            return 0;
        }
        else {
            # continue
        }
    }
}

1;