testserver.pm

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

# Copyright 2001-2005 The Apache Software Foundation or its licensors, as
# applicable.
#
# Licensed under the Apache License, Version 2.0 (the "License");
# you may not use this file except in compliance with the License.
# You may obtain a copy of the License at
#
#     http://www.apache.org/licenses/LICENSE-2.0
#
# Unless required by applicable law or agreed to in writing, software
# distributed under the License is distributed on an "AS IS" BASIS,
# WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
# See the License for the specific language governing permissions and
# limitations under the License.
#
package Apache::TestServer;

use strict;
use warnings FATAL => 'all';

use Config;
use Socket ();
use File::Spec::Functions qw(catfile);

use Apache::TestTrace;
use Apache::TestRun;
use Apache::TestConfig ();
use Apache::TestRequest ();

use constant COLOR => Apache::TestConfig::COLOR;
use constant WIN32 => Apache::TestConfig::WIN32;

my $CTRL_M = COLOR ? "\r" : "\n";

# some debuggers use the same syntax as others, so we reuse the same
# code by using the following mapping
my %debuggers = (
    gdb      => 'gdb',
    ddd      => 'gdb',
    valgrind => 'valgrind',
    strace   => 'strace',
);

sub new {
    my $class = shift;
    my $config = shift;

    my $self = bless {
        config => $config || Apache::TestConfig->thaw,
    }, $class;

    $self->{name} = join ':',
      map { $self->{config}->{vars}->{$_} } qw(servername port);

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

    $self;
}

# call this when you already know where httpd is
sub post_config {
    my($self) = @_;

    $self->{version} = $self->{config}->httpd_version || '';
    $self->{mpm}     = $self->{config}->httpd_mpm     || '';

    # try to get the revision number from the standard Apache version
    # string and various variations made by distributions which mangle
    # that string

    # Foo-Apache-Bar/x.y.z
    ($self->{rev}) = $self->{version} =~ m|/(\d)\.|;

    if ($self->{rev}) {
        debug "Matched Apache revision $self->{version} $self->{rev}";
    }
    else {
        # guessing is not good as it'll only mislead users
        # and we can't die since a config object is required
        # during Makefile.PL's write_perlscript when path to httpd may
        # be unknown yet. so default to non-existing version 0 for now.
        # and let TestRun.pm figure out the required pieces
        debug "can't figure out Apache revision, from string: " .
            "'$self->{version}', using a non-existing revision 0";
        $self->{rev} = 0; # unknown
    }

    $self;
}

sub version_of {
    my($self, $thing) = @_;
    die "Can't figure out what Apache server generation we are running"
        unless $self->{rev};

    $thing->{$self->{rev}};
}

my @apache_logs = qw(
error_log access_log httpd.pid
apache_runtime_status rewrite_log
ssl_engine_log ssl_request_log
cgisock
);

sub clean {
    my $self = shift;

    my $dir = $self->{config}->{vars}->{t_logs};

    for (@apache_logs) {
        my $file = catfile $dir, $_;
        if (unlink $file) {
            debug "unlink $file";
        }
    }
}

sub pid_file {
    my $self = shift;
    catfile $self->{config}->{vars}->{t_logs}, 'httpd.pid';
}

sub dversion {
    my $self = shift;
    "-D APACHE$self->{rev}";
}

sub config_defines {
    my $self = shift;

    my @defines = ();

    for my $item (qw(useithreads)) {
        next unless $Config{$item} and $Config{$item} eq 'define';
        push @defines, "-D PERL_\U$item";
    }

    if (my $defines = $self->{config}->{vars}->{defines}) {
        push @defines, map { "-D $_" } split " ", $defines;
    }

    "@defines";
}

sub args {
    my $self = shift;
    my $vars = $self->{config}->{vars};
    my $dversion = $self->dversion; #for .conf version conditionals
    my $defines = $self->config_defines;

    "-d $vars->{serverroot} -f $vars->{t_conf_file} $dversion $defines";
}

my %one_process = (1 => '-X', 2 => '-D ONE_PROCESS');

sub start_cmd {
    my $self  = shift;

    my $args   = $self->args;
    my $config = $self->{config};
    my $vars   = $config->{vars};
    my $httpd  = $vars->{httpd};

    my $one_process = $self->{run}->{opts}->{'one-process'}
        ? $self->version_of(\%one_process)
        : '';

    #XXX: threaded mpm does not respond to SIGTERM with -D ONE_PROCESS

    return "$httpd $one_process $args";
}

sub default_gdbinit {
    my $gdbinit = "";
    my @sigs = qw(PIPE);

    for my $sig (@sigs) {
        for my $flag (qw(pass nostop)) {
            $gdbinit .= "handle SIG$sig $flag\n";
        }
    }

    $gdbinit;
}

sub strace_cmd {
    my($self, $strace, $file) = @_;
    #XXX truss, ktrace, etc.
    "$strace -f -o $file -s1024";
}

sub valgrind_cmd {
    my($self, $valgrind) = @_;
    "$valgrind -v --leak-check=yes --show-reachable=yes --error-limit=no";
}

sub start_valgrind {
    my $self = shift;
    my $opts = shift;

    my $config       = $self->{config};
    my $args         = $self->args;
    my $one_process  = $self->version_of(\%one_process);
    my $valgrind_cmd = $self->valgrind_cmd($opts->{debugger});
    my $httpd        = $config->{vars}->{httpd};

    my $command = "$valgrind_cmd $httpd $one_process $args";

    debug $command;
    system $command;
}

sub start_strace {
    my $self = shift;
    my $opts = shift;

    my $config      = $self->{config};
    my $args        = $self->args;
    my $one_process = $self->version_of(\%one_process);
    my $file        = catfile $config->{vars}->{t_logs}, 'strace.log';
    my $strace_cmd  = $self->strace_cmd($opts->{debugger}, $file);
    my $httpd       = $config->{vars}->{httpd};

    $config->genfile($file); #just mark for cleanup

    my $command = "$strace_cmd $httpd $one_process $args";

    debug $command;
    system $command;
}

sub start_gdb {
    my $self = shift;
    my $opts = shift;

    my $debugger    = $opts->{debugger};
    my @breakpoints = @{ $opts->{breakpoint} || [] };
    my $config      = $self->{config};
    my $args        = $self->args;
    my $one_process = $self->version_of(\%one_process);

    my $file = catfile $config->{vars}->{serverroot}, '.gdb-test-start';
    my $fh   = $config->genfile($file);

    print $fh default_gdbinit();

    if (@breakpoints) {
        print $fh "b ap_run_pre_config\n";
        print $fh "run $one_process $args\n";
        print $fh "finish\n";
        for (@breakpoints) {
            print $fh "b $_\n"
        }
        print $fh "continue\n";
    }
    else {
        print $fh "run $one_process $args\n";
    }
    close $fh;

    my $command;
    my $httpd = $config->{vars}->{httpd};

    if ($debugger eq 'ddd') {
        $command = qq{ddd --gdb --debugger "gdb -command $file" $httpd};
    }
    else {
        $command = "gdb $httpd -command $file";
    }

    $self->note_debugging;
    debug  $command;
    system $command;

    unlink $file;
}

sub debugger_file {
    my $self = shift;
    catfile $self->{config}->{vars}->{serverroot}, '.debugging';
}

#make a note that the server is running under the debugger
#remove note when this process exits via END

sub note_debugging {
    my $self = shift;
    my $file = $self->debugger_file;
    my $fh   = $self->{config}->genfile($file);
    eval qq(END { unlink "$file" });
}

sub start_debugger {
    my $self = shift;
    my $opts = shift;

    $opts->{debugger} ||= $ENV{MP_DEBUGGER} || 'gdb';

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

    my $method = "start_" . $debuggers{ $opts->{debugger} };
    $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;