tester.pm

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

sub test_test
{
   # decode the arguements as described in the pod
   my $mess;
   my %args;
   if (@_ == 1)
     { $mess = shift }
   else
   {
     %args = @_;
     $mess = $args{name} if exists($args{name});
     $mess = $args{title} if exists($args{title});
     $mess = $args{label} if exists($args{label});
   }

    # er, are we testing?
    croak "Not testing.  You must declare output with a test function first."
	unless $testing;

    # okay, reconnect the test suite back to the saved handles
    $t->output($original_output_handle);
    $t->failure_output($original_failure_handle);
    $t->todo_output($original_todo_handle);

    # restore the test no, etc, back to the original point
    $t->current_test($testing_num);
    $testing = 0;

    # re-enable the original setting of the harness
    $ENV{HARNESS_ACTIVE} = $original_harness_env;

    # check the output we've stashed
    unless ($t->ok(    ($args{skip_out} || $out->check)
                    && ($args{skip_err} || $err->check),
                   $mess))
    {
      # print out the diagnostic information about why this
      # test failed

      local $_;

      $t->diag(map {"$_\n"} $out->complaint)
	unless $args{skip_out} || $out->check;

      $t->diag(map {"$_\n"} $err->complaint)
	unless $args{skip_err} || $err->check;
    }
}

=item line_num

A utility function that returns the line number that the function was
called on.  You can pass it an offset which will be added to the
result.  This is very useful for working out the correct text of
diagnostic functions that contain line numbers.

Essentially this is the same as the C<__LINE__> macro, but the
C<line_num(+3)> idiom is arguably nicer.

=cut

sub line_num
{
    my ($package, $filename, $line) = caller;
    return $line + (shift() || 0); # prevent warnings
}

=back

In addition to the six exported functions there there exists one
function that can only be accessed with a fully qualified function
call.

=over 4

=item color

When C<test_test> is called and the output that your tests generate
does not match that which you declared, C<test_test> will print out
debug information showing the two conflicting versions.  As this
output itself is debug information it can be confusing which part of
the output is from C<test_test> and which was the original output from
your original tests.  Also, it may be hard to spot things like
extraneous whitespace at the end of lines that may cause your test to
fail even though the output looks similar.

To assist you, if you have the B<Term::ANSIColor> module installed
(which you should do by default from perl 5.005 onwards), C<test_test>
can colour the background of the debug information to disambiguate the
different types of output. The debug output will have it's background
coloured green and red.  The green part represents the text which is
the same between the executed and actual output, the red shows which
part differs.

The C<color> function determines if colouring should occur or not.
Passing it a true or false value will enable or disable colouring
respectively, and the function called with no argument will return the
current setting.

To enable colouring from the command line, you can use the
B<Text::Builder::Tester::Color> module like so:

   perl -Mlib=Text::Builder::Tester::Color test.t

Or by including the B<Test::Builder::Tester::Color> module directly in
the PERL5LIB.

=cut

my $color;
sub color
{
  $color = shift if @_;
  $color;
}

=back

=head1 BUGS

Calls C<<Test::Builder->no_ending>> turning off the ending tests.
This is needed as otherwise it will trip out because we've run more
tests than we strictly should have and it'll register any failures we
had that we were testing for as real failures.

The color function doesn't work unless B<Term::ANSIColor> is installed
and is compatible with your terminal.

Bugs (and requests for new features) can be reported to the author
though the CPAN RT system:
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Builder-Tester>

=head1 AUTHOR

Copyright Mark Fowler E<lt>[e-mail]<gt> 2002, 2004.

Some code taken from B<Test::More> and B<Test::Catch>, written by by
Michael G Schwern E<lt>[e-mail]<gt>.  Hence, those parts
Copyright Micheal G Schwern 2001.  Used and distributed with
permission.

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

=head1 NOTES

This code has been tested explicitly on the following versions
of perl: 5.7.3, 5.6.1, 5.6.0, 5.005_03, 5.004_05 and 5.004.

Thanks to Richard Clamp E<lt>[e-mail]<gt> for letting
me use his testing system to try this module out on.

=head1 SEE ALSO

L<Test::Builder>, L<Test::Builder::Tester::Color>, L<Test::More>.

=cut

1;

####################################################################
# Helper class that is used to remember expected and received data

package Test::Builder::Tester::Tie;

##
# add line(s) to be expected

sub expect
{
    my $self = shift;

    my @checks = @_;
    foreach my $check (@checks) {
        $check = $self->_translate_Failed_check($check);
        push @{$self->{wanted}}, ref $check ? $check : "$check\n";
    }
}


sub _translate_Failed_check
{
    my($self, $check) = @_;

    if( $check =~ /\A(.*)#     (Failed .*test) \((.*?) at line (\d+)\)\Z(?!\n)/ ) {
        $check = "/\Q$1\E#\\s+\Q$2\E.*?\\n?.*?\Qat $3\E line \Q$4\E.*\\n?/";
    }

    return $check;
}


##
# return true iff the expected data matches the got data

sub check
{
    my $self = shift;

    # turn off warnings as these might be undef
    local $^W = 0;

    my @checks = @{$self->{wanted}};
    my $got = $self->{got};
    foreach my $check (@checks) {
        $check = "\Q$check\E" unless ($check =~ s,^/(.*)/$,$1, or ref $check);
        return 0 unless $got =~ s/^$check//;
    }

    return length $got == 0;
}

##
# a complaint message about the inputs not matching (to be
# used for debugging messages)

sub complaint
{
    my $self = shift;
    my $type   = $self->type;
    my $got    = $self->got;
    my $wanted = join "\n", @{$self->wanted};

    # are we running in colour mode?
    if (Test::Builder::Tester::color)
    {
      # get color
      eval "require Term::ANSIColor";
      unless ($@)
      {
	# colours

	my $green = Term::ANSIColor::color("black").
	            Term::ANSIColor::color("on_green");
        my $red   = Term::ANSIColor::color("black").
                    Term::ANSIColor::color("on_red");
	my $reset = Term::ANSIColor::color("reset");

	# work out where the two strings start to differ
	my $char = 0;
	$char++ while substr($got, $char, 1) eq substr($wanted, $char, 1);

	# get the start string and the two end strings
	my $start     = $green . substr($wanted, 0,   $char);
	my $gotend    = $red   . substr($got   , $char) . $reset;
	my $wantedend = $red   . substr($wanted, $char) . $reset;

	# make the start turn green on and off
	$start =~ s/\n/$reset\n$green/g;

	# make the ends turn red on and off
	$gotend    =~ s/\n/$reset\n$red/g;
	$wantedend =~ s/\n/$reset\n$red/g;

	# rebuild the strings
	$got    = $start . $gotend;
	$wanted = $start . $wantedend;
      }
    }

    return "$type is:\n" .
           "$got\nnot:\n$wanted\nas expected"
}

##
# forget all expected and got data

sub reset
{
    my $self = shift;
    %$self = (
              type   => $self->{type},
              got    => '',
              wanted => [],
             );
}


sub got
{
    my $self = shift;
    return $self->{got};
}

sub wanted
{
    my $self = shift;
    return $self->{wanted};
}

sub type
{
    my $self = shift;
    return $self->{type};
}

###
# tie interface
###

sub PRINT  {
    my $self = shift;
    $self->{got} .= join '', @_;
}

sub TIEHANDLE {
    my($class, $type) = @_;

    my $self = bless {
                   type => $type
               }, $class;

    $self->reset;

    return $self;
}

sub READ {}
sub READLINE {}
sub GETC {}
sub FILENO {}

1;