harness.pm

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

    my $iter = Parallel::Iterator::iterate(
        { workers => $self->jobs || 0 },
        sub {
            my ( $id, $test ) = @_;

            my ( $parser, $session ) = $self->make_parser($test);

            while ( defined( my $result = $parser->next ) ) {
                exit 1 if $result->is_bailout;
            }

            $self->finish_parser( $parser, $session );

            # Can't serialise coderefs...
            delete $parser->{_iter};
            delete $parser->{_stream};
            delete $parser->{_grammar};
            return $parser;
        },
        \@tests
    );

    while ( my ( $id, $parser ) = $iter->() ) {
        $self->_after_test( $aggregate, $tests[$id], $parser );
    }

    return;
}

sub _aggregate_parallel {
    my ( $self, $aggregate, @tests ) = @_;

    my $jobs = $self->jobs;
    my $mux  = TAP::Parser::Multiplexer->new;

    RESULT: {

        # Keep multiplexer topped up
        while ( @tests && $mux->parsers < $jobs ) {
            my $test = shift @tests;
            my ( $parser, $session ) = $self->make_parser($test);
            $mux->add( $parser, [ $session, $test ] );
        }

        if ( my ( $parser, $stash, $result ) = $mux->next ) {
            my ( $session, $test ) = @$stash;
            if ( defined $result ) {
                $session->result($result);
                exit 1 if $result->is_bailout;
            }
            else {

                # End of parser. Automatically removed from the mux.
                $self->finish_parser( $parser, $session );
                $self->_after_test( $aggregate, $test, $parser );
            }
            redo RESULT;
        }
    }

    return;
}

sub _aggregate_single {
    my ( $self, $aggregate, @tests ) = @_;

    for my $test (@tests) {
        my ( $parser, $session ) = $self->make_parser($test);

        while ( defined( my $result = $parser->next ) ) {
            $session->result($result);
            if ( $result->is_bailout ) {

                # Keep reading until input is exhausted in the hope
                # of allowing any pending diagnostics to show up.
                1 while $parser->next;
                exit 1;
            }
        }

        $self->finish_parser( $parser, $session );
        $self->_after_test( $aggregate, $test, $parser );
    }

    return;
}

=head3 C<aggregate_tests>

  $harness->aggregate_tests( $aggregate, @tests );

Run the named tests and display a summary of result. Tests will be run
in the order found. 

Test results will be added to the supplied L<TAP::Parser::Aggregator>.
C<aggregate_tests> may be called multiple times to run several sets of
tests. Multiple C<Test::Harness> instances may be used to pass results
to a single aggregator so that different parts of a complex test suite
may be run using different C<TAP::Harness> settings. This is useful, for
example, in the case where some tests should run in parallel but others
are unsuitable for parallel execution.

    my $formatter = TAP::Formatter::Console->new;
    my $ser_harness = TAP::Harness->new( { formatter => $formatter } );
    my $par_harness = TAP::Harness->new( { formatter => $formatter,
                                           jobs => 9 } );
    my $aggregator = TAP::Parser::Aggregator->new;
    
    $aggregator->start();
    $ser_harness->aggregate_tests( $aggregator, @ser_tests );
    $par_harness->aggregate_tests( $aggregator, @par_tests );
    $aggregator->stop();
    $formatter->summary( $aggregator );

Note that for simpler testing requirements it will often be possible to
replace the above code with a single call to C<runtests>.

Each elements of the @tests array is either

=over

=item * the file name of a test script to run

=item * a reference to a [ file name, display name ]

=back

When you supply a separate display name it becomes possible to run a
test more than once; the display name is effectively the alias by which
the test is known inside the harness. The harness doesn't care if it
runs the same script more than once along as each invocation uses a
different name.

=cut

sub aggregate_tests {
    my ( $self, $aggregate, @tests ) = @_;

    my $jobs = $self->jobs;

    my @expanded = map { 'ARRAY' eq ref $_ ? $_ : [ $_, $_ ] } @tests;

    # Formatter gets only names
    $self->formatter->prepare( map { $_->[1] } @expanded );

    if ( $self->jobs > 1 ) {
        if ( $self->fork ) {
            $self->_aggregate_forked( $aggregate, @expanded );
        }
        else {
            $self->_aggregate_parallel( $aggregate, @expanded );
        }
    }
    else {
        $self->_aggregate_single( $aggregate, @expanded );
    }

    return;
}

=head3 C<jobs>

Returns the number of concurrent test runs the harness is handling. For the default
harness this value is always 1. A parallel harness such as L<TAP::Harness::Parallel>
will override this to return the number of jobs it is handling.

=head3 C<fork>

If true the harness will attempt to fork and run the parser for each
test in a separate process. Currently this option requires
L<Parallel::Iterator> to be installed.

=cut

##############################################################################

=head1 SUBCLASSING

C<TAP::Harness> is designed to be (mostly) easy to subclass.  If you don't
like how a particular feature functions, just override the desired methods.

=head2 Methods

TODO: This is out of date

The following methods are ones you may wish to override if you want to
subclass C<TAP::Harness>.

=head3 C<summary>

  $harness->summary( \%args );

C<summary> prints the summary report after all tests are run.  The argument is
a hashref with the following keys:

=over 4

=item * C<start>

This is created with C<< Benchmark->new >> and it the time the tests started.
You can print a useful summary time, if desired, with:

  $self->output(timestr( timediff( Benchmark->new, $start_time ), 'nop' ));

=item * C<tests>

This is an array reference of all test names.  To get the L<TAP::Parser>
object for individual tests:

 my $aggregate = $args->{aggregate};
 my $tests     = $args->{tests};

 for my $name ( @$tests ) {
     my ($parser) = $aggregate->parsers($test);
     ... do something with $parser
 }

This is a bit clunky and will be cleaned up in a later release.

=back

=cut

sub _get_parser_args {
    my ( $self, $test ) = @_;
    my $test_prog = $test->[0];
    my %args      = ();
    my @switches;
    @switches = $self->lib if $self->lib;
    push @switches => $self->switches if $self->switches;
    $args{switches} = \@switches;
    $args{spool}    = $self->_open_spool($test_prog);
    $args{merge}    = $self->merge;
    $args{exec}     = $self->exec;

    if ( my $exec = $self->exec ) {
        $args{exec} = [ @$exec, $test_prog ];
    }
    else {
        $args{source} = $test_prog;
    }

    if ( defined( my $test_args = $self->test_args ) ) {
        $args{test_args} = $test_args;
    }

    return \%args;
}

=head3 C<make_parser>

Make a new parser and display formatter session. Typically used and/or
overridden in subclasses.

    my ( $parser, $session ) = $harness->make_parser;


=cut

sub make_parser {
    my ( $self, $test ) = @_;

    my $args = $self->_get_parser_args($test);
    $self->_make_callback( 'parser_args', $args, $test );
    my $parser = TAP::Parser->new($args);

    $self->_make_callback( 'made_parser', $parser, $test );
    my $session = $self->formatter->open_test( $test->[1], $parser );

    return ( $parser, $session );
}

=head3 C<finish_parser>

Terminate use of a parser. Typically used and/or overridden in
subclasses. The parser isn't destroyed as a result of this.

=cut

sub finish_parser {
    my ( $self, $parser, $session ) = @_;

    $session->close_test;
    $self->_close_spool($parser);

    return $parser;
}

sub _open_spool {
    my $self = shift;
    my $test = shift;

    if ( my $spool_dir = $ENV{PERL_TEST_HARNESS_DUMP_TAP} ) {

        my $spool = File::Spec->catfile( $spool_dir, $test );

        # Make the directory
        my ( $vol, $dir, undef ) = File::Spec->splitpath($spool);
        my $path = File::Spec->catpath( $vol, $dir, '' );
        eval { mkpath($path) };
        $self->_croak($@) if $@;

        my $spool_handle = IO::Handle->new;
        open( $spool_handle, ">$spool" )
          or $self->_croak(" Can't write $spool ( $! ) ");

        return $spool_handle;
    }

    return;
}

sub _close_spool {
    my $self = shift;
    my ($parser) = @_;

    if ( my $spool_handle = $parser->delete_spool ) {
        close($spool_handle)
          or $self->_croak(" Error closing TAP spool file( $! ) \n ");
    }

    return;
}

sub _croak {
    my ( $self, $message ) = @_;
    unless ($message) {
        $message = $self->_error;
    }
    $self->SUPER::_croak($message);

    return;
}

=head1 REPLACING

If you like the C<prove> utility and L<TAP::Parser> but you want your
own harness, all you need to do is write one and provide C<new> and
C<runtests> methods. Then you can use the C<prove> utility like so:

 prove --harness My::Test::Harness

Note that while C<prove> accepts a list of tests (or things to be
tested), C<new> has a fairly rich set of arguments. You'll probably want
to read over this code carefully to see how all of them are being used.

=head1 SEE ALSO

L<Test::Harness>

=cut

1;

# vim:ts=4:sw=4:et:sta