parser.pm

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

                push @{ $self->{ $test->is_ok ? 'passed' : 'failed' } } =>
                  $number;
                push @{
                    $self->{
                        $test->is_actual_ok
                        ? 'actual_passed'
                        : 'actual_failed'
                      }
                  } => $number;
            },
        },
        yaml => {
            act => sub { },
        },
    );

    # Each state contains a hash the keys of which match a token type. For
    # each token
    # type there may be:
    #   act      A coderef to run
    #   goto     The new state to move to. Stay in this state if
    #            missing
    #   continue Goto the new state and run the new state for the
    #            current token
    %states = (
        INIT => {
            version => {
                act => sub {
                    my ($version) = @_;
                    my $ver_num = $version->version;
                    if ( $ver_num <= $DEFAULT_TAP_VERSION ) {
                        my $ver_min = $DEFAULT_TAP_VERSION + 1;
                        $self->_add_error(
                                "Explicit TAP version must be at least "
                              . "$ver_min. Got version $ver_num" );
                        $ver_num = $DEFAULT_TAP_VERSION;
                    }
                    if ( $ver_num > $MAX_TAP_VERSION ) {
                        $self->_add_error(
                                "TAP specified version $ver_num but "
                              . "we don't know about versions later "
                              . "than $MAX_TAP_VERSION" );
                        $ver_num = $MAX_TAP_VERSION;
                    }
                    $self->version($ver_num);
                    $self->_grammar->set_version($ver_num);
                },
                goto => 'PLAN'
            },
            plan => { goto => 'PLANNED' },
            test => { goto => 'UNPLANNED' },
        },
        PLAN => {
            plan => { goto => 'PLANNED' },
            test => { goto => 'UNPLANNED' },
        },
        PLANNED => {
            test => { goto => 'PLANNED_AFTER_TEST' },
            plan => {
                act => sub {
                    my ($version) = @_;
                    $self->_add_error(
                        'More than one plan found in TAP output');
                },
            },
        },
        PLANNED_AFTER_TEST => {
            test => { goto => 'PLANNED_AFTER_TEST' },
            plan => { act  => sub { }, continue => 'PLANNED' },
            yaml => { goto => 'PLANNED' },
        },
        GOT_PLAN => {
            test => {
                act => sub {
                    my ($plan) = @_;
                    my $line = $self->plan;
                    $self->_add_error(
                            "Plan ($line) must be at the beginning "
                          . "or end of the TAP output" );
                    $self->is_good_plan(0);
                },
                continue => 'PLANNED'
            },
            plan => { continue => 'PLANNED' },
        },
        UNPLANNED => {
            test => { goto => 'UNPLANNED_AFTER_TEST' },
            plan => { goto => 'GOT_PLAN' },
        },
        UNPLANNED_AFTER_TEST => {
            test => { act  => sub { }, continue => 'UNPLANNED' },
            plan => { act  => sub { }, continue => 'UNPLANNED' },
            yaml => { goto => 'PLANNED' },
        },
    );

    # Apply globals and defaults to state table
    for my $name ( sort keys %states ) {

        # Merge with globals
        my $st = { %state_globals, %{ $states{$name} } };

        # Add defaults
        for my $next ( sort keys %{$st} ) {
            if ( my $default = $state_defaults{$next} ) {
                for my $def ( sort keys %{$default} ) {
                    $st->{$next}->{$def} ||= $default->{$def};
                }
            }
        }

        # Stuff back in table
        $states{$name} = $st;
    }

    return \%states;
}

=head3 C<get_select_handles>

Get an a list of file handles which can be passed to C<select> to
determine the readiness of this parser.

=cut

sub get_select_handles { shift->_stream->get_select_handles }

sub _iter {
    my $self        = shift;
    my $stream      = $self->_stream;
    my $spool       = $self->_spool;
    my $grammar     = $self->_grammar;
    my $state       = 'INIT';
    my $state_table = $self->_make_state_table;

    # Make next_state closure
    my $next_state = sub {
        my $token = shift;
        my $type  = $token->type;
        my $count = 1;
        TRANS: {
            my $state_spec = $state_table->{$state}
              or die "Illegal state: $state";

            if ( my $next = $state_spec->{$type} ) {
                if ( my $act = $next->{act} ) {
                    $act->($token);
                }
                if ( my $cont = $next->{continue} ) {
                    $state = $cont;
                    redo TRANS;
                }
                elsif ( my $goto = $next->{goto} ) {
                    $state = $goto;
                }
            }
        }
        return $token;
    };

    # Handle end of stream - which means either pop a block or finish
    my $end_handler = sub {
        $self->exit( $stream->exit );
        $self->wait( $stream->wait );
        $self->_finish;
        return;
    };

    # Finally make the closure that we return. For performance reasons
    # there are two versions of the returned function: one that handles
    # callbacks and one that does not.
    if ( $self->_has_callbacks ) {
        return sub {
            my $result = eval { $grammar->tokenize };
            $self->_add_error($@) if $@;

            if ( defined $result ) {
                $result = $next_state->($result);

                if ( my $code = $self->_callback_for( $result->type ) ) {
                    $_->($result) for @{$code};
                }
                else {
                    $self->_make_callback( 'ELSE', $result );
                }

                $self->_make_callback( 'ALL', $result );

                # Echo TAP to spool file
                print {$spool} $result->raw, "\n" if $spool;
            }
            else {
                $result = $end_handler->();
                $self->_make_callback( 'EOF', $result )
                  unless defined $result;
            }

            return $result;
        };
    }    # _has_callbacks
    else {
        return sub {
            my $result = eval { $grammar->tokenize };
            $self->_add_error($@) if $@;

            if ( defined $result ) {
                $result = $next_state->($result);

                # Echo TAP to spool file
                print {$spool} $result->raw, "\n" if $spool;
            }
            else {
                $result = $end_handler->();
            }

            return $result;
        };
    }    # no callbacks
}

sub _finish {
    my $self = shift;

    $self->end_time( $self->get_time );

    # sanity checks
    if ( !$self->plan ) {
        $self->_add_error('No plan found in TAP output');
    }
    else {
        $self->is_good_plan(1) unless defined $self->is_good_plan;
    }
    if ( $self->tests_run != ( $self->tests_planned || 0 ) ) {
        $self->is_good_plan(0);
        if ( defined( my $planned = $self->tests_planned ) ) {
            my $ran = $self->tests_run;
            $self->_add_error(
                "Bad plan.  You planned $planned tests but ran $ran.");
        }
    }
    if ( $self->tests_run != ( $self->passed + $self->failed ) ) {

        # this should never happen
        my $actual = $self->tests_run;
        my $passed = $self->passed;
        my $failed = $self->failed;
        $self->_croak( "Panic: planned test count ($actual) did not equal "
              . "sum of passed ($passed) and failed ($failed) tests!" );
    }

    $self->is_good_plan(0) unless defined $self->is_good_plan;
    return $self;
}

=head3 C<delete_spool>

Delete and return the spool.

  my $fh = $parser->delete_spool;

=cut

sub delete_spool {
    my $self = shift;

    return delete $self->{_spool};
}

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

=head1 CALLBACKS

As mentioned earlier, a "callback" key may be added to the
C<TAP::Parser> constructor. If present, each callback corresponding to a
given result type will be called with the result as the argument if the
C<run> method is used. The callback is expected to be a subroutine
reference (or anonymous subroutine) which is invoked with the parser
result as its argument.

 my %callbacks = (
     test    => \&test_callback,
     plan    => \&plan_callback,
     comment => \&comment_callback,
     bailout => \&bailout_callback,
     unknown => \&unknown_callback,
 );

 my $aggregator = TAP::Parser::Aggregator->new;
 foreach my $file ( @test_files ) {
     my $parser = TAP::Parser->new(
         {
             source    => $file,
             callbacks => \%callbacks,
         }
     );
     $parser->run;
     $aggregator->add( $file, $parser );
 }

Callbacks may also be added like this:

 $parser->callback( test => \&test_callback );
 $parser->callback( plan => \&plan_callback );

The following keys allowed for callbacks. These keys are case-sensitive.

=over 4

=item * C<test>

Invoked if C<< $result->is_test >> returns true.

=item * C<version>

Invoked if C<< $result->is_version >> returns true.

=item * C<plan>

Invoked if C<< $result->is_plan >> returns true.

=item * C<comment>

Invoked if C<< $result->is_comment >> returns true.

=item * C<bailout>

Invoked if C<< $result->is_unknown >> returns true.

=item * C<yaml>

Invoked if C<< $result->is_yaml >> returns true.

=item * C<unknown>

Invoked if C<< $result->is_unknown >> returns true.

=item * C<ELSE>

If a result does not have a callback defined for it, this callback will
be invoked. Thus, if all of the previous result types are specified as
callbacks, this callback will I<never> be invoked.

=item * C<ALL>

This callback will always be invoked and this will happen for each
result after one of the above callbacks is invoked.  For example, if
L<Term::ANSIColor> is loaded, you could use the following to color your
test output:

 my %callbacks = (
     test => sub {
         my $test = shift;
         if ( $test->is_ok && not $test->directive ) {
             # normal passing test
             print color 'green';
         }
         elsif ( !$test->is_ok ) {    # even if it's TODO
             print color 'white on_red';
         }
         elsif ( $test->has_skip ) {
             print color 'white on_blue';

         }
         elsif ( $test->has_todo ) {
             print color 'white';
         }
     },
     ELSE => sub {
         # plan, comment, and so on (anything which isn't a test line)
         print color 'black on_white';
     },
     ALL => sub {
         # now print them
         print shift->as_string;
         print color 'reset';
         print "\n";
     },
 );

=item * C<EOF>

Invoked when there are no more lines to be parsed. Since there is no
accompanying L<TAP::Parser::Result> object the C<TAP::Parser> object is
passed instead.

=back

=head1 TAP GRAMMAR

If you're looking for an EBNF grammar, see L<TAP::Parser::Grammar>.

=head1 BACKWARDS COMPATABILITY

The Perl-QA list attempted to ensure backwards compatability with
L<Test::Harness>.  However, there are some minor differences.

=head2 Differences

=over 4

=item * TODO plans

A little-known feature of L<Test::Harness> is that it supported TODO
lists in the plan:

 1..2 todo 2
 ok 1 - We have liftoff
 not ok 2 - Anti-gravity device activated

Under L<Test::Harness>, test number 2 would I<pass> because it was
listed as a TODO test on the plan line. However, we are not aware of
anyone actually using this feature and hard-coding test numbers is
discouraged because it's very easy to add a test and break the test
number sequence. This makes test suites very fragile. Instead, the
following should be used:

 1..2
 ok 1 - We have liftoff
 not ok 2 - Anti-gravity device activated # TODO

=item * 'Missing' tests

It rarely happens, but sometimes a harness might encounter
'missing tests:

 ok 1
 ok 2
 ok 15
 ok 16
 ok 17

L<Test::Harness> would report tests 3-14 as having failed. For the
C<TAP::Parser>, these tests are not considered failed because they've
never run. They're reported as parse failures (tests out of sequence).

=back

=head1 ACKNOWLEDGEMENTS

All of the following have helped. Bug reports, patches, (im)moral
support, or just words of encouragement have all been forthcoming.

=over 4

=item * Michael Schwern

=item * Andy Lester

=item * chromatic

=item * GEOFFR

=item * Shlomi Fish

=item * Torsten Schoenfeld

=item * Jerry Gay

=item * Aristotle

=item * Adam Kennedy

=item * Yves Orton

=item * Adrian Howard

=item * Sean & Lil

=item * Andreas J. Koenig

=item * Florian Ragwitz

=item * Corion

=item * Mark Stosberg

=item * Matt Kraai

=back

=head1 AUTHORS

Curtis "Ovid" Poe <[e-mail]>

Andy Armstong <[e-mail]>

Eric Wilhelm @ <ewilhelm at cpan dot org>

Michael Peters <mpeters at plusthree dot com>

Leif Eriksen <leif dot eriksen at bigpond dot com>

=head1 BUGS

Please report any bugs or feature requests to
C<[e-mail]>, or through the web interface at
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=TAP-Parser>.
We will be notified, and then you'll automatically be notified of
progress on your bug as we make changes.

Obviously, bugs which include patches are best. If you prefer, you can
patch against bleed by via anonymous checkout of the latest version:

 svn checkout http://svn.hexten.net/tapx

=head1 COPYRIGHT & LICENSE

Copyright 2006-2008 Curtis "Ovid" Poe, all rights reserved.

This program is free software; you can redistribute it and/or modify it
under the same terms as Perl itself.

=cut

1;