testconfig.pm

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

    }
}

sub configure_httpd {
    my $self = shift;
    my $vars = $self->{vars};

    debug "configuring httpd";

    $vars->{target} ||= (WIN32 ? 'Apache.EXE' : 'httpd');

    unless ($vars->{httpd}) {
        #sbindir should be bin/ with the default layout
        #but its eaiser to workaround apxs than fix apxs
        for my $dir (map { $vars->{$_} } qw(sbindir bindir)) {
            next unless defined $dir;
            my $httpd = catfile $dir, $vars->{target};
            next unless -x $httpd;
            $vars->{httpd} = $httpd;
            last;
        }

        $vars->{httpd} ||= $self->default_httpd;
    }

    if ($vars->{httpd}) {
        my @chunks = splitdir $vars->{httpd};
        #handle both $prefix/bin/httpd and $prefix/Apache.exe
        for (1,2) {
            pop @chunks;
            last unless @chunks;
            $self->{httpd_basedir} = catfile @chunks;
            last if -d "$self->{httpd_basedir}/bin";
        }
    }

    #cleanup httpd droppings
    my $sem = catfile $vars->{t_logs}, 'apache_runtime_status.sem';
    unless (-e $sem) {
        $self->clean_add_file($sem);
    }
}

sub configure_httpd_eapi {
    my $self = shift;
    my $vars = $self->{vars};

    #deal with EAPI_MM_CORE_PATH if defined.
    if (defined($self->{httpd_defines}->{EAPI_MM_CORE_PATH})) {
        my $path = $self->{httpd_defines}->{EAPI_MM_CORE_PATH};

        #ensure the directory exists
        my @chunks = splitdir $path;
        pop @chunks; #the file component of the path
        $path = catdir @chunks;
        unless (file_name_is_absolute $path) {
            $path = catdir $vars->{serverroot}, $path;
        }
        $self->gendir($path);
    }
}

sub configure_proxy {
    my $self = shift;
    my $vars = $self->{vars};

    #if we proxy to ourselves, must bump the maxclients
    if ($vars->{proxy} =~ /^on$/i) {
        unless ($vars->{maxclients_preset}) {
            $vars->{minclients}++;
            $vars->{maxclients}++;
        }
        $vars->{proxy} = $self->{vhosts}->{'mod_proxy'}->{hostport};
        return $vars->{proxy};
    }

    return undef;
}

# adds the config to the head of the group instead of the tail
# XXX: would be even better to add to a different sub-group
# (e.g. preamble_first) of only those that want to be first and then,
# make sure that they are dumped to the config file first in the same
# group (e.g. preamble)
sub add_config_first {
    my $self = shift;
    my $where = shift;
    unshift @{ $self->{$where} }, $self->massage_config_args(@_);
}

sub add_config_last {
    my $self = shift;
    my $where = shift;
    push @{ $self->{$where} }, $self->massage_config_args(@_);
}

sub massage_config_args {
    my $self = shift;
    my($directive, $arg, $data) = @_;
    my $args = "";

    if ($data) {
        $args = "<$directive $arg>\n";
        if (ref($data) eq 'HASH') {
            while (my($k,$v) = each %$data) {
                $args .= "    $k $v\n";
            }
        }
        elsif (ref($data) eq 'ARRAY') {
            # balanced (key=>val) list
            my $pairs = @$data / 2;
            for my $i (0..($pairs-1)) {
                $args .= sprintf "    %s %s\n", $data->[$i*2], $data->[$i*2+1];
            }
        }
        else {
            $args .= "    $data";
        }
        $args .= "</$directive>\n";
    }
    elsif (ref($directive) eq 'ARRAY') {
        $args = join "\n", @$directive;
    }
    else {
        $args = join " ", grep length($_), $directive,
          (ref($arg) && (ref($arg) eq 'ARRAY') ? "@$arg" : $arg || "");
    }

    return $args;
}

sub postamble_first {
    shift->add_config_first(postamble => @_);
}

sub postamble {
    shift->add_config_last(postamble => @_);
}

sub preamble_first {
    shift->add_config_first(preamble => @_);
}

sub preamble {
    shift->add_config_last(preamble => @_);
}

sub postamble_register {
    push @{ shift->{postamble_hooks} }, @_;
}

sub preamble_register {
    push @{ shift->{preamble_hooks} }, @_;
}

sub add_config_hooks_run {
    my($self, $where, $out) = @_;

    for (@{ $self->{"${where}_hooks"} }) {
        if ((ref($_) and ref($_) eq 'CODE') or $self->can($_)) {
            $self->$_();
        }
        else {
            error "cannot run configure hook: `$_'";
        }
    }

    for (@{ $self->{$where} }) {
        $self->replace;
        print $out "$_\n";
    }
}

sub postamble_run {
    shift->add_config_hooks_run(postamble => @_);
}

sub preamble_run {
    shift->add_config_hooks_run(preamble => @_);
}

sub default_group {
    return if WINFU;

    my $gid = $);

    #use only first value if $) contains more than one
    $gid =~ s/^(\d+).*$/$1/;

    my $group = $ENV{APACHE_TEST_GROUP} || (getgrgid($gid) || "#$gid");

    if ($group eq 'root') {
        # similar to default_user, we want to avoid perms problems,
        # when the server is started with group 'root'. When running
        # under group root it may fail to create dirs and files,
        # writable only by user
        my $user = default_user();
        my $gid = $user ? (getpwnam($user))[3] : '';
        $group = (getgrgid($gid) || "#$gid") if $gid;
    }

    $group;
}

sub default_user {
    return if WINFU;

    my $uid = $>;

    my $user = $ENV{APACHE_TEST_USER} || (getpwuid($uid) || "#$uid");

    if ($user eq 'root') {
        my $other = (getpwnam('nobody'))[0];
        if ($other) {
            $user = $other;
        }
        else {
            die "cannot run tests as User root";
            #XXX: prompt for another username
        }
    }

    $user;
}

sub default_serveradmin {
    my $vars = shift->{vars};
    join '@', ($vars->{user} || 'unknown'), $vars->{servername};
}

sub default_apxs {
    my $self = shift;

    return $self->{vars}->{apxs} if $self->{vars}->{apxs};

    if (my $build_config = $self->modperl_build_config()) {
        return $build_config->{MP_APXS};
    }

    $ENV{APACHE_TEST_APXS};
}

sub default_httpd {
    my $self = shift;

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

    if (my $build_config = $self->modperl_build_config()) {
        if (my $p = $build_config->{MP_AP_PREFIX}) {
            for my $bindir (qw(bin sbin)) {
                my $httpd = catfile $p, $bindir, $vars->{target};
                return $httpd if -e $httpd;
            }
        }
    }

    $ENV{APACHE_TEST_HTTPD};
}

my $localhost;

sub default_localhost {
    my $localhost_addr = pack('C4', 127, 0, 0, 1);
    gethostbyaddr($localhost_addr, Socket::AF_INET()) || 'localhost';
}

sub default_servername {
    my $self = shift;
    $localhost ||= $self->default_localhost;
    die "Can't figure out the default localhost's server name"
        unless $localhost;
}

# memoize the selected value (so we make sure that the same port is used
# via select). The problem is that select_first_port() is called 3 times after
# -clean, and it's possible that a lower port will get released
# between calls, leading to various places in the test suite getting a
# different base port selection.
#
# XXX: There is still a problem if two t/TEST's configure at the same
# time, so they both see the same port free, but only the first one to
# bind() will actually get the port. So there is a need in another
# check and reconfiguration just before the server starts.
#
my $port_memoized;
sub select_first_port {
    my $self = shift;

    my $port ||= $port_memoized || $ENV{APACHE_TEST_PORT} 
        || $self->{vars}{port} || DEFAULT_PORT;

    # memoize
    $port_memoized = $port;

    return $port unless $port eq 'select';

    # port select mode: try to find another available port, take into
    # account that each instance of the test suite may use more than
    # one port for virtual hosts, therefore try to check ports in big
    # steps (20?).
    my $step  = 20;
    my $tries = 20;
    $port = DEFAULT_PORT;
    until (Apache::TestServer->port_available($port)) {
        unless (--$tries) {
            error "no ports available";
            error "tried ports @{[DEFAULT_PORT]} - $port in $step increments";
            return 0;
        }
        $port += $step;
    }

    info "the default base port is used, using base port $port instead"
        unless $port == DEFAULT_PORT;

    # memoize
    $port_memoized = $port;

    return $port;
}

my $remote_addr;

sub our_remote_addr {
    my $self = shift;
    my $name = $self->default_servername;
    my $iaddr = (gethostbyname($name))[-1];
    unless (defined $iaddr) {
        error "Can't resolve host: '$name' (check /etc/hosts)";
        exit 1;
    }
    $remote_addr ||= Socket::inet_ntoa($iaddr);
}

sub default_loopback {
    '127.0.0.1';
}

sub port {
    my($self, $module) = @_;

    unless ($module) {
        my $vars = $self->{vars};
        return $self->select_first_port() unless $vars->{scheme} eq 'https';
        $module = $vars->{ssl_module_name};
    }
    return $self->{vhosts}->{$module}->{port};
}

sub hostport {
    my $self = shift;
    my $vars = shift || $self->{vars};
    my $module = shift || '';

    my $name = $vars->{servername};

    join ':', $name , $self->port($module || '');
}

#look for mod_foo.so
sub find_apache_module {
    my($self, $module) = @_;

    die "find_apache_module: module name argument is required"
        unless $module;

    my $vars = $self->{vars};
    my $sroot = $vars->{serverroot};

    my @trys = grep { $_ }
      ($vars->{src_dir},
       $self->apxs('LIBEXECDIR'),
       catfile($sroot, 'modules'),
       catfile($sroot, 'libexec'));

    for (@trys) {
        my $file = catfile $_, $module;
        if (-e $file) {
            debug "found $module => $file";
            return $file;
        }
    }

    # if the module wasn't found try to lookup in the list of modules
    # inherited from the system-wide httpd.conf
    my $name = $module;
    $name =~ s/\.s[ol]$/.c/;  #mod_info.so => mod_info.c
    $name =~ s/^lib/mod_/; #libphp4.so => mod_php4.c
    return $self->{modules}->{$name} if $self->{modules}->{$name};

}

#generate files and directories

my %warn_style = (
    html    => sub { "<!-- @_ -->" },
    c       => sub { "/* @_ */" },
    default => sub { join '', grep {s/^/\# /gm} @_ },
);

my %file_ext = (
    map({$_ => 'html'} qw(htm html)),
    map({$_ => 'c'   } qw(c h)),
);

# return the passed file's extension or '' if there is no one
# note: that '/foo/bar.conf.in' returns an extension: 'conf.in';
# note: a hidden file .foo will be recognized as an extension 'foo'
sub filename_ext {
    my ($self, $filename) = @_;
    my $ext = (File::Basename::fileparse($filename, '\..*'))[2] || '';
    $ext =~ s/^\.(.*)/lc $1/e;
    $ext;
}

sub warn_style_sub_ref {
    my ($self, $filename) = @_;
    my $ext = $self->filename_ext($filename);
    return $warn_style{ $file_ext{$ext} || 'default' };
}

sub genwarning {
    my($self, $filename, $from_filename) = @_;
    return unless $filename;
    my $warning = "WARNING: this file is generated";
    $warning .= " (from $from_filename)" if defined $from_filename;
    $warning .= ", do not edit\n";
    $warning .= calls_trace();
    return $self->warn_style_sub_ref($filename)->($warning);
}

sub calls_trace {
    my $frame = 1;
    my $trace = '';

    while (1) {
        my($package, $filename, $line) = caller($frame);
        last unless $filename;
        $trace .= sprintf "%02d: %s:%d\n", $frame, $filename, $line;
        $frame++;
    }

    return $trace;
}

sub clean_add_file {
    my($self, $file) = @_;

    $self->{clean}->{files}->{ rel2abs($file) } = 1;
}

sub clean_add_path {
    my($self, $path) = @_;

    $path = rel2abs($path);

    # remember which dirs were created and should be cleaned up
    while (1) {
        $self->{clean}->{dirs}->{$path} = 1;
        $path = dirname $path;
        last if -e $path;
    }
}