testconfig.pm

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

    # regenerate .conf files
    for my $file (@conf_files) {
        local $Apache::TestConfig::File = $file;

        my $in = Symbol::gensym();
        open($in, $file) or next;

        (my $generated = $file) =~ s/\.in$//;
        my $out = $self->genfile($generated, $file);
        $self->replace_vars($in, $out);

        close $in;
        close $out;

        $self->check_vars;
    }

    #we changed order to give ssl the first port after DEFAULT_PORT
    #but we want extra.conf Included first so vhosts inherit base config
    #such as LimitRequest*
    return [ sort @extra_conf ];
}

sub sslca_can {
    my($self, $check) = @_;

    my $vars = $self->{vars};
    return 0 unless $self->{modules}->{ $vars->{ssl_module} };
    return 0 unless -d "$vars->{t_conf}/ssl";

    require Apache::TestSSLCA;

    if ($check) {
        my $openssl = Apache::TestSSLCA::openssl();
        if (which($openssl)) {
            return 1;
        }

        error "cannot locate '$openssl' program required to generate SSL CA";
        exit(1);
    }

    return 1;
}

sub sslca_generate {
    my $self = shift;

    my $ca = $self->{vars}->{sslca};
    return if $ca and -d $ca; #t/conf/ssl/ca

    return unless $self->sslca_can(1);

    Apache::TestSSLCA::generate($self);
}

sub sslca_clean {
    my $self = shift;

    # XXX: httpd config is required, for now just skip ssl clean if
    # there is none. should probably add some flag which will tell us
    # when httpd_config was already run
    return unless $self->{vars}->{httpd} && $self->{vars}->{ssl_module};

    return unless $self->sslca_can;

    Apache::TestSSLCA::clean($self);
}

#XXX: just a quick hack to support t/TEST -ssl
#outside of httpd-test/perl-framework
sub generate_ssl_conf {
    my $self = shift;
    my $vars = $self->{vars};
    my $conf = "$vars->{t_conf}/ssl";
    my $httpd_test_ssl = "../httpd-test/perl-framework/t/conf/ssl";
    my $ssl_conf = "$vars->{top_dir}/$httpd_test_ssl";

    if (-d $ssl_conf and not -d $conf) {
        $self->gendir($conf);
        for (qw(ssl.conf.in)) {
            $self->cpfile("$ssl_conf/$_", "$conf/$_");
        }
        for (qw(certs keys crl)) {
            $self->symlink("$ssl_conf/$_", "$conf/$_");
        }
    }
}

sub find_in_inc {
    my($self, $dir) = @_;
    for my $path (@INC) {
        my $location = "$path/$dir";
        return $location if -d $location;
    }
    return "";
}

sub prepare_t_conf {
    my $self = shift;
    $self->gendir($self->{vars}->{t_conf});
}

my %aliases = (
    "perl-pod"     => "perlpod",
    "binary-httpd" => "httpd",
    "binary-perl"  => "perl",
);
sub generate_httpd_conf {
    my $self = shift;
    my $vars = $self->{vars};

    #generated httpd.conf depends on these things to exist
    $self->generate_types_config;
    $self->generate_index_html;

    $self->gendir($vars->{t_logs});
    $self->gendir($vars->{t_conf});

    my @very_last_postamble = ();
    if (my $extra_conf = $self->generate_extra_conf) {
        for my $file (@$extra_conf) {
            my $entry;
            if ($file =~ /\.conf$/) {
                next if $file =~ m|/httpd\.conf$|;
                $entry = qq(Include "$file");
            }
            elsif ($file =~ /\.pl$/) {
                $entry = qq(<IfModule mod_perl.c>\n    PerlRequire "$file"\n</IfModule>\n);
            }
            else {
                next;
            }

            # put the .last includes very last
            if ($file =~ /\.last\.(conf|pl)$/) {
                 push @very_last_postamble, $entry;
            }
            else {
                $self->postamble($entry);
            }

        }
    }

    $self->configure_proxy;

    my $conf_file = $vars->{t_conf_file};
    my $conf_file_in = join '.', $conf_file, 'in';

    my $in = $self->httpd_conf_template($conf_file_in);

    my $out = $self->genfile($conf_file);

    $self->find_and_load_module('mod_alias.so');

    $self->preamble_run($out);

    for my $name (qw(user group)) { #win32/cygwin do not support
        if ($vars->{$name}) {
            print $out qq[\u$name    "$vars->{$name}"\n];
        }
    }

    #2.0: ServerName $ServerName:$Port
    #1.3: ServerName $ServerName
    #     Port       $Port
    my @name_cfg = $self->servername_config($vars->{servername},
                                            $vars->{port});
    for my $pair (@name_cfg) {
        print $out "@$pair\n";
    }

    $self->replace_vars($in, $out);

    # handle the case when mod_alias is built as a shared object
    # but wasn't included in the system-wide httpd.conf

    print $out "<IfModule mod_alias.c>\n";
    for (keys %aliases) {
        next unless $vars->{$aliases{$_}};
        print $out "    Alias /getfiles-$_ $vars->{$aliases{$_}}\n";
    }
    print $out "</IfModule>\n";

    print $out "\n";

    $self->postamble_run($out);

    print $out join "\n", @very_last_postamble;

    close $in;
    close $out or die "close $conf_file: $!";
}

sub need_reconfiguration {
    my($self, $conf_opts) = @_;
    my @reasons = ();
    my $vars = $self->{vars};

    # if '-port select' we need to check from scratch which ports are
    # available
    if (my $port = $conf_opts->{port} || $Apache::TestConfig::Argv{port}) {
        if ($port eq 'select') {
            push @reasons, "'-port $port' requires reconfiguration";
        }
    }

    my $exe = $vars->{apxs} || $vars->{httpd} || '';
    # if httpd.conf is older than executable
    push @reasons,
        "$exe is newer than $vars->{t_conf_file}"
            if -e $exe && 
               -e $vars->{t_conf_file} &&
               -M $exe < -M $vars->{t_conf_file};

    # any .in files are newer than their derived versions?
    if (my @files = $self->extra_conf_files_needing_update) {
        # invalidate the vhosts cache, since a different port could be
        # assigned on reparse
        $self->{vhosts} = {};
        for my $file (@files) {
            push @reasons, "$file.in is newer than $file";
        }
    }

    # if special env variables are used (since they can change any time)
    # XXX: may be we could check whether they have changed since the
    # last run and thus avoid the reconfiguration?
    {
        my $passenv = passenv();
        if (my @env_vars = grep { $ENV{$_} } keys %$passenv) {
            push @reasons, "environment variables (@env_vars) are set";
        }
    }

    return @reasons;
}

sub error_log {
    my($self, $rel) = @_;
    my $file = catfile $self->{vars}->{t_logs}, 'error_log';
    my $rfile = abs2rel $file, $self->{vars}->{top_dir};
    return wantarray ? ($file, $rfile) :
      $rel ? $rfile : $file;
}

#utils

#For Win32 systems, stores the extensions used for executable files
#They may be . prefixed, so we will strip the leading periods.

my @path_ext = ();

if (WIN32) {
    if ($ENV{PATHEXT}) {
        push @path_ext, split ';', $ENV{PATHEXT};
        for my $ext (@path_ext) {
            $ext =~ s/^\.*(.+)$/$1/;
        }
    }
    else {
        #Win9X: doesn't have PATHEXT
        push @path_ext, qw(com exe bat);
    }
}

sub which {
    my $program = shift;

    return undef unless $program;

    my @dirs = File::Spec->path();

    require Config;
    my $perl_bin = $Config::Config{bin} || '';
    push @dirs, $perl_bin if $perl_bin and -d $perl_bin;

    for my $base (map { catfile $_, $program } @dirs) {
        if ($ENV{HOME} and not WIN32) {
            # only works on Unix, but that's normal:
            # on Win32 the shell doesn't have special treatment of '~'
            $base =~ s/~/$ENV{HOME}/o;
        }

        return $base if -x $base && -f _;

        if (WIN32) {
            for my $ext (@path_ext) {
                return "$base.$ext" if -x "$base.$ext" && -f _;
            }
        }
    }
}

sub apxs {
    my($self, $q, $ok_fail) = @_;
    return unless $self->{APXS};
    my $val;
    unless (exists $self->{_apxs}{$q}) {
        local @ENV{ qw(IFS CDPATH ENV BASH_ENV) };
        local $ENV{PATH} = untaint_path($ENV{PATH});
        my $devnull = devnull();
        my $apxs = shell_ready($self->{APXS});
        $val = qx($apxs -q $q 2>$devnull);
        chomp $val if defined $val; # apxs post-2.0.40 adds a new line
        if ($val) {
            $self->{_apxs}{$q} = $val;
        }
        unless ($val) {
            if ($ok_fail) {
                return "";
            }
            else {
                warn "APXS ($self->{APXS}) query for $q failed\n";
                return $val;
            }
        }
    }
    $self->{_apxs}{$q};
}

# Temporarily untaint PATH
sub untaint_path {
    my $path = shift;
    ($path) = ( $path =~ /(.*)/ );
    # win32 uses ';' for a path separator, assume others use ':'
    my $sep = WIN32 ? ';' : ':';
    # -T disallows relative and empty directories in the PATH
    return join $sep, grep !/^(\.|$)/, split /$sep/, $path;
}

sub pop_dir {
    my $dir = shift;

    my @chunks = splitdir $dir;
    while (my $remove = shift) {
        pop @chunks if $chunks[-1] eq $remove;
    }

    catfile @chunks;
}

sub add_inc {
    my $self = shift;
    return if $ENV{MOD_PERL}; #already setup by mod_perl
    require lib;
    # make sure that Apache-Test/lib will be first in @INC,
    # followed by modperl-2.0/lib (or some other project's lib/),
    # followed by blib/ and finally system-wide libs.
    my $top_dir = $self->{vars}->{top_dir};
    my @dirs = map { catdir $top_dir, "blib", $_ } qw(lib arch);

    my $apache_test_dir = catdir $top_dir, "Apache-Test";
    unshift @dirs, $apache_test_dir if -d $apache_test_dir;

    if ($ENV{APACHE_TEST_LIVE_DEV}) {
        my $lib_dir = catdir $top_dir, "lib";
        push @dirs, $lib_dir if -d $lib_dir;
    }

    lib::->import(@dirs);
    #print join "\n", "add_inc", @INC, "";
}

#freeze/thaw so other processes can access config

sub thaw {
    my $class = shift;
    $class->new({thaw => 1, @_});
}

sub freeze {
    require Data::Dumper;
    local $Data::Dumper::Terse = 1;
    my $data = Data::Dumper::Dumper(shift);
    chomp $data;
    $data;
}

sub sync_vars {
    my $self = shift;

    return if $self->{save}; #this is not a cached config

    my $changed = 0;
    my $thaw = $self->thaw;
    my $tvars = $thaw->{vars};
    my $svars = $self->{vars};

    for my $key (@_) {
        for my $v ($tvars, $svars) {
            if (exists $v->{$key} and not defined $v->{$key}) {
                $v->{$key} = ''; #rid undef
            }
        }
        next if exists $tvars->{$key} and exists $svars->{$key} and
                       $tvars->{$key} eq $svars->{$key};
        $tvars->{$key} = $svars->{$key};
        $changed = 1;
    }

    return unless $changed;

    $thaw->{save} = 1;
    $thaw->save;
}

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

    return unless $self->{save};

    my $name = 'apache_test_config';
    my $file = catfile $self->{vars}->{t_conf}, "$name.pm";
    my $fh = $self->genfile($file);

    debug "saving config data to $name.pm";

    (my $obj = $self->freeze) =~ s/^/    /;

    print $fh <<EOF;
package $name;

sub new {
$obj;
}

1;
EOF

    close $fh or die "failed to write $file: $!";
}

sub as_string {
    my $cfg = '';
    my $command = '';

    # httpd opts
    my $test_config = Apache::TestConfig->new({thaw=>1});
    # XXX: need to run httpd config to get the value of httpd
    if (my $httpd = $test_config->{vars}->{httpd}) {
        $httpd = shell_ready($httpd);
        $command = "$httpd -V";
        $cfg .= "\n*** $command\n";
        $cfg .= qx{$command};

        $cfg .= ldd_as_string($httpd);
    } 
    else {
        $cfg .= "\n\n*** The httpd binary was not found\n";
    }

    # perl opts
    my $perl = shell_ready($^X);
    $command = "$perl -V";
    $cfg .= "\n\n*** $command\n";
    $cfg .= qx{$command};

    return $cfg;
}

sub ldd_as_string {