testconfig.pm

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

sub genfile_trace {
    my($self, $file, $from_file) = @_;
    my $name = abs2rel $file, $self->{vars}->{t_dir};
    my $msg = "generating $name";
    $msg .= " from $from_file" if defined $from_file;
    debug $msg;
}

sub genfile_warning {
    my($self, $file, $from_file, $fh) = @_;

    if (my $msg = $self->genwarning($file, $from_file)) {
        print $fh $msg, "\n";
    }
}

# $from_file == undef if there was no templates used
sub genfile {
    my($self, $file, $from_file, $nowarning) = @_;

    # create the parent dir if it doesn't exist yet
    my $dir = dirname $file;
    $self->makepath($dir);

    $self->genfile_trace($file, $from_file);

    my $fh = Symbol::gensym();
    open $fh, ">$file" or die "open $file: $!";

    $self->genfile_warning($file, $from_file, $fh) unless $nowarning;

    $self->clean_add_file($file);

    return $fh;
}

# gen + write file
sub writefile {
    my($self, $file, $content, $nowarning) = @_;

    my $fh = $self->genfile($file, undef, $nowarning);

    print $fh $content if $content;

    close $fh;
}

sub perlscript_header {

    require FindBin;

    my @dirs = ();

    # mp2 needs its modper-2.0/lib before blib was created
    if (IS_MOD_PERL_2_BUILD || $ENV{APACHE_TEST_LIVE_DEV}) {
        # the live 'lib/' dir of the distro
        # (e.g. modperl-2.0/ModPerl-Registry/lib)
        my $dir = canonpath catdir $FindBin::Bin, "lib";
        push @dirs, $dir if -d $dir;

        # the live dir of the top dir if any  (e.g. modperl-2.0/lib)
        if (-e catfile($FindBin::Bin, "..", "Makefile.PL")) {
            my $dir = canonpath catdir $FindBin::Bin, "..", "lib";
            push @dirs, $dir if -d $dir;
        }
    }

    for (qw(. ..)) {
        my $dir = canonpath catdir $FindBin::Bin, $_ , "Apache-Test", "lib";
        if (-d $dir) {
            push @dirs, $dir;
            last;
        }
    }

    {
        my $dir = canonpath catdir $FindBin::Bin, "t", "lib";
        push @dirs, $dir if -d $dir;
    }

    my $dirs = join("\n    ", '', @dirs) . "\n";;

    return <<"EOF";

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

use lib qw($dirs);

EOF
}

# gen + write executable perl script file
sub write_perlscript {
    my($self, $file, $content) = @_;

    my $fh = $self->genfile($file, undef, 1);

    # shebang
    print $fh "#!$Config{perlpath}\n";

    $self->genfile_warning($file, undef, $fh);

    print $fh $content if $content;

    close $fh;
    chmod 0755, $file;
}

sub cpfile {
    my($self, $from, $to) = @_;
    File::Copy::copy($from, $to);
    $self->clean_add_file($to);
}

sub symlink {
    my($self, $from, $to) = @_;
    CORE::symlink($from, $to);
    $self->clean_add_file($to);
}

sub gendir {
    my($self, $dir) = @_;
    $self->makepath($dir);
}

# returns a list of dirs successfully created
sub makepath {
    my($self, $path) = @_;

    return if !defined($path) || -e $path;

    $self->clean_add_path($path);

    return File::Path::mkpath($path, 0, 0755);
}

sub open_cmd {
    my($self, $cmd) = @_;
    # untaint some %ENV fields
    local @ENV{ qw(IFS CDPATH ENV BASH_ENV) };
    local $ENV{PATH} = untaint_path($ENV{PATH});

    # launder for -T
    $cmd = $1 if $cmd =~ /(.*)/;

    my $handle = Symbol::gensym();
    open $handle, "$cmd|" or die "$cmd failed: $!";

    return $handle;
}

sub clean {
    my $self = shift;
    $self->{clean_level} = shift || 2; #2 == really clean, 1 == reconfigure

    $self->new_test_server->clean;
    $self->cmodules_clean;
    $self->sslca_clean;

    for (keys %{ $self->{clean}->{files} }) {
        if (-e $_) {
            debug "unlink $_";
            unlink $_;
        }
        else {
            debug "unlink $_: $!";
        }
    }

    # if /foo comes before /foo/bar, /foo will never be removed
    # hence ensure that sub-dirs are always treated before a parent dir
    for (reverse sort keys %{ $self->{clean}->{dirs} }) {
        if (-d $_) {
            my $dh = Symbol::gensym();
            opendir($dh, $_);
            my $notempty = grep { ! /^\.{1,2}$/ } readdir $dh;
            closedir $dh;
            next if $notempty;
            debug "rmdir $_";
            rmdir $_;
        }
    }
}

sub replace {
    my $self = shift;
    my $file = $Apache::TestConfig::File
        ? "in file $Apache::TestConfig::File" : '';

    s[@(\w+)@]
     [ my $key = lc $1;
      exists $self->{vars}->{$key}
      ? $self->{vars}->{$key}
      : die "invalid token: \@$1\@ $file\n";
     ]ge;
}

#need to configure the vhost port for redirects and $ENV{SERVER_PORT}
#to have the correct values
my %servername_config = (
    0 => sub {
        my($name, $port) = @_;
        [ServerName => ''], [Port => 0];
    },
    1 => sub {
        my($name, $port) = @_;
        [ServerName => $name], [Port => $port];
    },
    2 => sub {
        my($name, $port) = @_;
        [ServerName => "$name:$port"];
    },
);

sub servername_config {
    my $self = shift;
    $self->server->version_of(\%servername_config)->(@_);
}

sub parse_vhost {
    my($self, $line) = @_;

    my($indent, $module, $namebased);
    if ($line =~ /^(\s*)<VirtualHost\s+(?:_default_:|([^:]+):(?!:))?(.*?)\s*>\s*$/) {
        $indent    = $1 || "";
        $namebased = $2 || "";
        $module    = $3;
    }
    else {
        return undef;
    }

    my $vars = $self->{vars};
    my $mods = $self->{modules};
    my $have_module = "$module.c";
    my $ssl_module = $vars->{ssl_module};

    #if module ends with _ssl and it is not the module that implements ssl,
    #then assume this module is a vhost with SSLEngine On (or similar)
    #see mod_echo in extra.conf.in for example
    if ($module =~ /^(mod_\w+)_ssl$/ and $have_module ne $ssl_module) {
        $have_module = "$1.c"; #e.g. s/mod_echo_ssl.c/mod_echo.c/
        return undef unless $mods->{$ssl_module};
    }

    #don't allocate a port if this module is not configured
    #assumes the configuration is inside an <IfModule $have_module>
    if ($module =~ /^mod_/ and not $mods->{$have_module}) {
        return undef;
    }

    #allocate a port and configure this module into $self->{vhosts}
    my $port = $self->new_vhost($module, $namebased);

    #extra config that should go *inside* the <VirtualHost ...>
    my @in_config = $self->servername_config($namebased
                                                 ? $namebased
                                                 : $vars->{servername},
                                             $port);

    my @out_config = ();
    if ($self->{vhosts}->{$module}->{namebased} < 2) {
        #extra config that should go *outside* the <VirtualHost ...>
        @out_config = ([Listen => '0.0.0.0:' . $port]);

        if ($self->{vhosts}->{$module}->{namebased}) {
            push @out_config => [NameVirtualHost => "*:$port"];
        }
    }

    $self->{vars}->{$module . '_port'} = $port;

    #there are two ways of building a vhost
    #first is when we parse test .pm and .c files
    #second is when we scan *.conf.in
    my $form_postamble = sub {
        my $indent = shift;
        for my $pair (@_) {
            $self->postamble("$indent@$pair");
        }
    };

    my $form_string = sub {
        my $indent = shift;
        join "\n", map { "$indent@$_\n" } @_;
    };

    my $double_indent = $indent ? $indent x 2 : ' ' x 4;
    return {
        port          => $port,
        #used when parsing .pm and .c test modules
        in_postamble  => sub { $form_postamble->($double_indent, @in_config) },
        out_postamble => sub { $form_postamble->($indent, @out_config) },
        #used when parsing *.conf.in files
        in_string     => $form_string->($double_indent, @in_config),
        out_string    => $form_string->($indent, @out_config),
        line          => "$indent<VirtualHost " . ($namebased ? '*' : '_default_') .
                         ":$port>",
    };
}

sub find_and_load_module {
    my ($self, $name) = @_;
    my $mod_path = $self->find_apache_module($name) or return;
    my ($sym) = $name =~ m/mod_(\w+)\./;

    if ($mod_path && -e $mod_path) {
        $self->preamble(IfModule => "!mod_$sym.c",
                        qq{LoadModule ${sym}_module "$mod_path"\n});
    }
    return 1;
}

sub replace_vhost_modules {
    my $self = shift;

    if (my $cfg = $self->parse_vhost($_)) {
        $_ = '';
        for my $key (qw(out_string line in_string)) {
            next unless $cfg->{$key};
            $_ .= "$cfg->{$key}\n";
        }
    }
}

sub replace_vars {
    my($self, $in, $out) = @_;

    local $_;
    while (<$in>) {
        $self->replace;
        $self->replace_vhost_modules;
        print $out $_;
    }
}

sub index_html_template {
    my $self = shift;
    return "welcome to $self->{server}->{name}\n";
}

sub generate_index_html {
    my $self = shift;
    my $dir = $self->{vars}->{documentroot};
    $self->gendir($dir);
    my $file = catfile $dir, 'index.html';
    return if -e $file;
    my $fh = $self->genfile($file);
    print $fh $self->index_html_template;
}

sub types_config_template {
    return <<EOF;
text/html  html htm
image/gif  gif
image/jpeg jpeg jpg jpe
image/png  png
text/plain asc txt
EOF
}

sub generate_types_config {
    my $self = shift;

    # handle the case when mod_mime is built as a shared object
    # but wasn't included in the system-wide httpd.conf
    $self->find_and_load_module('mod_mime.so');

    unless ($self->{inherit_config}->{TypesConfig}) {
        my $types = catfile $self->{vars}->{t_conf}, 'mime.types';
        unless (-e $types) {
            my $fh = $self->genfile($types);
            print $fh $self->types_config_template;
            close $fh;
        }
        $self->postamble(<<EOI);
<IfModule mod_mime.c>
    TypesConfig "$types"
</IfModule>
EOI
    }
}

# various dup bugs in older perl and perlio in perl < 5.8.4 need a
# workaround to explicitly rewind the dupped DATA fh before using it
my $DATA_pos = tell DATA;
sub httpd_conf_template {
    my($self, $try) = @_;

    my $in = Symbol::gensym();
    if (open $in, $try) {
        return $in;
    }
    else {
        my $dup = Symbol::gensym();
        open $dup, "<&DATA" or die "Can't dup DATA: $!";
        seek $dup, $DATA_pos, 0; # rewind to the beginning
        return $dup; # so we don't close DATA
    }
}

#certain variables may not be available until certain config files
#are generated.  for example, we don't know the ssl port until ssl.conf.in
#is parsed.  ssl port is needed for proxyssl testing

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

    unless ($vars->{proxyssl_url}) {
        my $ssl = $self->{vhosts}->{ $vars->{ssl_module_name} };
        if ($ssl) {
            $vars->{proxyssl_url} ||= $ssl->{hostport};
        }

        if ($vars->{proxyssl_url}) {
            unless ($vars->{maxclients_preset}) {
                $vars->{minclients}++;
                $vars->{maxclients}++;
            }
        }
    }
}

sub extra_conf_files_needing_update {
    my $self = shift;

    my @need_update = ();
    finddepth(sub {
        return unless /\.in$/;
        (my $generated = $File::Find::name) =~ s/\.in$//;
        push @need_update, $generated 
            unless -e $generated && -M $generated < -M $File::Find::name;
    }, $self->{vars}->{t_conf});

    return @need_update;
}

sub generate_extra_conf {
    my $self = shift;

    my(@extra_conf, @conf_in, @conf_files);

    finddepth(sub {
        return unless /\.in$/;
        push @conf_in, catdir $File::Find::dir, $_;
    }, $self->{vars}->{t_conf});

    #make ssl port always be 8530 when available
    for my $file (@conf_in) {
        if (basename($file) =~ /^ssl/) {
            unshift @conf_files, $file;
        }
        else {
            push @conf_files, $file;
        }
    }

    for my $file (@conf_files) {
        (my $generated = $file) =~ s/\.in$//;
        debug "Will 'Include' $generated config file";
        push @extra_conf, $generated;
    }