testconfigperl.pm

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

    my %directives;

    while (<$fh>) {
        last if /^\#endif/; #for .c modules
        next unless /\S+/;
        chomp;
        s/^\s+//;
        $self->replace;
        if (/^#/) {
            # preserve comments
            $self->postamble($_);
            next;
        }
        my($directive, $rest) = split /\s+/, $_, 2;
        $directives{$directive}++ unless $directive =~ /^</;
        $rest = '' unless defined $rest;

        if ($outside_container{$directive}) {
            $self->postamble($directive => $rest);
        }
        elsif ($directive =~ /IfModule/) {
            $self->postamble($_);
        }
        elsif ($directive =~ m/^<(\w+)/) {
            # strip special container directives like <Base> and </Base>
            my $strip_container = exists $strip_tags{lc $1} ? 1 : 0;

            $directives{noautoconfig}++ if lc($1) eq 'noautoconfig';

            my $indent = '';
            $self->process_container($_, $fh, lc($1),
                                     $strip_container, $indent);
        }
        else {
            push @$args, $directive, $rest;
        }
    }

    \%directives;
}


# recursively process the directives including nested containers,
# re-indent 4 and ucfirst the closing tags letter
sub process_container {
    my($self, $first_line, $fh, $directive, $strip_container, $indent) = @_;

    my $new_indent = $indent;

    unless ($strip_container) {
        $new_indent .= "    ";

        local $_ = $first_line;
        s/^\s*//;
        $self->replace;

        if (/<VirtualHost/) {
            $self->process_vhost_open_tag($_, $indent);
        }
        else {
            $self->postamble($indent . $_);
        }
    }

    $self->process_container_remainder($fh, $directive, $new_indent);

    unless ($strip_container) {
        $self->postamble($indent . "</\u$directive>");
    }

}


# processes the body of the container without the last line, including
# the end tag
sub process_container_remainder {
    my($self, $fh, $directive, $indent) = @_;

    my $end_tag = "</$directive>";

    while (<$fh>) {
        chomp;
        last if m|^\s*\Q$end_tag|i;
        s/^\s*//;
        $self->replace;

        if (m/^\s*<(\w+)/) {
            $self->process_container($_, $fh, $1, 0, $indent);
        }
        else {
            $self->postamble($indent . $_);
        }
    }
}

# does the necessary processing to create a vhost container header
sub process_vhost_open_tag {
    my($self, $line, $indent) = @_;

    my $cfg = $self->parse_vhost($line);

    if ($cfg) {
        my $port = $cfg->{port};
        $cfg->{out_postamble}->();
        $self->postamble($cfg->{line});
        $cfg->{in_postamble}->();
    } else {
        $self->postamble("$indent$line");
    }
}

#the idea for each group:
# Response: there will be many of these, mostly modules to test the API
#           that plan tests => ... and output with ok()
#           the naming allows grouping, making it easier to run an
#           individual set of tests, e.g. t/TEST t/apr
#           the PerlResponseHandler and SetHandler modperl is auto-configured
# Hooks:    for testing the simpler Perl*Handlers
#           auto-generates the Perl*Handler config
# Protocol: protocol modules need their own port/vhost to listen on

#@INC is auto-modified so each test .pm can be found
#modules can add their own configuration using __DATA__

my %hooks = map { $_, ucfirst $_ }
    qw(init trans headerparser access authen authz type fixup log);
$hooks{Protocol} = 'ProcessConnection';
$hooks{Filter}   = 'OutputFilter';

my @extra_subdirs = qw(Response Protocol PreConnection Hooks Filter);

# add the subdirs to @INC early, in case mod_perl is started earlier
sub configure_pm_tests_inc {
    my $self = shift;
    for my $subdir (@extra_subdirs) {
        my $dir = catfile $self->{vars}->{t_dir}, lc $subdir;
        next unless -d $dir;

        push @{ $self->{inc} }, $dir;
    }
}

# @status fields
use constant APACHE_TEST_CONFIGURE    => 0;
use constant APACHE_TEST_CONFIG_ORDER => 1;

sub configure_pm_tests_pick {
    my($self, $entries) = @_;

    for my $subdir (@extra_subdirs) {
        my $dir = catfile $self->{vars}->{t_dir}, lc $subdir;
        next unless -d $dir;

        finddepth(sub {
            return unless /\.pm$/;

            my $file = catfile $File::Find::dir, $_;
            my $module = abs2rel $file, $dir;
            my $status = $self->run_apache_test_config_scan($file);
            push @$entries, [$file, $module, $subdir, $status];
        }, $dir);
    }
}


# a simple numerical order is performed and configuration sections are
# inserted using that order. If the test package specifies no special
# token that matches /APACHE_TEST_CONFIG_ORDER\s+([+-]?\d+)/ anywhere
# in the file, 0 is assigned as its order. If the token is specified,
# config section with negative values will be inserted first, with
# positive last. By using different values you can arrange for the
# test configuration sections to be inserted in any desired order
sub configure_pm_tests_sort {
    my($self, $entries) = @_;

    @$entries = sort {
        $a->[3]->[APACHE_TEST_CONFIG_ORDER] <=>
        $b->[3]->[APACHE_TEST_CONFIG_ORDER]
    } @$entries;

}

sub configure_pm_tests {
    my $self = shift;

    my @entries = ();
    $self->configure_pm_tests_pick(\@entries);
    $self->configure_pm_tests_sort(\@entries);

    for my $entry (@entries) {
        my ($file, $module, $subdir, $status) = @$entry;
        my @args = ();

        my $directives = $self->add_module_config($file, \@args);
        $module =~ s,\.pm$,,;
        $module =~ s/^[a-z]://i; #strip drive if any
        $module = join '::', splitdir $module;

        $self->run_apache_test_configure($file, $module, $status);

        my @base =
            map { s/^test//i; $_ } split '::', $module;

        my $sub = pop @base;

        my $hook = ($subdir eq 'Hooks' ? $hooks{$sub} : '')
            || $hooks{$subdir} || $subdir;

        if ($hook eq 'OutputFilter' and $module =~ /::i\w+$/) {
            #XXX: tmp hack
            $hook = 'InputFilter';
        }

        my $handler = join $hook, qw(Perl Handler);

        if ($self->server->{rev} < 2 and lc($hook) eq 'response') {
            $handler =~ s/response//i; #s/PerlResponseHandler/PerlHandler/
        }

        debug "configuring $module";

        if ($directives->{noautoconfig}) {
            $self->postamble(""); # which adds "\n"
        }
        else {
            if (my $cv = $add_hook_config{$hook}) {
                $self->$cv($module, \@args);
            }

            my $container = $container_config{$hook} || \&location_container;

            #unless the .pm test already configured the Perl*Handler
            unless ($directives->{$handler}) {
                my @handler_cfg = ($handler => $module);

                if ($outside_container{$handler}) {
                    $self->postamble(@handler_cfg);
                } else {
                    push @args, @handler_cfg;
                }
            }

            $self->postamble($self->$container($module), \@args) if @args;
        }

        $self->write_pm_test($module, lc $sub, map { lc } @base);
    }
}

# scan tests for interesting information
sub run_apache_test_config_scan {
    my ($self, $file) = @_;

    my @status = ();
    $status[APACHE_TEST_CONFIGURE]    = 0;
    $status[APACHE_TEST_CONFIG_ORDER] = 0;

    my $fh = Symbol::gensym();
    if (open $fh, $file) {
        local $/;
        my $content = <$fh>;
        close $fh;
        # XXX: optimize to match once?
        if ($content =~ /APACHE_TEST_CONFIGURE/m) {
            $status[APACHE_TEST_CONFIGURE] = 1;
        }
        if ($content =~ /APACHE_TEST_CONFIG_ORDER\s+([+-]?\d+)/m) {
            $status[APACHE_TEST_CONFIG_ORDER] = int $1;
        }
    }
    else {
        error "cannot open $file: $!";
    }

    return \@status;
}

# We have to test whether tests have APACHE_TEST_CONFIGURE() in them
# and run it if found at this stage, so when the server starts
# everything is ready.
# XXX: however we cannot use a simple require() because some tests
# won't require() outside of mod_perl environment. Therefore we scan
# the slurped file in.  and if APACHE_TEST_CONFIGURE has been found we
# require the file and run this function.
sub run_apache_test_configure {
    my ($self, $file, $module, $status) = @_;

    return unless $status->[APACHE_TEST_CONFIGURE];

    eval { require $file };
    warn $@ if $@;
    # double check that it's a real sub
    if ($module->can('APACHE_TEST_CONFIGURE')) {
        eval { $module->APACHE_TEST_CONFIGURE($self); };
        warn $@ if $@;
    }
}


1;