testsmoke.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::TestSmoke;

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

use Apache::Test ();
use Apache::TestConfig ();
use Apache::TestTrace;

use Apache::TestHarness ();
use Apache::TestRun (); # for core scan functions

use Getopt::Long qw(GetOptions);
use File::Spec::Functions qw(catfile);
use FindBin;
use POSIX ();
use Symbol ();

#use constant DEBUG => 1;

# how many times to run all tests at the first iteration
use constant DEFAULT_TIMES  => 10;

# how many various seeds to try in NONSTOP mode
use constant DEFAULT_ITERATIONS  => 10;

# if after this number of tries to reduce the number of tests fails we
# give up on more tries
use constant MAX_REDUCTION_TRIES => 50;

my @num_opts  = qw(times iterations);
my @string_opts  = qw(order report);
my @flag_opts = qw(help verbose bug_mode);

my %order = map {$_ => 1} qw(random repeat rotate);

my %usage = (
   'iterations=N'    => 'number of random iterations to run' .
                        ' (default: ' . DEFAULT_ITERATIONS . ')',
   'times=N'         => 'try to repeat all tests at most N times' .
                        ' (default: ' . DEFAULT_TIMES . ')',
   'order=MODE'      => 'modes: random, repeat, rotate' .
                        ' (default: random)',
   'report=FILENAME' => 'save report in a filename' .
                        ' (default: smoke-report-<date>.txt)',
   'verbose[=1]'     => 'verbose output' .
                        ' (default: 0)',
   'bug_mode'        => 'bug report mode' .
                        ' (default: 0)',
);

sub new {
    my($class, @argv) = @_;

    my $self = bless {
        seen    => {}, # seen sequences and tried them md5 hash
        results => {}, # final reduced sequences md5 hash
        smoking_completed         => 0,
        tests                     => [],
        total_iterations          => 0,
        total_reduction_attempts  => 0,
        total_reduction_successes => 0,
        total_tests_run           => 0,
    }, ref($class)||$class;

    $self->{test_config} = Apache::TestConfig->thaw;

    $self->getopts(\@argv);
    my $opts = $self->{opts};

    chdir "$FindBin::Bin/..";

    $self->{times}   = $opts->{times}   || DEFAULT_TIMES;
    $self->{order}   = $opts->{order}   || 'random';
    $self->{verbose} = $opts->{verbose} || 0;

    # unless specifically asked to, it doesn't make sense to run a
    # known sequence more than once
    $self->{run_iter} = $opts->{iterations} || DEFAULT_ITERATIONS;
    if ($self->{order} ne 'random' and !$opts->{iterations}) {
        error "forcing only one iteration for non-random order";
        $self->{run_iter} = 1;
    }

    # this is like 'make test' but produces an output to be used in
    # the bug report
    if ($opts->{bug_mode}) {
        $self->{bug_mode} = 1;
        $self->{run_iter} = 1;
        $self->{times}    = 1;
        $self->{verbose}  = 1;
        $self->{order}    = 'rotate';
        $self->{trace}    = 'debug';
    }

    # specific tests end up in $self->{tests} and $self->{subtests};
    # and get removed from $self->{argv}
    $self->Apache::TestRun::split_test_args();

    my $test_opts = {
        #verbose  => $self->{verbose},
        tests    => $self->{tests},
        times    => $self->{times},
        order    => $self->{order},
        subtests => $self->{subtests} || [],
    };

    @{ $self->{tests} } = $self->get_tests($test_opts);

    $self->{base_command} = "$^X $FindBin::Bin/TEST";

    # options common to all
    $self->{base_command} .= " -verbose" if $self->{verbose};

    # options specific to the startup
    $self->{start_command} = "$self->{base_command} -start";
    $self->{start_command} .= " -trace=" . $self->{trace} if $self->{trace};

    # options specific to the run
    $self->{run_command} = "$self->{base_command} -run";

    # options specific to the stop
    $self->{stop_command} = "$self->{base_command} -stop";

    $self;
}

sub getopts {
    my($self, $argv) = @_;
    my %opts;
    local *ARGV = $argv;

    # permute      : optional values can come before the options
    # pass_through : all unknown things are to be left in @ARGV
    Getopt::Long::Configure(qw(pass_through permute));

    # grab from @ARGV only the options that we expect
    GetOptions(\%opts, @flag_opts,
               (map "$_=s", @string_opts),
               (map "$_=i", @num_opts));

    if (exists $opts{order}  && !exists $order{$opts{order}}) {
        error "unknown -order mode: $opts{order}";
        $self->opt_help();
        exit;
    }

    if ($opts{help}) {
        $self->opt_help;
        exit;
    }

    # min
    $self->{opts} = \%opts;

    $self->{argv} = [@ARGV];
}

# XXX: need proper sub-classing
# from Apache::TestHarness
sub skip      { Apache::TestHarness::skip(@_); }
sub prune     { Apache::TestHarness::prune(@_); }
sub get_tests { Apache::TestHarness::get_tests(@_);}

sub install_sighandlers {
    my $self = shift;

    $SIG{INT} = sub {
        # make sure that there the server is down
        $self->kill_proc();

        $self->report_finish;
        exit;
    };
}

END {
    local $?; # preserve the exit status
    eval {
        Apache::TestRun->new(test_config =>
                             Apache::TestConfig->thaw)->scan_core;
    };
}

sub run {
    my($self) = shift;

    $self->Apache::TestRun::warn_core();
    local $SIG{INT};
    $self->install_sighandlers;

    $self->report_start();

    if ($self->{bug_mode}) {
        # 'make test', but useful for bug reports
        $self->run_bug_mode();
    }
    else {
         # normal smoke
        my $iter = 0;
        while ($iter++ < $self->{run_iter}) {
            my $last = $self->run_iter($iter);
            last if $last;
        }
    }
    $self->{smoking_completed} = 1;
    $self->report_finish();
    exit;
}

sub sep {
    my($char, $title) = @_;
    my $width = 60;
    if ($title) {
        my $side = int( ($width - length($title) - 2) / 2);
        my $pad  = ($side+1) * 2 + length($title) < $width ? 1 : 0;
        return $char x $side . " $title " . $char x ($side+$pad);
    }
    else {
        return $char x $width;
    }
}

my %log_files = ();
use constant FH  => 0;
use constant POS => 1;
sub logs_init {
    my($self, @log_files) = @_;

    for my $path (@log_files) {
        my $fh = Symbol::gensym();
        open $fh, "<$path" or die "Can't open $path: $!";
        seek $fh, 0, POSIX::SEEK_END();
        $log_files{$path}[FH]  = $fh;
        $log_files{$path}[POS] = tell $fh;
    }
}

sub logs_end {
    for my $path (keys %log_files) {
        close $log_files{$path}[FH];
    }
}

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

    my $log = $log_files{$path};
    die "no such log file: $path" unless $log;

    my $fh = $log->[FH];
    # no checkpoints were made yet?
    unless (defined $log->[POS]) {
        seek $fh, 0, POSIX::SEEK_END();
        $log->[POS] = tell $fh;
        return '';
    }

    seek $fh, $log->[POS], POSIX::SEEK_SET(); # not really needed
    local $/; # slurp mode
    my $diff = <$fh>;
    seek $fh, 0, POSIX::SEEK_END(); # not really needed
    $log->[POS] = tell $fh;

    return $diff || '';
}

# this is a special mode, which really just runs 't/TEST -start;
# t/TEST -run; t/TEST -stop;' but it runs '-run' separately for each
# test, and checks whether anything bad has happened after the run 
# of each test (i.e. either a test has failed, or a test may be successful,
# but server may have dumped a core file, we detect that).
sub run_bug_mode {
    my($self) = @_;

    my $iter = 0;

    warning "running t/TEST in the bug report mode";

    my $reduce_iter = 0;
    my @good = ();

    # first time run all tests, or all specified tests
    my @tests = @{ $self->{tests} }; # copy
    my $bad = $self->run_test($iter, $reduce_iter, \@tests, \@good);
    $self->{total_iterations}++;

}


# returns true if for some reason no more iterations should be made
sub run_iter {
    my($self, $iter) = @_;

    my $stop_now = 0;
    my $reduce_iter = 0;
    my @good = ();
    warning "\n" . sep("-");
    warning sprintf "[%03d-%02d-%02d] trying all tests %d time%s",
        $iter, $reduce_iter, 0, $self->{times},
        ($self->{times} > 1 ? "s" : "");

    # first time run all tests, or all specified tests
    my @tests = @{ $self->{tests} }; # copy 
    my $bad = $self->run_test($iter, $reduce_iter, \@tests, \@good);
    unless ($bad) {
        $self->{total_iterations}++;
        return $stop_now;
    }
    error "recorded a positive failure ('$bad'), " .
        "will try to minimize the input now";

    my $command = $self->{base_command};

    # does the test fail on its own
    {
        $reduce_iter++;
        warning sprintf "[%03d-%02d-%02d] trying '$bad' on its own",
            $iter, $reduce_iter, 1;
        my @good = ();
        my @tests = ($bad);
        my $bad = $self->run_test($iter, $reduce_iter, \@tests, \@good);
        # if a test is failing on its own there is no point to
        # continue looking for other sequences
        if ($bad) {
            $stop_now = 1;
            $self->{total_iterations}++;
            unless ($self->sequence_seen($self->{results}, [@good, $bad])) {
                $self->report_success($iter, $reduce_iter, "$command $bad", 1);
            }
            return $stop_now;
        }
    }

    # positive failure
    my $ok_tests = @good;
    my $reduction_success = 0;
    my $done = 0;
    while (@good > 1) {
        my $tries = 0;
        my $reduce_sub = $self->reduce_stream(\@good);
        $reduce_iter++;
        while ($tries++ < MAX_REDUCTION_TRIES) {
            $self->{total_reduction_attempts}++;
            my @try = @{ $reduce_sub->() };

            # reduction stream is empty (tried all?)
            unless (@try) {
                $done = 1;
                last;
            }

            warning sprintf "\n[%03d-%02d-%02d] trying %d tests",
                $iter, $reduce_iter, $tries, scalar(@try);
            my @ok = ();
            my @tests = (@try, $bad);
            my $new_bad = $self->run_test($iter, $reduce_iter, \@tests, \@ok);
            if ($new_bad) {
                # successful reduction
                $reduction_success++;
                @good = @ok;
                $tries = 0;
                my $num = @ok;
                error "*** reduction $reduce_iter succeeded ($num tests) ***";
                $self->{total_reduction_successes}++;
                $self->log_successful_reduction($iter, \@ok);
                last;
            }
        }

        # last round of reducing has failed, so we give up
        if ($done || $tries >= MAX_REDUCTION_TRIES){
            error "no further reductions were made";
            $done = 1;
            last;
        }

    }

    # we have a minimal failure sequence at this point (to the extend
    # of success of our attempts to reduce)

    # report the sequence if we didn't see such one yet in the
    # previous iterations
    unless ($self->sequence_seen($self->{results}, [@good, $bad])) {
        # if no reduction succeeded, it's 0
        $reduce_iter = 0 unless $reduction_success;
        $self->report_success($iter, $reduce_iter,
                              "$command @good $bad", @good + 1);
    }

    $self->{total_iterations}++;

    return $stop_now;
}

# my $sub = $self->reduce_stream(\@items);
sub reduce_stream {
    my($self) = shift;
    my @items = @{+shift};

    my $items = @items;
    my $odd   = $items % 2 ? 1 : 0;
    my $middle = int($items/2) - 1;
    my $c = 0;

    return sub {
        $c++; # remember stream's state 

        # a single item is not reduce-able
        return \@items if $items == 1;

        my @try = ();
        my $max_repeat_tries = 50; # avoid seen sequences
        my $repeat = 0;
        while ($repeat++ <= $max_repeat_tries) {

            # try to use a binary search
            if ($c == 1) {
                # right half
                @try = @items[($middle+1)..($items-1)];
            }
            elsif ($c == 2) {
                # left half
                @try = @items[0..$middle];
            }

            # try to use a random window size alg
            else {
                my $left = int rand($items);
                $left = $items - 1 if $left == $items - 1;
                my $right = $left + int rand($items - $left);
                $right = $items - 1 if $right >= $items;
                @try = @items[$left..$right];
            }

            if ($self->sequence_seen($self->{seen}, \@try)) {
                @try = ();
            }
            else {
                last; # found an unseen sequence
            }
        }
        return \@try;
    }
}

sub sequence_seen {
    my ($self, $rh_store, $ra_tests) = @_;

    require Digest::MD5;
    my $digest = Digest::MD5::md5_hex(join '', @$ra_tests);
    #error $self->{seen};
    return $rh_store->{$digest}++ ? 1 : 0

}

sub run_test {
    require IPC::Run3;
    my($self, $iter, $count, $tests, $ra_ok) = @_;
    my $bad = '';
    my $ra_nok = [];