Added Cyg-Win
This commit is contained in:
parent
82cbc206eb
commit
413c315806
10586 changed files with 3806249 additions and 0 deletions
2650
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Builder.pm
Normal file
2650
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Builder.pm
Normal file
File diff suppressed because it is too large
Load diff
|
|
@ -0,0 +1,107 @@
|
|||
package Test::Builder::Formatter;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) }
|
||||
|
||||
use Test2::Util::HashBase qw/no_header no_diag/;
|
||||
|
||||
BEGIN {
|
||||
*OUT_STD = Test2::Formatter::TAP->can('OUT_STD');
|
||||
*OUT_ERR = Test2::Formatter::TAP->can('OUT_ERR');
|
||||
|
||||
my $todo = OUT_ERR() + 1;
|
||||
*OUT_TODO = sub() { $todo };
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->SUPER::init(@_);
|
||||
$self->{+HANDLES}->[OUT_TODO] = $self->{+HANDLES}->[OUT_STD];
|
||||
}
|
||||
|
||||
sub plan_tap {
|
||||
my ($self, $f) = @_;
|
||||
|
||||
return if $self->{+NO_HEADER};
|
||||
return $self->SUPER::plan_tap($f);
|
||||
}
|
||||
|
||||
sub debug_tap {
|
||||
my ($self, $f, $num) = @_;
|
||||
return if $self->{+NO_DIAG};
|
||||
my @out = $self->SUPER::debug_tap($f, $num);
|
||||
$self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package}
|
||||
&& $f->{about}->{package} eq 'Test::Builder::TodoDiag';
|
||||
return @out;
|
||||
}
|
||||
|
||||
sub info_tap {
|
||||
my ($self, $f) = @_;
|
||||
return if $self->{+NO_DIAG};
|
||||
my @out = $self->SUPER::info_tap($f);
|
||||
$self->redirect(\@out) if @out && ref $f->{about} && defined $f->{about}->{package}
|
||||
&& $f->{about}->{package} eq 'Test::Builder::TodoDiag';
|
||||
return @out;
|
||||
}
|
||||
|
||||
sub redirect {
|
||||
my ($self, $out) = @_;
|
||||
$_->[0] = OUT_TODO for @$out;
|
||||
}
|
||||
|
||||
sub no_subtest_space { 1 }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Builder::Formatter - Test::Builder subclass of Test2::Formatter::TAP
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is what takes events and turns them into TAP.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::Builder; # Loads Test::Builder::Formatter for you
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
L<https://github.com/Test-More/test-more/>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
See L<https://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,659 @@
|
|||
package Test::Builder::IO::Scalar;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Builder::IO::Scalar - A copy of IO::Scalar for Test::Builder
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a copy of L<IO::Scalar> which ships with L<Test::Builder> to
|
||||
support scalar references as filehandles on Perl 5.6. Newer
|
||||
versions of Perl simply use C<open()>'s built in support.
|
||||
|
||||
L<Test::Builder> can not have dependencies on other modules without
|
||||
careful consideration, so its simply been copied into the distribution.
|
||||
|
||||
=head1 COPYRIGHT and LICENSE
|
||||
|
||||
This file came from the "IO-stringy" Perl5 toolkit.
|
||||
|
||||
Copyright (c) 1996 by Eryq. All rights reserved.
|
||||
Copyright (c) 1999,2001 by ZeeGee Software Inc. All rights reserved.
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
# This is copied code, I don't care.
|
||||
##no critic
|
||||
|
||||
use Carp;
|
||||
use strict;
|
||||
use vars qw($VERSION @ISA);
|
||||
use IO::Handle;
|
||||
|
||||
use 5.005;
|
||||
|
||||
### The package version, both in 1.23 style *and* usable by MakeMaker:
|
||||
$VERSION = "2.114";
|
||||
|
||||
### Inheritance:
|
||||
@ISA = qw(IO::Handle);
|
||||
|
||||
#==============================
|
||||
|
||||
=head2 Construction
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item new [ARGS...]
|
||||
|
||||
I<Class method.>
|
||||
Return a new, unattached scalar handle.
|
||||
If any arguments are given, they're sent to open().
|
||||
|
||||
=cut
|
||||
|
||||
sub new {
|
||||
my $proto = shift;
|
||||
my $class = ref($proto) || $proto;
|
||||
my $self = bless \do { local *FH }, $class;
|
||||
tie *$self, $class, $self;
|
||||
$self->open(@_); ### open on anonymous by default
|
||||
$self;
|
||||
}
|
||||
sub DESTROY {
|
||||
shift->close;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item open [SCALARREF]
|
||||
|
||||
I<Instance method.>
|
||||
Open the scalar handle on a new scalar, pointed to by SCALARREF.
|
||||
If no SCALARREF is given, a "private" scalar is created to hold
|
||||
the file data.
|
||||
|
||||
Returns the self object on success, undefined on error.
|
||||
|
||||
=cut
|
||||
|
||||
sub open {
|
||||
my ($self, $sref) = @_;
|
||||
|
||||
### Sanity:
|
||||
defined($sref) or do {my $s = ''; $sref = \$s};
|
||||
(ref($sref) eq "SCALAR") or croak "open() needs a ref to a scalar";
|
||||
|
||||
### Setup:
|
||||
*$self->{Pos} = 0; ### seek position
|
||||
*$self->{SR} = $sref; ### scalar reference
|
||||
$self;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item opened
|
||||
|
||||
I<Instance method.>
|
||||
Is the scalar handle opened on something?
|
||||
|
||||
=cut
|
||||
|
||||
sub opened {
|
||||
*{shift()}->{SR};
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item close
|
||||
|
||||
I<Instance method.>
|
||||
Disassociate the scalar handle from its underlying scalar.
|
||||
Done automatically on destroy.
|
||||
|
||||
=cut
|
||||
|
||||
sub close {
|
||||
my $self = shift;
|
||||
%{*$self} = ();
|
||||
1;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
|
||||
#==============================
|
||||
|
||||
=head2 Input and output
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item flush
|
||||
|
||||
I<Instance method.>
|
||||
No-op, provided for OO compatibility.
|
||||
|
||||
=cut
|
||||
|
||||
sub flush { "0 but true" }
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item getc
|
||||
|
||||
I<Instance method.>
|
||||
Return the next character, or undef if none remain.
|
||||
|
||||
=cut
|
||||
|
||||
sub getc {
|
||||
my $self = shift;
|
||||
|
||||
### Return undef right away if at EOF; else, move pos forward:
|
||||
return undef if $self->eof;
|
||||
substr(${*$self->{SR}}, *$self->{Pos}++, 1);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item getline
|
||||
|
||||
I<Instance method.>
|
||||
Return the next line, or undef on end of string.
|
||||
Can safely be called in an array context.
|
||||
Currently, lines are delimited by "\n".
|
||||
|
||||
=cut
|
||||
|
||||
sub getline {
|
||||
my $self = shift;
|
||||
|
||||
### Return undef right away if at EOF:
|
||||
return undef if $self->eof;
|
||||
|
||||
### Get next line:
|
||||
my $sr = *$self->{SR};
|
||||
my $i = *$self->{Pos}; ### Start matching at this point.
|
||||
|
||||
### Minimal impact implementation!
|
||||
### We do the fast fast thing (no regexps) if using the
|
||||
### classic input record separator.
|
||||
|
||||
### Case 1: $/ is undef: slurp all...
|
||||
if (!defined($/)) {
|
||||
*$self->{Pos} = length $$sr;
|
||||
return substr($$sr, $i);
|
||||
}
|
||||
|
||||
### Case 2: $/ is "\n": zoom zoom zoom...
|
||||
elsif ($/ eq "\012") {
|
||||
|
||||
### Seek ahead for "\n"... yes, this really is faster than regexps.
|
||||
my $len = length($$sr);
|
||||
for (; $i < $len; ++$i) {
|
||||
last if ord (substr ($$sr, $i, 1)) == 10;
|
||||
}
|
||||
|
||||
### Extract the line:
|
||||
my $line;
|
||||
if ($i < $len) { ### We found a "\n":
|
||||
$line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos} + 1);
|
||||
*$self->{Pos} = $i+1; ### Remember where we finished up.
|
||||
}
|
||||
else { ### No "\n"; slurp the remainder:
|
||||
$line = substr ($$sr, *$self->{Pos}, $i - *$self->{Pos});
|
||||
*$self->{Pos} = $len;
|
||||
}
|
||||
return $line;
|
||||
}
|
||||
|
||||
### Case 3: $/ is ref to int. Do fixed-size records.
|
||||
### (Thanks to Dominique Quatravaux.)
|
||||
elsif (ref($/)) {
|
||||
my $len = length($$sr);
|
||||
my $i = ${$/} + 0;
|
||||
my $line = substr ($$sr, *$self->{Pos}, $i);
|
||||
*$self->{Pos} += $i;
|
||||
*$self->{Pos} = $len if (*$self->{Pos} > $len);
|
||||
return $line;
|
||||
}
|
||||
|
||||
### Case 4: $/ is either "" (paragraphs) or something weird...
|
||||
### This is Graham's general-purpose stuff, which might be
|
||||
### a tad slower than Case 2 for typical data, because
|
||||
### of the regexps.
|
||||
else {
|
||||
pos($$sr) = $i;
|
||||
|
||||
### If in paragraph mode, skip leading lines (and update i!):
|
||||
length($/) or
|
||||
(($$sr =~ m/\G\n*/g) and ($i = pos($$sr)));
|
||||
|
||||
### If we see the separator in the buffer ahead...
|
||||
if (length($/)
|
||||
? $$sr =~ m,\Q$/\E,g ### (ordinary sep) TBD: precomp!
|
||||
: $$sr =~ m,\n\n,g ### (a paragraph)
|
||||
) {
|
||||
*$self->{Pos} = pos $$sr;
|
||||
return substr($$sr, $i, *$self->{Pos}-$i);
|
||||
}
|
||||
### Else if no separator remains, just slurp the rest:
|
||||
else {
|
||||
*$self->{Pos} = length $$sr;
|
||||
return substr($$sr, $i);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item getlines
|
||||
|
||||
I<Instance method.>
|
||||
Get all remaining lines.
|
||||
It will croak() if accidentally called in a scalar context.
|
||||
|
||||
=cut
|
||||
|
||||
sub getlines {
|
||||
my $self = shift;
|
||||
wantarray or croak("can't call getlines in scalar context!");
|
||||
my ($line, @lines);
|
||||
push @lines, $line while (defined($line = $self->getline));
|
||||
@lines;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item print ARGS...
|
||||
|
||||
I<Instance method.>
|
||||
Print ARGS to the underlying scalar.
|
||||
|
||||
B<Warning:> this continues to always cause a seek to the end
|
||||
of the string, but if you perform seek()s and tell()s, it is
|
||||
still safer to explicitly seek-to-end before subsequent print()s.
|
||||
|
||||
=cut
|
||||
|
||||
sub print {
|
||||
my $self = shift;
|
||||
*$self->{Pos} = length(${*$self->{SR}} .= join('', @_) . (defined($\) ? $\ : ""));
|
||||
1;
|
||||
}
|
||||
sub _unsafe_print {
|
||||
my $self = shift;
|
||||
my $append = join('', @_) . $\;
|
||||
${*$self->{SR}} .= $append;
|
||||
*$self->{Pos} += length($append);
|
||||
1;
|
||||
}
|
||||
sub _old_print {
|
||||
my $self = shift;
|
||||
${*$self->{SR}} .= join('', @_) . $\;
|
||||
*$self->{Pos} = length(${*$self->{SR}});
|
||||
1;
|
||||
}
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item read BUF, NBYTES, [OFFSET]
|
||||
|
||||
I<Instance method.>
|
||||
Read some bytes from the scalar.
|
||||
Returns the number of bytes actually read, 0 on end-of-file, undef on error.
|
||||
|
||||
=cut
|
||||
|
||||
sub read {
|
||||
my $self = $_[0];
|
||||
my $n = $_[2];
|
||||
my $off = $_[3] || 0;
|
||||
|
||||
my $read = substr(${*$self->{SR}}, *$self->{Pos}, $n);
|
||||
$n = length($read);
|
||||
*$self->{Pos} += $n;
|
||||
($off ? substr($_[1], $off) : $_[1]) = $read;
|
||||
return $n;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item write BUF, NBYTES, [OFFSET]
|
||||
|
||||
I<Instance method.>
|
||||
Write some bytes to the scalar.
|
||||
|
||||
=cut
|
||||
|
||||
sub write {
|
||||
my $self = $_[0];
|
||||
my $n = $_[2];
|
||||
my $off = $_[3] || 0;
|
||||
|
||||
my $data = substr($_[1], $off, $n);
|
||||
$n = length($data);
|
||||
$self->print($data);
|
||||
return $n;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item sysread BUF, LEN, [OFFSET]
|
||||
|
||||
I<Instance method.>
|
||||
Read some bytes from the scalar.
|
||||
Returns the number of bytes actually read, 0 on end-of-file, undef on error.
|
||||
|
||||
=cut
|
||||
|
||||
sub sysread {
|
||||
my $self = shift;
|
||||
$self->read(@_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item syswrite BUF, NBYTES, [OFFSET]
|
||||
|
||||
I<Instance method.>
|
||||
Write some bytes to the scalar.
|
||||
|
||||
=cut
|
||||
|
||||
sub syswrite {
|
||||
my $self = shift;
|
||||
$self->write(@_);
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#==============================
|
||||
|
||||
=head2 Seeking/telling and other attributes
|
||||
|
||||
=over 4
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item autoflush
|
||||
|
||||
I<Instance method.>
|
||||
No-op, provided for OO compatibility.
|
||||
|
||||
=cut
|
||||
|
||||
sub autoflush {}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item binmode
|
||||
|
||||
I<Instance method.>
|
||||
No-op, provided for OO compatibility.
|
||||
|
||||
=cut
|
||||
|
||||
sub binmode {}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item clearerr
|
||||
|
||||
I<Instance method.> Clear the error and EOF flags. A no-op.
|
||||
|
||||
=cut
|
||||
|
||||
sub clearerr { 1 }
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item eof
|
||||
|
||||
I<Instance method.> Are we at end of file?
|
||||
|
||||
=cut
|
||||
|
||||
sub eof {
|
||||
my $self = shift;
|
||||
(*$self->{Pos} >= length(${*$self->{SR}}));
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item seek OFFSET, WHENCE
|
||||
|
||||
I<Instance method.> Seek to a given position in the stream.
|
||||
|
||||
=cut
|
||||
|
||||
sub seek {
|
||||
my ($self, $pos, $whence) = @_;
|
||||
my $eofpos = length(${*$self->{SR}});
|
||||
|
||||
### Seek:
|
||||
if ($whence == 0) { *$self->{Pos} = $pos } ### SEEK_SET
|
||||
elsif ($whence == 1) { *$self->{Pos} += $pos } ### SEEK_CUR
|
||||
elsif ($whence == 2) { *$self->{Pos} = $eofpos + $pos} ### SEEK_END
|
||||
else { croak "bad seek whence ($whence)" }
|
||||
|
||||
### Fixup:
|
||||
if (*$self->{Pos} < 0) { *$self->{Pos} = 0 }
|
||||
if (*$self->{Pos} > $eofpos) { *$self->{Pos} = $eofpos }
|
||||
return 1;
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item sysseek OFFSET, WHENCE
|
||||
|
||||
I<Instance method.> Identical to C<seek OFFSET, WHENCE>, I<q.v.>
|
||||
|
||||
=cut
|
||||
|
||||
sub sysseek {
|
||||
my $self = shift;
|
||||
$self->seek (@_);
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item tell
|
||||
|
||||
I<Instance method.>
|
||||
Return the current position in the stream, as a numeric offset.
|
||||
|
||||
=cut
|
||||
|
||||
sub tell { *{shift()}->{Pos} }
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item use_RS [YESNO]
|
||||
|
||||
I<Instance method.>
|
||||
B<Deprecated and ignored.>
|
||||
Obey the current setting of $/, like IO::Handle does?
|
||||
Default is false in 1.x, but cold-welded true in 2.x and later.
|
||||
|
||||
=cut
|
||||
|
||||
sub use_RS {
|
||||
my ($self, $yesno) = @_;
|
||||
carp "use_RS is deprecated and ignored; \$/ is always consulted\n";
|
||||
}
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item setpos POS
|
||||
|
||||
I<Instance method.>
|
||||
Set the current position, using the opaque value returned by C<getpos()>.
|
||||
|
||||
=cut
|
||||
|
||||
sub setpos { shift->seek($_[0],0) }
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item getpos
|
||||
|
||||
I<Instance method.>
|
||||
Return the current position in the string, as an opaque object.
|
||||
|
||||
=cut
|
||||
|
||||
*getpos = \&tell;
|
||||
|
||||
|
||||
#------------------------------
|
||||
|
||||
=item sref
|
||||
|
||||
I<Instance method.>
|
||||
Return a reference to the underlying scalar.
|
||||
|
||||
=cut
|
||||
|
||||
sub sref { *{shift()}->{SR} }
|
||||
|
||||
|
||||
#------------------------------
|
||||
# Tied handle methods...
|
||||
#------------------------------
|
||||
|
||||
# Conventional tiehandle interface:
|
||||
sub TIEHANDLE {
|
||||
((defined($_[1]) && UNIVERSAL::isa($_[1], __PACKAGE__))
|
||||
? $_[1]
|
||||
: shift->new(@_));
|
||||
}
|
||||
sub GETC { shift->getc(@_) }
|
||||
sub PRINT { shift->print(@_) }
|
||||
sub PRINTF { shift->print(sprintf(shift, @_)) }
|
||||
sub READ { shift->read(@_) }
|
||||
sub READLINE { wantarray ? shift->getlines(@_) : shift->getline(@_) }
|
||||
sub WRITE { shift->write(@_); }
|
||||
sub CLOSE { shift->close(@_); }
|
||||
sub SEEK { shift->seek(@_); }
|
||||
sub TELL { shift->tell(@_); }
|
||||
sub EOF { shift->eof(@_); }
|
||||
sub FILENO { -1 }
|
||||
|
||||
#------------------------------------------------------------
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
|
||||
=back
|
||||
|
||||
=cut
|
||||
|
||||
|
||||
=head1 WARNINGS
|
||||
|
||||
Perl's TIEHANDLE spec was incomplete prior to 5.005_57;
|
||||
it was missing support for C<seek()>, C<tell()>, and C<eof()>.
|
||||
Attempting to use these functions with an IO::Scalar will not work
|
||||
prior to 5.005_57. IO::Scalar will not have the relevant methods
|
||||
invoked; and even worse, this kind of bug can lie dormant for a while.
|
||||
If you turn warnings on (via C<$^W> or C<perl -w>),
|
||||
and you see something like this...
|
||||
|
||||
attempt to seek on unopened filehandle
|
||||
|
||||
...then you are probably trying to use one of these functions
|
||||
on an IO::Scalar with an old Perl. The remedy is to simply
|
||||
use the OO version; e.g.:
|
||||
|
||||
$SH->seek(0,0); ### GOOD: will work on any 5.005
|
||||
seek($SH,0,0); ### WARNING: will only work on 5.005_57 and beyond
|
||||
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
$Id: Scalar.pm,v 1.6 2005/02/10 21:21:53 dfs Exp $
|
||||
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=head2 Primary Maintainer
|
||||
|
||||
David F. Skoll (F<dfs@roaringpenguin.com>).
|
||||
|
||||
=head2 Principal author
|
||||
|
||||
Eryq (F<eryq@zeegee.com>).
|
||||
President, ZeeGee Software Inc (F<http://www.zeegee.com>).
|
||||
|
||||
|
||||
=head2 Other contributors
|
||||
|
||||
The full set of contributors always includes the folks mentioned
|
||||
in L<IO::Stringy/"CHANGE LOG">. But just the same, special
|
||||
thanks to the following individuals for their invaluable contributions
|
||||
(if I've forgotten or misspelled your name, please email me!):
|
||||
|
||||
I<Andy Glew,>
|
||||
for contributing C<getc()>.
|
||||
|
||||
I<Brandon Browning,>
|
||||
for suggesting C<opened()>.
|
||||
|
||||
I<David Richter,>
|
||||
for finding and fixing the bug in C<PRINTF()>.
|
||||
|
||||
I<Eric L. Brine,>
|
||||
for his offset-using read() and write() implementations.
|
||||
|
||||
I<Richard Jones,>
|
||||
for his patches to massively improve the performance of C<getline()>
|
||||
and add C<sysread> and C<syswrite>.
|
||||
|
||||
I<B. K. Oxley (binkley),>
|
||||
for stringification and inheritance improvements,
|
||||
and sundry good ideas.
|
||||
|
||||
I<Doug Wilson,>
|
||||
for the IO::Handle inheritance and automatic tie-ing.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<IO::String>, which is quite similar but which was designed
|
||||
more-recently and with an IO::Handle-like interface in mind,
|
||||
so you could mix OO- and native-filehandle usage without using tied().
|
||||
|
||||
I<Note:> as of version 2.x, these classes all work like
|
||||
their IO::Handle counterparts, so we have comparable
|
||||
functionality to IO::String.
|
||||
|
||||
=cut
|
||||
|
||||
182
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Builder/Module.pm
Normal file
182
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Builder/Module.pm
Normal file
|
|
@ -0,0 +1,182 @@
|
|||
package Test::Builder::Module;
|
||||
|
||||
use strict;
|
||||
|
||||
use Test::Builder;
|
||||
|
||||
require Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Builder::Module - Base class for test modules
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Emulates Test::Simple
|
||||
package Your::Module;
|
||||
|
||||
my $CLASS = __PACKAGE__;
|
||||
|
||||
use parent 'Test::Builder::Module';
|
||||
@EXPORT = qw(ok);
|
||||
|
||||
sub ok ($;$) {
|
||||
my $tb = $CLASS->builder;
|
||||
return $tb->ok(@_);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a superclass for L<Test::Builder>-based modules. It provides a
|
||||
handful of common functionality and a method of getting at the underlying
|
||||
L<Test::Builder> object.
|
||||
|
||||
|
||||
=head2 Importing
|
||||
|
||||
Test::Builder::Module is a subclass of L<Exporter> which means your
|
||||
module is also a subclass of Exporter. @EXPORT, @EXPORT_OK, etc...
|
||||
all act normally.
|
||||
|
||||
A few methods are provided to do the C<< use Your::Module tests => 23 >> part
|
||||
for you.
|
||||
|
||||
=head3 import
|
||||
|
||||
Test::Builder::Module provides an C<import()> method which acts in the
|
||||
same basic way as L<Test::More>'s, setting the plan and controlling
|
||||
exporting of functions and variables. This allows your module to set
|
||||
the plan independent of L<Test::More>.
|
||||
|
||||
All arguments passed to C<import()> are passed onto
|
||||
C<< Your::Module->builder->plan() >> with the exception of
|
||||
C<< import =>[qw(things to import)] >>.
|
||||
|
||||
use Your::Module import => [qw(this that)], tests => 23;
|
||||
|
||||
says to import the functions C<this()> and C<that()> as well as set the plan
|
||||
to be 23 tests.
|
||||
|
||||
C<import()> also sets the C<exported_to()> attribute of your builder to be
|
||||
the caller of the C<import()> function.
|
||||
|
||||
Additional behaviors can be added to your C<import()> method by overriding
|
||||
C<import_extra()>.
|
||||
|
||||
=cut
|
||||
|
||||
sub import {
|
||||
my($class) = shift;
|
||||
|
||||
Test2::API::test2_load() unless Test2::API::test2_in_preload();
|
||||
|
||||
# Don't run all this when loading ourself.
|
||||
return 1 if $class eq 'Test::Builder::Module';
|
||||
|
||||
my $test = $class->builder;
|
||||
|
||||
my $caller = caller;
|
||||
|
||||
$test->exported_to($caller);
|
||||
|
||||
$class->import_extra( \@_ );
|
||||
my(@imports) = $class->_strip_imports( \@_ );
|
||||
|
||||
$test->plan(@_);
|
||||
|
||||
local $Exporter::ExportLevel = $Exporter::ExportLevel + 1;
|
||||
$class->Exporter::import(@imports);
|
||||
}
|
||||
|
||||
sub _strip_imports {
|
||||
my $class = shift;
|
||||
my $list = shift;
|
||||
|
||||
my @imports = ();
|
||||
my @other = ();
|
||||
my $idx = 0;
|
||||
while( $idx <= $#{$list} ) {
|
||||
my $item = $list->[$idx];
|
||||
|
||||
if( defined $item and $item eq 'import' ) {
|
||||
push @imports, @{ $list->[ $idx + 1 ] };
|
||||
$idx++;
|
||||
}
|
||||
else {
|
||||
push @other, $item;
|
||||
}
|
||||
|
||||
$idx++;
|
||||
}
|
||||
|
||||
@$list = @other;
|
||||
|
||||
return @imports;
|
||||
}
|
||||
|
||||
=head3 import_extra
|
||||
|
||||
Your::Module->import_extra(\@import_args);
|
||||
|
||||
C<import_extra()> is called by C<import()>. It provides an opportunity for you
|
||||
to add behaviors to your module based on its import list.
|
||||
|
||||
Any extra arguments which shouldn't be passed on to C<plan()> should be
|
||||
stripped off by this method.
|
||||
|
||||
See L<Test::More> for an example of its use.
|
||||
|
||||
B<NOTE> This mechanism is I<VERY ALPHA AND LIKELY TO CHANGE> as it
|
||||
feels like a bit of an ugly hack in its current form.
|
||||
|
||||
=cut
|
||||
|
||||
sub import_extra { }
|
||||
|
||||
=head2 Builder
|
||||
|
||||
Test::Builder::Module provides some methods of getting at the underlying
|
||||
Test::Builder object.
|
||||
|
||||
=head3 builder
|
||||
|
||||
my $builder = Your::Class->builder;
|
||||
|
||||
This method returns the L<Test::Builder> object associated with Your::Class.
|
||||
It is not a constructor so you can call it as often as you like.
|
||||
|
||||
This is the preferred way to get the L<Test::Builder> object. You should
|
||||
I<not> get it via C<< Test::Builder->new >> as was previously
|
||||
recommended.
|
||||
|
||||
The object returned by C<builder()> may change at runtime so you should
|
||||
call C<builder()> inside each function rather than store it in a global.
|
||||
|
||||
sub ok {
|
||||
my $builder = Your::Class->builder;
|
||||
|
||||
return $builder->ok(@_);
|
||||
}
|
||||
|
||||
|
||||
=cut
|
||||
|
||||
sub builder {
|
||||
return Test::Builder->new;
|
||||
}
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<< Test2::Manual::Tooling::TestBuilder >> describes the improved
|
||||
options for writing testing modules provided by L<< Test2 >>.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
675
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Builder/Tester.pm
Normal file
675
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Builder/Tester.pm
Normal file
|
|
@ -0,0 +1,675 @@
|
|||
package Test::Builder::Tester;
|
||||
|
||||
use strict;
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
use Test::Builder;
|
||||
use Symbol;
|
||||
use Carp;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Builder::Tester - test testsuites that have been built with
|
||||
Test::Builder
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::Builder::Tester tests => 1;
|
||||
use Test::More;
|
||||
|
||||
test_out("not ok 1 - foo");
|
||||
test_fail(+1);
|
||||
fail("foo");
|
||||
test_test("fail works");
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
A module that helps you test testing modules that are built with
|
||||
L<Test::Builder>.
|
||||
|
||||
The testing system is designed to be used by performing a three step
|
||||
process for each test you wish to test. This process starts with using
|
||||
C<test_out> and C<test_err> in advance to declare what the testsuite you
|
||||
are testing will output with L<Test::Builder> to stdout and stderr.
|
||||
|
||||
You then can run the test(s) from your test suite that call
|
||||
L<Test::Builder>. At this point the output of L<Test::Builder> is
|
||||
safely captured by L<Test::Builder::Tester> rather than being
|
||||
interpreted as real test output.
|
||||
|
||||
The final stage is to call C<test_test> that will simply compare what you
|
||||
predeclared to what L<Test::Builder> actually outputted, and report the
|
||||
results back with a "ok" or "not ok" (with debugging) to the normal
|
||||
output.
|
||||
|
||||
=cut
|
||||
|
||||
####
|
||||
# set up testing
|
||||
####
|
||||
|
||||
my $t = Test::Builder->new;
|
||||
|
||||
###
|
||||
# make us an exporter
|
||||
###
|
||||
|
||||
use Exporter;
|
||||
our @ISA = qw(Exporter);
|
||||
|
||||
our @EXPORT = qw(test_out test_err test_fail test_diag test_test line_num);
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
my(@plan) = @_;
|
||||
|
||||
my $caller = caller;
|
||||
|
||||
$t->exported_to($caller);
|
||||
$t->plan(@plan);
|
||||
|
||||
my @imports = ();
|
||||
foreach my $idx ( 0 .. $#plan ) {
|
||||
if( $plan[$idx] eq 'import' ) {
|
||||
@imports = @{ $plan[ $idx + 1 ] };
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
__PACKAGE__->export_to_level( 1, __PACKAGE__, @imports );
|
||||
}
|
||||
|
||||
###
|
||||
# set up file handles
|
||||
###
|
||||
|
||||
# create some private file handles
|
||||
my $output_handle = gensym;
|
||||
my $error_handle = gensym;
|
||||
|
||||
# and tie them to this package
|
||||
my $out = tie *$output_handle, "Test::Builder::Tester::Tie", "STDOUT";
|
||||
my $err = tie *$error_handle, "Test::Builder::Tester::Tie", "STDERR";
|
||||
|
||||
####
|
||||
# exported functions
|
||||
####
|
||||
|
||||
# for remembering that we're testing and where we're testing at
|
||||
my $testing = 0;
|
||||
my $testing_num;
|
||||
my $original_is_passing;
|
||||
|
||||
# remembering where the file handles were originally connected
|
||||
my $original_output_handle;
|
||||
my $original_failure_handle;
|
||||
my $original_todo_handle;
|
||||
my $original_formatter;
|
||||
|
||||
my $original_harness_env;
|
||||
|
||||
# function that starts testing and redirects the filehandles for now
|
||||
sub _start_testing {
|
||||
# Hack for things that conditioned on Test-Stream being loaded
|
||||
$INC{'Test/Stream.pm'} ||= 'fake' if $INC{'Test/Moose/More.pm'};
|
||||
# even if we're running under Test::Harness pretend we're not
|
||||
# for now. This needed so Test::Builder doesn't add extra spaces
|
||||
$original_harness_env = $ENV{HARNESS_ACTIVE} || 0;
|
||||
$ENV{HARNESS_ACTIVE} = 0;
|
||||
|
||||
my $hub = $t->{Hub} || ($t->{Stack} ? $t->{Stack}->top : Test2::API::test2_stack->top);
|
||||
$original_formatter = $hub->format;
|
||||
unless ($original_formatter && $original_formatter->isa('Test::Builder::Formatter')) {
|
||||
my $fmt = Test::Builder::Formatter->new;
|
||||
$hub->format($fmt);
|
||||
}
|
||||
|
||||
# remember what the handles were set to
|
||||
$original_output_handle = $t->output();
|
||||
$original_failure_handle = $t->failure_output();
|
||||
$original_todo_handle = $t->todo_output();
|
||||
|
||||
# switch out to our own handles
|
||||
$t->output($output_handle);
|
||||
$t->failure_output($error_handle);
|
||||
$t->todo_output($output_handle);
|
||||
|
||||
# clear the expected list
|
||||
$out->reset();
|
||||
$err->reset();
|
||||
|
||||
# remember that we're testing
|
||||
$testing = 1;
|
||||
$testing_num = $t->current_test;
|
||||
$t->current_test(0);
|
||||
$original_is_passing = $t->is_passing;
|
||||
$t->is_passing(1);
|
||||
|
||||
# look, we shouldn't do the ending stuff
|
||||
$t->no_ending(1);
|
||||
}
|
||||
|
||||
=head2 Functions
|
||||
|
||||
These are the six methods that are exported as default.
|
||||
|
||||
=over 4
|
||||
|
||||
=item test_out
|
||||
|
||||
=item test_err
|
||||
|
||||
Procedures for predeclaring the output that your test suite is
|
||||
expected to produce until C<test_test> is called. These procedures
|
||||
automatically assume that each line terminates with "\n". So
|
||||
|
||||
test_out("ok 1","ok 2");
|
||||
|
||||
is the same as
|
||||
|
||||
test_out("ok 1\nok 2");
|
||||
|
||||
which is even the same as
|
||||
|
||||
test_out("ok 1");
|
||||
test_out("ok 2");
|
||||
|
||||
Once C<test_out> or C<test_err> (or C<test_fail> or C<test_diag>) have
|
||||
been called, all further output from L<Test::Builder> will be
|
||||
captured by L<Test::Builder::Tester>. This means that you will not
|
||||
be able perform further tests to the normal output in the normal way
|
||||
until you call C<test_test> (well, unless you manually meddle with the
|
||||
output filehandles)
|
||||
|
||||
=cut
|
||||
|
||||
sub test_out {
|
||||
# do we need to do any setup?
|
||||
_start_testing() unless $testing;
|
||||
|
||||
$out->expect(@_);
|
||||
}
|
||||
|
||||
sub test_err {
|
||||
# do we need to do any setup?
|
||||
_start_testing() unless $testing;
|
||||
|
||||
$err->expect(@_);
|
||||
}
|
||||
|
||||
=item test_fail
|
||||
|
||||
Because the standard failure message that L<Test::Builder> produces
|
||||
whenever a test fails will be a common occurrence in your test error
|
||||
output, and because it has changed between Test::Builder versions, rather
|
||||
than forcing you to call C<test_err> with the string all the time like
|
||||
so
|
||||
|
||||
test_err("# Failed test ($0 at line ".line_num(+1).")");
|
||||
|
||||
C<test_fail> exists as a convenience function that can be called
|
||||
instead. It takes one argument, the offset from the current line that
|
||||
the line that causes the fail is on.
|
||||
|
||||
test_fail(+1);
|
||||
|
||||
This means that the example in the synopsis could be rewritten
|
||||
more simply as:
|
||||
|
||||
test_out("not ok 1 - foo");
|
||||
test_fail(+1);
|
||||
fail("foo");
|
||||
test_test("fail works");
|
||||
|
||||
=cut
|
||||
|
||||
sub test_fail {
|
||||
# do we need to do any setup?
|
||||
_start_testing() unless $testing;
|
||||
|
||||
# work out what line we should be on
|
||||
my( $package, $filename, $line ) = caller;
|
||||
$line = $line + ( shift() || 0 ); # prevent warnings
|
||||
|
||||
# expect that on stderr
|
||||
$err->expect("# Failed test ($filename at line $line)");
|
||||
}
|
||||
|
||||
=item test_diag
|
||||
|
||||
As most of the remaining expected output to the error stream will be
|
||||
created by L<Test::Builder>'s C<diag> function, L<Test::Builder::Tester>
|
||||
provides a convenience function C<test_diag> that you can use instead of
|
||||
C<test_err>.
|
||||
|
||||
The C<test_diag> function prepends comment hashes and spacing to the
|
||||
start and newlines to the end of the expected output passed to it and
|
||||
adds it to the list of expected error output. So, instead of writing
|
||||
|
||||
test_err("# Couldn't open file");
|
||||
|
||||
you can write
|
||||
|
||||
test_diag("Couldn't open file");
|
||||
|
||||
Remember that L<Test::Builder>'s diag function will not add newlines to
|
||||
the end of output and test_diag will. So to check
|
||||
|
||||
Test::Builder->new->diag("foo\n","bar\n");
|
||||
|
||||
You would do
|
||||
|
||||
test_diag("foo","bar")
|
||||
|
||||
without the newlines.
|
||||
|
||||
=cut
|
||||
|
||||
sub test_diag {
|
||||
# do we need to do any setup?
|
||||
_start_testing() unless $testing;
|
||||
|
||||
# expect the same thing, but prepended with "# "
|
||||
local $_;
|
||||
$err->expect( map { "# $_" } @_ );
|
||||
}
|
||||
|
||||
=item test_test
|
||||
|
||||
Actually performs the output check testing the tests, comparing the
|
||||
data (with C<eq>) that we have captured from L<Test::Builder> against
|
||||
what was declared with C<test_out> and C<test_err>.
|
||||
|
||||
This takes name/value pairs that effect how the test is run.
|
||||
|
||||
=over
|
||||
|
||||
=item title (synonym 'name', 'label')
|
||||
|
||||
The name of the test that will be displayed after the C<ok> or C<not
|
||||
ok>.
|
||||
|
||||
=item skip_out
|
||||
|
||||
Setting this to a true value will cause the test to ignore if the
|
||||
output sent by the test to the output stream does not match that
|
||||
declared with C<test_out>.
|
||||
|
||||
=item skip_err
|
||||
|
||||
Setting this to a true value will cause the test to ignore if the
|
||||
output sent by the test to the error stream does not match that
|
||||
declared with C<test_err>.
|
||||
|
||||
=back
|
||||
|
||||
As a convenience, if only one argument is passed then this argument
|
||||
is assumed to be the name of the test (as in the above examples.)
|
||||
|
||||
Once C<test_test> has been run test output will be redirected back to
|
||||
the original filehandles that L<Test::Builder> was connected to
|
||||
(probably STDOUT and STDERR,) meaning any further tests you run
|
||||
will function normally and cause success/errors for L<Test::Harness>.
|
||||
|
||||
=cut
|
||||
|
||||
sub test_test {
|
||||
# END the hack
|
||||
delete $INC{'Test/Stream.pm'} if $INC{'Test/Stream.pm'} && $INC{'Test/Stream.pm'} eq 'fake';
|
||||
# decode the arguments 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;
|
||||
|
||||
|
||||
my $hub = $t->{Hub} || Test2::API::test2_stack->top;
|
||||
$hub->format($original_formatter);
|
||||
|
||||
# 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;
|
||||
$t->is_passing($original_is_passing);
|
||||
|
||||
# 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 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 C<test_test> can colour the background of the debug
|
||||
information to disambiguate the different types of output. The debug
|
||||
output will have its 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
|
||||
L<Text::Builder::Tester::Color> module like so:
|
||||
|
||||
perl -Mlib=Text::Builder::Tester::Color test.t
|
||||
|
||||
Or by including the L<Test::Builder::Tester::Color> module directly in
|
||||
the PERL5LIB.
|
||||
|
||||
=cut
|
||||
|
||||
my $color;
|
||||
|
||||
sub color {
|
||||
$color = shift if @_;
|
||||
$color;
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Test::Builder::Tester does not handle plans well. It has never done anything
|
||||
special with plans. This means that plans from outside Test::Builder::Tester
|
||||
will effect Test::Builder::Tester, worse plans when using Test::Builder::Tester
|
||||
will effect overall testing. At this point there are no plans to fix this bug
|
||||
as people have come to depend on it, and Test::Builder::Tester is now
|
||||
discouraged in favor of C<Test2::API::intercept()>. See
|
||||
L<https://github.com/Test-More/test-more/issues/667>
|
||||
|
||||
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 L<Term::ANSIColor> is
|
||||
compatible with your terminal. Additionally, L<Win32::Console::ANSI>
|
||||
must be installed on windows platforms for color output.
|
||||
|
||||
Bugs (and requests for new features) can be reported to the author
|
||||
though GitHub:
|
||||
L<https://github.com/Test-More/test-more/issues>
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002, 2004.
|
||||
|
||||
Some code taken from L<Test::More> and L<Test::Catch>, written by
|
||||
Michael G Schwern E<lt>schwern@pobox.comE<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 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
Thanks to Richard Clamp E<lt>richardc@unixbeard.netE<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->_account_for_subtest($check);
|
||||
$check = $self->_translate_Failed_check($check);
|
||||
push @{ $self->{wanted} }, ref $check ? $check : "$check\n";
|
||||
}
|
||||
}
|
||||
|
||||
sub _account_for_subtest {
|
||||
my( $self, $check ) = @_;
|
||||
|
||||
my $hub = $t->{Stack}->top;
|
||||
my $nesting = $hub->isa('Test2::Hub::Subtest') ? $hub->nested : 0;
|
||||
return ref($check) ? $check : (' ' x $nesting) . $check;
|
||||
}
|
||||
|
||||
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 '', @{ $self->wanted };
|
||||
|
||||
# are we running in colour mode?
|
||||
if(Test::Builder::Tester::color) {
|
||||
# get color
|
||||
eval { require Term::ANSIColor };
|
||||
unless($@) {
|
||||
eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms
|
||||
|
||||
# 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;
|
||||
}
|
||||
}
|
||||
|
||||
my @got = split "\n", $got;
|
||||
my @wanted = split "\n", $wanted;
|
||||
|
||||
$got = "";
|
||||
$wanted = "";
|
||||
|
||||
while (@got || @wanted) {
|
||||
my $g = shift @got || "";
|
||||
my $w = shift @wanted || "";
|
||||
if ($g ne $w) {
|
||||
if($g =~ s/(\s+)$/ |> /g) {
|
||||
$g .= ($_ eq ' ' ? '_' : '\t') for split '', $1;
|
||||
}
|
||||
if($w =~ s/(\s+)$/ |> /g) {
|
||||
$w .= ($_ eq ' ' ? '_' : '\t') for split '', $1;
|
||||
}
|
||||
$g = "> $g";
|
||||
$w = "> $w";
|
||||
}
|
||||
else {
|
||||
$g = " $g";
|
||||
$w = " $w";
|
||||
}
|
||||
$got = $got ? "$got\n$g" : $g;
|
||||
$wanted = $wanted ? "$wanted\n$w" : $w;
|
||||
}
|
||||
|
||||
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;
|
||||
|
|
@ -0,0 +1,51 @@
|
|||
package Test::Builder::Tester::Color;
|
||||
|
||||
use strict;
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
require Test::Builder::Tester;
|
||||
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Builder::Tester::Color - turn on colour in Test::Builder::Tester
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
When running a test script
|
||||
|
||||
perl -MTest::Builder::Tester::Color test.t
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Importing this module causes the subroutine color in Test::Builder::Tester
|
||||
to be called with a true value causing colour highlighting to be turned
|
||||
on in debug output.
|
||||
|
||||
The sole purpose of this module is to enable colour highlighting
|
||||
from the command line.
|
||||
|
||||
=cut
|
||||
|
||||
sub import {
|
||||
Test::Builder::Tester::color(1);
|
||||
}
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright Mark Fowler E<lt>mark@twoshortplanks.comE<gt> 2002.
|
||||
|
||||
This program is free software; you can redistribute it
|
||||
and/or modify it under the same terms as Perl itself.
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
This module will have no effect unless Term::ANSIColor is installed.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Test::Builder::Tester>, L<Term::ANSIColor>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
|
|
@ -0,0 +1,68 @@
|
|||
package Test::Builder::TodoDiag;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) }
|
||||
|
||||
sub diagnostics { 0 }
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
my $out = $self->SUPER::facet_data();
|
||||
$out->{info}->[0]->{debug} = 0;
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Builder::TodoDiag - Test::Builder subclass of Test2::Event::Diag
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is used to encapsulate diag messages created inside TODO.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
You do not need to use this directly.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
L<https://github.com/Test-More/test-more/>.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
See L<https://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
618
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Harness.pm
Normal file
618
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Harness.pm
Normal file
|
|
@ -0,0 +1,618 @@
|
|||
package Test::Harness;
|
||||
|
||||
use 5.006;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use constant IS_WIN32 => ( $^O =~ /^(MS)?Win32$/ );
|
||||
use constant IS_VMS => ( $^O eq 'VMS' );
|
||||
|
||||
use TAP::Harness ();
|
||||
use TAP::Parser::Aggregator ();
|
||||
use TAP::Parser::Source ();
|
||||
use TAP::Parser::SourceHandler::Perl ();
|
||||
|
||||
use Text::ParseWords qw(shellwords);
|
||||
|
||||
use Config;
|
||||
use base 'Exporter';
|
||||
|
||||
# $ML $Last_ML_Print
|
||||
|
||||
BEGIN {
|
||||
eval q{use Time::HiRes 'time'};
|
||||
our $has_time_hires = !$@;
|
||||
}
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Harness - Run Perl standard test scripts with statistics
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
Version 3.48
|
||||
|
||||
=cut
|
||||
|
||||
our $VERSION = '3.48';
|
||||
|
||||
# Backwards compatibility for exportable variable names.
|
||||
*verbose = *Verbose;
|
||||
*switches = *Switches;
|
||||
*debug = *Debug;
|
||||
|
||||
$ENV{HARNESS_ACTIVE} = 1;
|
||||
$ENV{HARNESS_VERSION} = $VERSION;
|
||||
|
||||
END {
|
||||
|
||||
# For VMS.
|
||||
delete $ENV{HARNESS_ACTIVE};
|
||||
delete $ENV{HARNESS_VERSION};
|
||||
}
|
||||
|
||||
our @EXPORT = qw(&runtests);
|
||||
our @EXPORT_OK = qw(&execute_tests $verbose $switches);
|
||||
|
||||
our $Verbose = $ENV{HARNESS_VERBOSE} || 0;
|
||||
our $Debug = $ENV{HARNESS_DEBUG} || 0;
|
||||
our $Switches = '-w';
|
||||
our $Columns = $ENV{HARNESS_COLUMNS} || $ENV{COLUMNS} || 80;
|
||||
$Columns--; # Some shells have trouble with a full line of text.
|
||||
our $Timer = $ENV{HARNESS_TIMER} || 0;
|
||||
our $Color = $ENV{HARNESS_COLOR} || 0;
|
||||
our $IgnoreExit = $ENV{HARNESS_IGNORE_EXIT} || 0;
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::Harness;
|
||||
|
||||
runtests(@test_files);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Although, for historical reasons, the L<Test::Harness> distribution
|
||||
takes its name from this module it now exists only to provide
|
||||
L<TAP::Harness> with an interface that is somewhat backwards compatible
|
||||
with L<Test::Harness> 2.xx. If you're writing new code consider using
|
||||
L<TAP::Harness> directly instead.
|
||||
|
||||
Emulation is provided for C<runtests> and C<execute_tests> but the
|
||||
pluggable 'Straps' interface that previous versions of L<Test::Harness>
|
||||
supported is not reproduced here. Straps is now available as a stand
|
||||
alone module: L<Test::Harness::Straps>.
|
||||
|
||||
See L<TAP::Parser>, L<TAP::Harness> for the main documentation for this
|
||||
distribution.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
The following functions are available.
|
||||
|
||||
=head2 runtests( @test_files )
|
||||
|
||||
This runs all the given I<@test_files> and divines whether they passed
|
||||
or failed based on their output to STDOUT (details above). It prints
|
||||
out each individual test which failed along with a summary report and
|
||||
a how long it all took.
|
||||
|
||||
It returns true if everything was ok. Otherwise it will C<die()> with
|
||||
one of the messages in the DIAGNOSTICS section.
|
||||
|
||||
=cut
|
||||
|
||||
sub _has_taint {
|
||||
my $test = shift;
|
||||
return TAP::Parser::SourceHandler::Perl->get_taint(
|
||||
TAP::Parser::Source->shebang($test) );
|
||||
}
|
||||
|
||||
sub _aggregate {
|
||||
my ( $harness, $aggregate, @tests ) = @_;
|
||||
|
||||
# Don't propagate to our children
|
||||
local $ENV{HARNESS_OPTIONS};
|
||||
|
||||
_apply_extra_INC($harness);
|
||||
_aggregate_tests( $harness, $aggregate, @tests );
|
||||
}
|
||||
|
||||
# Make sure the child sees all the extra junk in @INC
|
||||
sub _apply_extra_INC {
|
||||
my $harness = shift;
|
||||
|
||||
$harness->callback(
|
||||
parser_args => sub {
|
||||
my ( $args, $test ) = @_;
|
||||
push @{ $args->{switches} }, map {"-I$_"} _filtered_inc();
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
sub _aggregate_tests {
|
||||
my ( $harness, $aggregate, @tests ) = @_;
|
||||
$aggregate->start();
|
||||
$harness->aggregate_tests( $aggregate, @tests );
|
||||
$aggregate->stop();
|
||||
|
||||
}
|
||||
|
||||
sub runtests {
|
||||
my @tests = @_;
|
||||
|
||||
# shield against -l
|
||||
local ( $\, $, );
|
||||
|
||||
my $harness = _new_harness();
|
||||
my $aggregate = TAP::Parser::Aggregator->new();
|
||||
|
||||
local $ENV{PERL_USE_UNSAFE_INC} = 1 if not exists $ENV{PERL_USE_UNSAFE_INC};
|
||||
_aggregate( $harness, $aggregate, @tests );
|
||||
|
||||
$harness->formatter->summary($aggregate);
|
||||
|
||||
my $total = $aggregate->total;
|
||||
my $passed = $aggregate->passed;
|
||||
my $failed = $aggregate->failed;
|
||||
|
||||
my @parsers = $aggregate->parsers;
|
||||
|
||||
my $num_bad = 0;
|
||||
for my $parser (@parsers) {
|
||||
$num_bad++ if $parser->has_problems;
|
||||
}
|
||||
|
||||
die(sprintf(
|
||||
"Failed %d/%d test programs. %d/%d subtests failed.\n",
|
||||
$num_bad, scalar @parsers, $failed, $total
|
||||
)
|
||||
) if $num_bad;
|
||||
|
||||
return $total && $total == $passed;
|
||||
}
|
||||
|
||||
sub _canon {
|
||||
my @list = sort { $a <=> $b } @_;
|
||||
my @ranges = ();
|
||||
my $count = scalar @list;
|
||||
my $pos = 0;
|
||||
|
||||
while ( $pos < $count ) {
|
||||
my $end = $pos + 1;
|
||||
$end++ while $end < $count && $list[$end] <= $list[ $end - 1 ] + 1;
|
||||
push @ranges, ( $end == $pos + 1 )
|
||||
? $list[$pos]
|
||||
: join( '-', $list[$pos], $list[ $end - 1 ] );
|
||||
$pos = $end;
|
||||
}
|
||||
|
||||
return join( ' ', @ranges );
|
||||
}
|
||||
|
||||
sub _new_harness {
|
||||
my $sub_args = shift || {};
|
||||
|
||||
my ( @lib, @switches );
|
||||
my @opt = map { shellwords($_) } grep { defined } $Switches, $ENV{HARNESS_PERL_SWITCHES};
|
||||
while ( my $opt = shift @opt ) {
|
||||
if ( $opt =~ /^ -I (.*) $ /x ) {
|
||||
push @lib, length($1) ? $1 : shift @opt;
|
||||
}
|
||||
else {
|
||||
push @switches, $opt;
|
||||
}
|
||||
}
|
||||
|
||||
# Do things the old way on VMS...
|
||||
push @lib, _filtered_inc() if IS_VMS;
|
||||
|
||||
# If $Verbose isn't numeric default to 1. This helps core.
|
||||
my $verbosity = ( $Verbose ? ( $Verbose !~ /\d/ ) ? 1 : $Verbose : 0 );
|
||||
|
||||
my $args = {
|
||||
timer => $Timer,
|
||||
directives => our $Directives,
|
||||
lib => \@lib,
|
||||
switches => \@switches,
|
||||
color => $Color,
|
||||
verbosity => $verbosity,
|
||||
ignore_exit => $IgnoreExit,
|
||||
};
|
||||
|
||||
$args->{stdout} = $sub_args->{out}
|
||||
if exists $sub_args->{out};
|
||||
|
||||
my $class = $ENV{HARNESS_SUBCLASS} || 'TAP::Harness';
|
||||
if ( defined( my $env_opt = $ENV{HARNESS_OPTIONS} ) ) {
|
||||
for my $opt ( split /:/, $env_opt ) {
|
||||
if ( $opt =~ /^j(\d*)$/ ) {
|
||||
$args->{jobs} = $1 || 9;
|
||||
}
|
||||
elsif ( $opt eq 'c' ) {
|
||||
$args->{color} = 1;
|
||||
}
|
||||
elsif ( $opt =~ m/^f(.*)$/ ) {
|
||||
my $fmt = $1;
|
||||
$fmt =~ s/-/::/g;
|
||||
$args->{formatter_class} = $fmt;
|
||||
}
|
||||
elsif ( $opt =~ m/^a(.*)$/ ) {
|
||||
my $archive = $1;
|
||||
$class = "TAP::Harness::Archive";
|
||||
$args->{archive} = $archive;
|
||||
}
|
||||
else {
|
||||
die "Unknown HARNESS_OPTIONS item: $opt\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
return TAP::Harness->_construct( $class, $args );
|
||||
}
|
||||
|
||||
# Get the parts of @INC which are changed from the stock list AND
|
||||
# preserve reordering of stock directories.
|
||||
sub _filtered_inc {
|
||||
my @inc = grep { !ref } @INC; #28567
|
||||
|
||||
if (IS_VMS) {
|
||||
|
||||
# VMS has a 255-byte limit on the length of %ENV entries, so
|
||||
# toss the ones that involve perl_root, the install location
|
||||
@inc = grep !/perl_root/i, @inc;
|
||||
|
||||
}
|
||||
elsif (IS_WIN32) {
|
||||
|
||||
# Lose any trailing backslashes in the Win32 paths
|
||||
s/[\\\/]+$// for @inc;
|
||||
}
|
||||
|
||||
my @default_inc = _default_inc();
|
||||
|
||||
my @new_inc;
|
||||
my %seen;
|
||||
for my $dir (@inc) {
|
||||
next if $seen{$dir}++;
|
||||
|
||||
if ( $dir eq ( $default_inc[0] || '' ) ) {
|
||||
shift @default_inc;
|
||||
}
|
||||
else {
|
||||
push @new_inc, $dir;
|
||||
}
|
||||
|
||||
shift @default_inc while @default_inc and $seen{ $default_inc[0] };
|
||||
}
|
||||
|
||||
return @new_inc;
|
||||
}
|
||||
|
||||
{
|
||||
|
||||
# Cache this to avoid repeatedly shelling out to Perl.
|
||||
my @inc;
|
||||
|
||||
sub _default_inc {
|
||||
return @inc if @inc;
|
||||
|
||||
local $ENV{PERL5LIB};
|
||||
local $ENV{PERLLIB};
|
||||
|
||||
my $perl = $ENV{HARNESS_PERL} || $^X;
|
||||
|
||||
# Avoid using -l for the benefit of Perl 6
|
||||
chomp( @inc = `"$perl" -e "print join qq[\\n], \@INC, q[]"` );
|
||||
return @inc;
|
||||
}
|
||||
}
|
||||
|
||||
sub _check_sequence {
|
||||
my @list = @_;
|
||||
my $prev;
|
||||
while ( my $next = shift @list ) {
|
||||
return if defined $prev && $next <= $prev;
|
||||
$prev = $next;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub execute_tests {
|
||||
my %args = @_;
|
||||
|
||||
my $harness = _new_harness( \%args );
|
||||
my $aggregate = TAP::Parser::Aggregator->new();
|
||||
|
||||
my %tot = (
|
||||
bonus => 0,
|
||||
max => 0,
|
||||
ok => 0,
|
||||
bad => 0,
|
||||
good => 0,
|
||||
files => 0,
|
||||
tests => 0,
|
||||
sub_skipped => 0,
|
||||
todo => 0,
|
||||
skipped => 0,
|
||||
bench => undef,
|
||||
);
|
||||
|
||||
# Install a callback so we get to see any plans the
|
||||
# harness executes.
|
||||
$harness->callback(
|
||||
made_parser => sub {
|
||||
my $parser = shift;
|
||||
$parser->callback(
|
||||
plan => sub {
|
||||
my $plan = shift;
|
||||
if ( $plan->directive eq 'SKIP' ) {
|
||||
$tot{skipped}++;
|
||||
}
|
||||
}
|
||||
);
|
||||
}
|
||||
);
|
||||
|
||||
local $ENV{PERL_USE_UNSAFE_INC} = 1 if not exists $ENV{PERL_USE_UNSAFE_INC};
|
||||
_aggregate( $harness, $aggregate, @{ $args{tests} } );
|
||||
|
||||
$tot{bench} = $aggregate->elapsed;
|
||||
my @tests = $aggregate->descriptions;
|
||||
|
||||
# TODO: Work out the circumstances under which the files
|
||||
# and tests totals can differ.
|
||||
$tot{files} = $tot{tests} = scalar @tests;
|
||||
|
||||
my %failedtests = ();
|
||||
my %todo_passed = ();
|
||||
|
||||
for my $test (@tests) {
|
||||
my ($parser) = $aggregate->parsers($test);
|
||||
|
||||
my @failed = $parser->failed;
|
||||
|
||||
my $wstat = $parser->wait;
|
||||
my $estat = $parser->exit;
|
||||
my $planned = $parser->tests_planned;
|
||||
my @errors = $parser->parse_errors;
|
||||
my $passed = $parser->passed;
|
||||
my $actual_passed = $parser->actual_passed;
|
||||
|
||||
my $ok_seq = _check_sequence( $parser->actual_passed );
|
||||
|
||||
# Duplicate exit, wait status semantics of old version
|
||||
$estat ||= '' unless $wstat;
|
||||
$wstat ||= '';
|
||||
|
||||
$tot{max} += ( $planned || 0 );
|
||||
$tot{bonus} += $parser->todo_passed;
|
||||
$tot{ok} += $passed > $actual_passed ? $passed : $actual_passed;
|
||||
$tot{sub_skipped} += $parser->skipped;
|
||||
$tot{todo} += $parser->todo;
|
||||
|
||||
if ( @failed || $estat || @errors ) {
|
||||
$tot{bad}++;
|
||||
|
||||
my $huh_planned = $planned ? undef : '??';
|
||||
my $huh_errors = $ok_seq ? undef : '??';
|
||||
|
||||
$failedtests{$test} = {
|
||||
'canon' => $huh_planned
|
||||
|| $huh_errors
|
||||
|| _canon(@failed)
|
||||
|| '??',
|
||||
'estat' => $estat,
|
||||
'failed' => $huh_planned
|
||||
|| $huh_errors
|
||||
|| scalar @failed,
|
||||
'max' => $huh_planned || $planned,
|
||||
'name' => $test,
|
||||
'wstat' => $wstat
|
||||
};
|
||||
}
|
||||
else {
|
||||
$tot{good}++;
|
||||
}
|
||||
|
||||
my @todo = $parser->todo_passed;
|
||||
if (@todo) {
|
||||
$todo_passed{$test} = {
|
||||
'canon' => _canon(@todo),
|
||||
'estat' => $estat,
|
||||
'failed' => scalar @todo,
|
||||
'max' => scalar $parser->todo,
|
||||
'name' => $test,
|
||||
'wstat' => $wstat
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
return ( \%tot, \%failedtests, \%todo_passed );
|
||||
}
|
||||
|
||||
=head2 execute_tests( tests => \@test_files, out => \*FH )
|
||||
|
||||
Runs all the given C<@test_files> (just like C<runtests()>) but
|
||||
doesn't generate the final report. During testing, progress
|
||||
information will be written to the currently selected output
|
||||
filehandle (usually C<STDOUT>), or to the filehandle given by the
|
||||
C<out> parameter. The I<out> is optional.
|
||||
|
||||
Returns a list of two values, C<$total> and C<$failed>, describing the
|
||||
results. C<$total> is a hash ref summary of all the tests run. Its
|
||||
keys and values are this:
|
||||
|
||||
bonus Number of individual todo tests unexpectedly passed
|
||||
max Number of individual tests ran
|
||||
ok Number of individual tests passed
|
||||
sub_skipped Number of individual tests skipped
|
||||
todo Number of individual todo tests
|
||||
|
||||
files Number of test files ran
|
||||
good Number of test files passed
|
||||
bad Number of test files failed
|
||||
tests Number of test files originally given
|
||||
skipped Number of test files skipped
|
||||
|
||||
If C<< $total->{bad} == 0 >> and C<< $total->{max} > 0 >>, you've
|
||||
got a successful test.
|
||||
|
||||
C<$failed> is a hash ref of all the test scripts that failed. Each key
|
||||
is the name of a test script, each value is another hash representing
|
||||
how that script failed. Its keys are these:
|
||||
|
||||
name Name of the test which failed
|
||||
estat Script's exit value
|
||||
wstat Script's wait status
|
||||
max Number of individual tests
|
||||
failed Number which failed
|
||||
canon List of tests which failed (as string).
|
||||
|
||||
C<$failed> should be empty if everything passed.
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
__END__
|
||||
|
||||
=head1 EXPORT
|
||||
|
||||
C<&runtests> is exported by C<Test::Harness> by default.
|
||||
|
||||
C<&execute_tests>, C<$verbose>, C<$switches> and C<$debug> are
|
||||
exported upon request.
|
||||
|
||||
=head1 ENVIRONMENT VARIABLES THAT TAP::HARNESS::COMPATIBLE SETS
|
||||
|
||||
C<Test::Harness> sets these before executing the individual tests.
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<HARNESS_ACTIVE>
|
||||
|
||||
This is set to a true value. It allows the tests to determine if they
|
||||
are being executed through the harness or by any other means.
|
||||
|
||||
=item C<HARNESS_VERSION>
|
||||
|
||||
This is the version of C<Test::Harness>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 ENVIRONMENT VARIABLES THAT AFFECT TEST::HARNESS
|
||||
|
||||
=over 4
|
||||
|
||||
=item C<HARNESS_PERL_SWITCHES>
|
||||
|
||||
Setting this adds perl command line switches to each test file run.
|
||||
|
||||
For example, C<HARNESS_PERL_SWITCHES=-T> will turn on taint mode.
|
||||
C<HARNESS_PERL_SWITCHES=-MDevel::Cover> will run C<Devel::Cover> for
|
||||
each test.
|
||||
|
||||
C<-w> is always set. You can turn this off in the test with C<BEGIN {
|
||||
$^W = 0 }>.
|
||||
|
||||
=item C<HARNESS_TIMER>
|
||||
|
||||
Setting this to true will make the harness display the number of
|
||||
milliseconds each test took. You can also use F<prove>'s C<--timer>
|
||||
switch.
|
||||
|
||||
=item C<HARNESS_VERBOSE>
|
||||
|
||||
If true, C<Test::Harness> will output the verbose results of running
|
||||
its tests. Setting C<$Test::Harness::verbose> will override this,
|
||||
or you can use the C<-v> switch in the F<prove> utility.
|
||||
|
||||
=item C<HARNESS_OPTIONS>
|
||||
|
||||
Provide additional options to the harness. Currently supported options are:
|
||||
|
||||
=over
|
||||
|
||||
=item C<< j<n> >>
|
||||
|
||||
Run <n> (default 9) parallel jobs.
|
||||
|
||||
=item C<< c >>
|
||||
|
||||
Try to color output. See L<TAP::Formatter::Base/"new">.
|
||||
|
||||
=item C<< a<file.tgz> >>
|
||||
|
||||
Will use L<TAP::Harness::Archive> as the harness class, and save the TAP to
|
||||
C<file.tgz>
|
||||
|
||||
=item C<< fPackage-With-Dashes >>
|
||||
|
||||
Set the formatter_class of the harness being run. Since the C<HARNESS_OPTIONS>
|
||||
is separated by C<:>, we use C<-> instead.
|
||||
|
||||
=back
|
||||
|
||||
Multiple options may be separated by colons:
|
||||
|
||||
HARNESS_OPTIONS=j9:c make test
|
||||
|
||||
=item C<HARNESS_SUBCLASS>
|
||||
|
||||
Specifies a TAP::Harness subclass to be used in place of TAP::Harness.
|
||||
|
||||
=item C<HARNESS_SUMMARY_COLOR_SUCCESS>
|
||||
|
||||
Determines the L<Term::ANSIColor> for the summary in case it is successful.
|
||||
This color defaults to C<'green'>.
|
||||
|
||||
=item C<HARNESS_SUMMARY_COLOR_FAIL>
|
||||
|
||||
Determines the L<Term::ANSIColor> for the failure in case it is successful.
|
||||
This color defaults to C<'red'>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 Taint Mode
|
||||
|
||||
Normally when a Perl program is run in taint mode the contents of the
|
||||
C<PERL5LIB> environment variable do not appear in C<@INC>.
|
||||
|
||||
Because C<PERL5LIB> is often used during testing to add build
|
||||
directories to C<@INC> C<Test::Harness> passes the names of any
|
||||
directories found in C<PERL5LIB> as -I switches. The net effect of this
|
||||
is that C<PERL5LIB> is honoured even in taint mode.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<TAP::Harness>
|
||||
|
||||
=head1 BUGS
|
||||
|
||||
Please report any bugs or feature requests to
|
||||
C<bug-test-harness at rt.cpan.org>, or through the web interface at
|
||||
L<http://rt.cpan.org/NoAuth/ReportBug.html?Queue=Test-Harness>. I will be
|
||||
notified, and then you'll automatically be notified of progress on your bug
|
||||
as I make changes.
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Andy Armstrong C<< <andy@hexten.net> >>
|
||||
|
||||
L<Test::Harness> 2.64 (maintained by Andy Lester and on which this
|
||||
module is based) has this attribution:
|
||||
|
||||
Either Tim Bunce or Andreas Koenig, we don't know. What we know for
|
||||
sure is, that it was inspired by Larry Wall's F<TEST> script that came
|
||||
with perl distributions for ages. Numerous anonymous contributors
|
||||
exist. Andreas Koenig held the torch for many years, and then
|
||||
Michael G Schwern.
|
||||
|
||||
=head1 LICENCE AND COPYRIGHT
|
||||
|
||||
Copyright (c) 2007-2011, Andy Armstrong C<< <andy@hexten.net> >>. All rights reserved.
|
||||
|
||||
This module is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself. See L<perlartistic>.
|
||||
|
||||
2043
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/More.pm
Normal file
2043
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/More.pm
Normal file
File diff suppressed because it is too large
Load diff
220
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Simple.pm
Normal file
220
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Simple.pm
Normal file
|
|
@ -0,0 +1,220 @@
|
|||
package Test::Simple;
|
||||
|
||||
use 5.006;
|
||||
|
||||
use strict;
|
||||
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
use Test::Builder::Module;
|
||||
our @ISA = qw(Test::Builder::Module);
|
||||
our @EXPORT = qw(ok);
|
||||
|
||||
my $CLASS = __PACKAGE__;
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Simple - Basic utilities for writing tests.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::Simple tests => 1;
|
||||
|
||||
ok( $foo eq $bar, 'foo is bar' );
|
||||
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
** If you are unfamiliar with testing B<read L<Test::Tutorial> first!> **
|
||||
|
||||
This is an extremely simple, extremely basic module for writing tests
|
||||
suitable for CPAN modules and other pursuits. If you wish to do more
|
||||
complicated testing, use the Test::More module (a drop-in replacement
|
||||
for this one).
|
||||
|
||||
The basic unit of Perl testing is the ok. For each thing you want to
|
||||
test your program will print out an "ok" or "not ok" to indicate pass
|
||||
or fail. You do this with the C<ok()> function (see below).
|
||||
|
||||
The only other constraint is you must pre-declare how many tests you
|
||||
plan to run. This is in case something goes horribly wrong during the
|
||||
test and your test program aborts, or skips a test or whatever. You
|
||||
do this like so:
|
||||
|
||||
use Test::Simple tests => 23;
|
||||
|
||||
You must have a plan.
|
||||
|
||||
|
||||
=over 4
|
||||
|
||||
=item B<ok>
|
||||
|
||||
ok( $foo eq $bar, $name );
|
||||
ok( $foo eq $bar );
|
||||
|
||||
C<ok()> is given an expression (in this case C<$foo eq $bar>). If it's
|
||||
true, the test passed. If it's false, it didn't. That's about it.
|
||||
|
||||
C<ok()> prints out either "ok" or "not ok" along with a test number (it
|
||||
keeps track of that for you).
|
||||
|
||||
# This produces "ok 1 - Hell not yet frozen over" (or not ok)
|
||||
ok( get_temperature($hell) > 0, 'Hell not yet frozen over' );
|
||||
|
||||
If you provide a $name, that will be printed along with the "ok/not
|
||||
ok" to make it easier to find your test when if fails (just search for
|
||||
the name). It also makes it easier for the next guy to understand
|
||||
what your test is for. It's highly recommended you use test names.
|
||||
|
||||
All tests are run in scalar context. So this:
|
||||
|
||||
ok( @stuff, 'I have some stuff' );
|
||||
|
||||
will do what you mean (fail if stuff is empty)
|
||||
|
||||
=cut
|
||||
|
||||
sub ok ($;$) { ## no critic (Subroutines::ProhibitSubroutinePrototypes)
|
||||
return $CLASS->builder->ok(@_);
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
Test::Simple will start by printing number of tests run in the form
|
||||
"1..M" (so "1..5" means you're going to run 5 tests). This strange
|
||||
format lets L<Test::Harness> know how many tests you plan on running in
|
||||
case something goes horribly wrong.
|
||||
|
||||
If all your tests passed, Test::Simple will exit with zero (which is
|
||||
normal). If anything failed it will exit with how many failed. If
|
||||
you run less (or more) tests than you planned, the missing (or extras)
|
||||
will be considered failures. If no tests were ever run Test::Simple
|
||||
will throw a warning and exit with 255. If the test died, even after
|
||||
having successfully completed all its tests, it will still be
|
||||
considered a failure and will exit with 255.
|
||||
|
||||
So the exit codes are...
|
||||
|
||||
0 all tests successful
|
||||
255 test died or all passed but wrong # of tests run
|
||||
any other number how many failed (including missing or extras)
|
||||
|
||||
If you fail more than 254 tests, it will be reported as 254.
|
||||
|
||||
This module is by no means trying to be a complete testing system.
|
||||
It's just to get you started. Once you're off the ground its
|
||||
recommended you look at L<Test::More>.
|
||||
|
||||
|
||||
=head1 EXAMPLE
|
||||
|
||||
Here's an example of a simple .t file for the fictional Film module.
|
||||
|
||||
use Test::Simple tests => 5;
|
||||
|
||||
use Film; # What you're testing.
|
||||
|
||||
my $btaste = Film->new({ Title => 'Bad Taste',
|
||||
Director => 'Peter Jackson',
|
||||
Rating => 'R',
|
||||
NumExplodingSheep => 1
|
||||
});
|
||||
ok( defined($btaste) && ref $btaste eq 'Film', 'new() works' );
|
||||
|
||||
ok( $btaste->Title eq 'Bad Taste', 'Title() get' );
|
||||
ok( $btaste->Director eq 'Peter Jackson', 'Director() get' );
|
||||
ok( $btaste->Rating eq 'R', 'Rating() get' );
|
||||
ok( $btaste->NumExplodingSheep == 1, 'NumExplodingSheep() get' );
|
||||
|
||||
It will produce output like this:
|
||||
|
||||
1..5
|
||||
ok 1 - new() works
|
||||
ok 2 - Title() get
|
||||
ok 3 - Director() get
|
||||
not ok 4 - Rating() get
|
||||
# Failed test 'Rating() get'
|
||||
# in t/film.t at line 14.
|
||||
ok 5 - NumExplodingSheep() get
|
||||
# Looks like you failed 1 tests of 5
|
||||
|
||||
Indicating the Film::Rating() method is broken.
|
||||
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Test::Simple will only report a maximum of 254 failures in its exit
|
||||
code. If this is a problem, you probably have a huge test script.
|
||||
Split it into multiple files. (Otherwise blame the Unix folks for
|
||||
using an unsigned short integer as the exit status).
|
||||
|
||||
Because VMS's exit codes are much, much different than the rest of the
|
||||
universe, and perl does horrible mangling to them that gets in my way,
|
||||
it works like this on VMS.
|
||||
|
||||
0 SS$_NORMAL all tests successful
|
||||
4 SS$_ABORT something went wrong
|
||||
|
||||
Unfortunately, I can't differentiate any further.
|
||||
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
Test::Simple is B<explicitly> tested all the way back to perl 5.6.0.
|
||||
|
||||
Test::Simple is thread-safe in perl 5.8.1 and up.
|
||||
|
||||
=head1 HISTORY
|
||||
|
||||
This module was conceived while talking with Tony Bowden in his
|
||||
kitchen one night about the problems I was having writing some really
|
||||
complicated feature into the new Testing module. He observed that the
|
||||
main problem is not dealing with these edge cases but that people hate
|
||||
to write tests B<at all>. What was needed was a dead simple module
|
||||
that took all the hard work out of testing and was really, really easy
|
||||
to learn. Paul Johnson simultaneously had this idea (unfortunately,
|
||||
he wasn't in Tony's kitchen). This is it.
|
||||
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<Test::More>
|
||||
|
||||
More testing functions! Once you outgrow Test::Simple, look at
|
||||
L<Test::More>. Test::Simple is 100% forward compatible with L<Test::More>
|
||||
(i.e. you can just use L<Test::More> instead of Test::Simple in your
|
||||
programs and things will still work).
|
||||
|
||||
=back
|
||||
|
||||
Look in L<Test::More>'s SEE ALSO for more testing modules.
|
||||
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Idea by Tony Bowden and Paul Johnson, code by Michael G Schwern
|
||||
E<lt>schwern@pobox.comE<gt>, wardrobe by Calvin Klein.
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2001-2008 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
|
||||
|
||||
This program is free software; you can redistribute it and/or
|
||||
modify it under the same terms as Perl itself.
|
||||
|
||||
See L<https://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
695
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Tester.pm
Normal file
695
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Tester.pm
Normal file
|
|
@ -0,0 +1,695 @@
|
|||
use strict;
|
||||
|
||||
package Test::Tester;
|
||||
|
||||
BEGIN
|
||||
{
|
||||
if (*Test::Builder::new{CODE})
|
||||
{
|
||||
warn "You should load Test::Tester before Test::Builder (or anything that loads Test::Builder)"
|
||||
}
|
||||
}
|
||||
|
||||
use Test::Builder;
|
||||
use Test::Tester::CaptureRunner;
|
||||
use Test::Tester::Delegate;
|
||||
|
||||
require Exporter;
|
||||
|
||||
use vars qw( @ISA @EXPORT );
|
||||
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
@EXPORT = qw( run_tests check_tests check_test cmp_results show_space );
|
||||
@ISA = qw( Exporter );
|
||||
|
||||
my $Test = Test::Builder->new;
|
||||
my $Capture = Test::Tester::Capture->new;
|
||||
my $Delegator = Test::Tester::Delegate->new;
|
||||
$Delegator->{Object} = $Test;
|
||||
|
||||
my $runner = Test::Tester::CaptureRunner->new;
|
||||
|
||||
my $want_space = $ENV{TESTTESTERSPACE};
|
||||
|
||||
sub show_space
|
||||
{
|
||||
$want_space = 1;
|
||||
}
|
||||
|
||||
my $colour = '';
|
||||
my $reset = '';
|
||||
|
||||
if (my $want_colour = $ENV{TESTTESTERCOLOUR} || $ENV{TESTTESTERCOLOR})
|
||||
{
|
||||
if (eval { require Term::ANSIColor; 1 })
|
||||
{
|
||||
eval { require Win32::Console::ANSI } if 'MSWin32' eq $^O; # support color on windows platforms
|
||||
my ($f, $b) = split(",", $want_colour);
|
||||
$colour = Term::ANSIColor::color($f).Term::ANSIColor::color("on_$b");
|
||||
$reset = Term::ANSIColor::color("reset");
|
||||
}
|
||||
|
||||
}
|
||||
|
||||
sub new_new
|
||||
{
|
||||
return $Delegator;
|
||||
}
|
||||
|
||||
sub capture
|
||||
{
|
||||
return Test::Tester::Capture->new;
|
||||
}
|
||||
|
||||
sub fh
|
||||
{
|
||||
# experiment with capturing output, I don't like it
|
||||
$runner = Test::Tester::FHRunner->new;
|
||||
|
||||
return $Test;
|
||||
}
|
||||
|
||||
sub find_run_tests
|
||||
{
|
||||
my $d = 1;
|
||||
my $found = 0;
|
||||
while ((not $found) and (my ($sub) = (caller($d))[3]) )
|
||||
{
|
||||
# print "$d: $sub\n";
|
||||
$found = ($sub eq "Test::Tester::run_tests");
|
||||
$d++;
|
||||
}
|
||||
|
||||
# die "Didn't find 'run_tests' in caller stack" unless $found;
|
||||
return $d;
|
||||
}
|
||||
|
||||
sub run_tests
|
||||
{
|
||||
local($Delegator->{Object}) = $Capture;
|
||||
|
||||
$runner->run_tests(@_);
|
||||
|
||||
return ($runner->get_premature, $runner->get_results);
|
||||
}
|
||||
|
||||
sub check_test
|
||||
{
|
||||
my $test = shift;
|
||||
my $expect = shift;
|
||||
my $name = shift;
|
||||
$name = "" unless defined($name);
|
||||
|
||||
@_ = ($test, [$expect], $name);
|
||||
goto &check_tests;
|
||||
}
|
||||
|
||||
sub check_tests
|
||||
{
|
||||
my $test = shift;
|
||||
my $expects = shift;
|
||||
my $name = shift;
|
||||
$name = "" unless defined($name);
|
||||
|
||||
my ($prem, @results) = eval { run_tests($test, $name) };
|
||||
|
||||
$Test->ok(! $@, "Test '$name' completed") || $Test->diag($@);
|
||||
$Test->ok(! length($prem), "Test '$name' no premature diagnostication") ||
|
||||
$Test->diag("Before any testing anything, your tests said\n$prem");
|
||||
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
cmp_results(\@results, $expects, $name);
|
||||
return ($prem, @results);
|
||||
}
|
||||
|
||||
sub cmp_field
|
||||
{
|
||||
my ($result, $expect, $field, $desc) = @_;
|
||||
|
||||
if (defined $expect->{$field})
|
||||
{
|
||||
$Test->is_eq($result->{$field}, $expect->{$field},
|
||||
"$desc compare $field");
|
||||
}
|
||||
}
|
||||
|
||||
sub cmp_result
|
||||
{
|
||||
my ($result, $expect, $name) = @_;
|
||||
|
||||
my $sub_name = $result->{name};
|
||||
$sub_name = "" unless defined($name);
|
||||
|
||||
my $desc = "subtest '$sub_name' of '$name'";
|
||||
|
||||
{
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
|
||||
cmp_field($result, $expect, "ok", $desc);
|
||||
|
||||
cmp_field($result, $expect, "actual_ok", $desc);
|
||||
|
||||
cmp_field($result, $expect, "type", $desc);
|
||||
|
||||
cmp_field($result, $expect, "reason", $desc);
|
||||
|
||||
cmp_field($result, $expect, "name", $desc);
|
||||
}
|
||||
|
||||
# if we got no depth then default to 1
|
||||
my $depth = 1;
|
||||
if (exists $expect->{depth})
|
||||
{
|
||||
$depth = $expect->{depth};
|
||||
}
|
||||
|
||||
# if depth was explicitly undef then don't test it
|
||||
if (defined $depth)
|
||||
{
|
||||
$Test->is_eq($result->{depth}, $depth, "checking depth") ||
|
||||
$Test->diag('You need to change $Test::Builder::Level');
|
||||
}
|
||||
|
||||
if (defined(my $exp = $expect->{diag}))
|
||||
{
|
||||
|
||||
my $got = '';
|
||||
if (ref $exp eq 'Regexp') {
|
||||
|
||||
if (not $Test->like($result->{diag}, $exp,
|
||||
"subtest '$sub_name' of '$name' compare diag"))
|
||||
{
|
||||
$got = $result->{diag};
|
||||
}
|
||||
|
||||
} else {
|
||||
|
||||
# if there actually is some diag then put a \n on the end if it's not
|
||||
# there already
|
||||
$exp .= "\n" if (length($exp) and $exp !~ /\n$/);
|
||||
|
||||
if (not $Test->ok($result->{diag} eq $exp,
|
||||
"subtest '$sub_name' of '$name' compare diag"))
|
||||
{
|
||||
$got = $result->{diag};
|
||||
}
|
||||
}
|
||||
|
||||
if ($got) {
|
||||
my $glen = length($got);
|
||||
my $elen = length($exp);
|
||||
for ($got, $exp)
|
||||
{
|
||||
my @lines = split("\n", $_);
|
||||
$_ = join("\n", map {
|
||||
if ($want_space)
|
||||
{
|
||||
$_ = $colour.escape($_).$reset;
|
||||
}
|
||||
else
|
||||
{
|
||||
"'$colour$_$reset'"
|
||||
}
|
||||
} @lines);
|
||||
}
|
||||
|
||||
$Test->diag(<<EOM);
|
||||
Got diag ($glen bytes):
|
||||
$got
|
||||
Expected diag ($elen bytes):
|
||||
$exp
|
||||
EOM
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
sub escape
|
||||
{
|
||||
my $str = shift;
|
||||
my $res = '';
|
||||
for my $char (split("", $str))
|
||||
{
|
||||
my $c = ord($char);
|
||||
if(($c>32 and $c<125) or $c == 10)
|
||||
{
|
||||
$res .= $char;
|
||||
}
|
||||
else
|
||||
{
|
||||
$res .= sprintf('\x{%x}', $c)
|
||||
}
|
||||
}
|
||||
return $res;
|
||||
}
|
||||
|
||||
sub cmp_results
|
||||
{
|
||||
my ($results, $expects, $name) = @_;
|
||||
|
||||
$Test->is_num(scalar @$results, scalar @$expects, "Test '$name' result count");
|
||||
|
||||
for (my $i = 0; $i < @$expects; $i++)
|
||||
{
|
||||
my $expect = $expects->[$i];
|
||||
my $result = $results->[$i];
|
||||
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
cmp_result($result, $expect, $name);
|
||||
}
|
||||
}
|
||||
|
||||
######## nicked from Test::More
|
||||
sub plan {
|
||||
my(@plan) = @_;
|
||||
|
||||
my $caller = caller;
|
||||
|
||||
$Test->exported_to($caller);
|
||||
|
||||
my @imports = ();
|
||||
foreach my $idx (0..$#plan) {
|
||||
if( $plan[$idx] eq 'import' ) {
|
||||
my($tag, $imports) = splice @plan, $idx, 2;
|
||||
@imports = @$imports;
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
$Test->plan(@plan);
|
||||
|
||||
__PACKAGE__->_export_to_level(1, __PACKAGE__, @imports);
|
||||
}
|
||||
|
||||
sub import {
|
||||
my($class) = shift;
|
||||
{
|
||||
no warnings 'redefine';
|
||||
*Test::Builder::new = \&new_new;
|
||||
}
|
||||
goto &plan;
|
||||
}
|
||||
|
||||
sub _export_to_level
|
||||
{
|
||||
my $pkg = shift;
|
||||
my $level = shift;
|
||||
(undef) = shift; # redundant arg
|
||||
my $callpkg = caller($level);
|
||||
$pkg->export($callpkg, @_);
|
||||
}
|
||||
|
||||
|
||||
############
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Tester - Ease testing test modules built with Test::Builder
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test::Tester tests => 6;
|
||||
|
||||
use Test::MyStyle;
|
||||
|
||||
check_test(
|
||||
sub {
|
||||
is_mystyle_eq("this", "that", "not eq");
|
||||
},
|
||||
{
|
||||
ok => 0, # expect this to fail
|
||||
name => "not eq",
|
||||
diag => "Expected: 'this'\nGot: 'that'",
|
||||
}
|
||||
);
|
||||
|
||||
or
|
||||
|
||||
use Test::Tester tests => 6;
|
||||
|
||||
use Test::MyStyle;
|
||||
|
||||
check_test(
|
||||
sub {
|
||||
is_mystyle_qr("this", "that", "not matching");
|
||||
},
|
||||
{
|
||||
ok => 0, # expect this to fail
|
||||
name => "not matching",
|
||||
diag => qr/Expected: 'this'\s+Got: 'that'/,
|
||||
}
|
||||
);
|
||||
|
||||
or
|
||||
|
||||
use Test::Tester;
|
||||
|
||||
use Test::More tests => 3;
|
||||
use Test::MyStyle;
|
||||
|
||||
my ($premature, @results) = run_tests(
|
||||
sub {
|
||||
is_database_alive("dbname");
|
||||
}
|
||||
);
|
||||
|
||||
# now use Test::More::like to check the diagnostic output
|
||||
|
||||
like($results[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag");
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
If you have written a test module based on Test::Builder then Test::Tester
|
||||
allows you to test it with the minimum of effort.
|
||||
|
||||
=head1 HOW TO USE (THE EASY WAY)
|
||||
|
||||
From version 0.08 Test::Tester no longer requires you to included anything
|
||||
special in your test modules. All you need to do is
|
||||
|
||||
use Test::Tester;
|
||||
|
||||
in your test script B<before> any other Test::Builder based modules and away
|
||||
you go.
|
||||
|
||||
Other modules based on Test::Builder can be used to help with the
|
||||
testing. In fact you can even use functions from your module to test
|
||||
other functions from the same module (while this is possible it is
|
||||
probably not a good idea, if your module has bugs, then
|
||||
using it to test itself may give the wrong answers).
|
||||
|
||||
The easiest way to test is to do something like
|
||||
|
||||
check_test(
|
||||
sub { is_mystyle_eq("this", "that", "not eq") },
|
||||
{
|
||||
ok => 0, # we expect the test to fail
|
||||
name => "not eq",
|
||||
diag => "Expected: 'this'\nGot: 'that'",
|
||||
}
|
||||
);
|
||||
|
||||
this will execute the is_mystyle_eq test, capturing its results and
|
||||
checking that they are what was expected.
|
||||
|
||||
You may need to examine the test results in a more flexible way, for
|
||||
example, the diagnostic output may be quite long or complex or it may involve
|
||||
something that you cannot predict in advance like a timestamp. In this case
|
||||
you can get direct access to the test results:
|
||||
|
||||
my ($premature, @results) = run_tests(
|
||||
sub {
|
||||
is_database_alive("dbname");
|
||||
}
|
||||
);
|
||||
|
||||
like($result[0]->{diag}, "/^Database ping took \\d+ seconds$"/, "diag");
|
||||
|
||||
or
|
||||
|
||||
check_test(
|
||||
sub { is_mystyle_qr("this", "that", "not matching") },
|
||||
{
|
||||
ok => 0, # we expect the test to fail
|
||||
name => "not matching",
|
||||
diag => qr/Expected: 'this'\s+Got: 'that'/,
|
||||
}
|
||||
);
|
||||
|
||||
We cannot predict how long the database ping will take so we use
|
||||
Test::More's like() test to check that the diagnostic string is of the right
|
||||
form.
|
||||
|
||||
=head1 HOW TO USE (THE HARD WAY)
|
||||
|
||||
I<This is here for backwards compatibility only>
|
||||
|
||||
Make your module use the Test::Tester::Capture object instead of the
|
||||
Test::Builder one. How to do this depends on your module but assuming that
|
||||
your module holds the Test::Builder object in $Test and that all your test
|
||||
routines access it through $Test then providing a function something like this
|
||||
|
||||
sub set_builder
|
||||
{
|
||||
$Test = shift;
|
||||
}
|
||||
|
||||
should allow your test scripts to do
|
||||
|
||||
Test::YourModule::set_builder(Test::Tester->capture);
|
||||
|
||||
and after that any tests inside your module will captured.
|
||||
|
||||
=head1 TEST RESULTS
|
||||
|
||||
The result of each test is captured in a hash. These hashes are the same as
|
||||
the hashes returned by Test::Builder->details but with a couple of extra
|
||||
fields.
|
||||
|
||||
These fields are documented in L<Test::Builder> in the details() function
|
||||
|
||||
=over 2
|
||||
|
||||
=item ok
|
||||
|
||||
Did the test pass?
|
||||
|
||||
=item actual_ok
|
||||
|
||||
Did the test really pass? That is, did the pass come from
|
||||
Test::Builder->ok() or did it pass because it was a TODO test?
|
||||
|
||||
=item name
|
||||
|
||||
The name supplied for the test.
|
||||
|
||||
=item type
|
||||
|
||||
What kind of test? Possibilities include, skip, todo etc. See
|
||||
L<Test::Builder> for more details.
|
||||
|
||||
=item reason
|
||||
|
||||
The reason for the skip, todo etc. See L<Test::Builder> for more details.
|
||||
|
||||
=back
|
||||
|
||||
These fields are exclusive to Test::Tester.
|
||||
|
||||
=over 2
|
||||
|
||||
=item diag
|
||||
|
||||
Any diagnostics that were output for the test. This only includes
|
||||
diagnostics output B<after> the test result is declared.
|
||||
|
||||
Note that Test::Builder ensures that any diagnostics end in a \n and
|
||||
it in earlier versions of Test::Tester it was essential that you have
|
||||
the final \n in your expected diagnostics. From version 0.10 onward,
|
||||
Test::Tester will add the \n if you forgot it. It will not add a \n if
|
||||
you are expecting no diagnostics. See below for help tracking down
|
||||
hard to find space and tab related problems.
|
||||
|
||||
=item depth
|
||||
|
||||
This allows you to check that your test module is setting the correct value
|
||||
for $Test::Builder::Level and thus giving the correct file and line number
|
||||
when a test fails. It is calculated by looking at caller() and
|
||||
$Test::Builder::Level. It should count how many subroutines there are before
|
||||
jumping into the function you are testing. So for example in
|
||||
|
||||
run_tests( sub { my_test_function("a", "b") } );
|
||||
|
||||
the depth should be 1 and in
|
||||
|
||||
sub deeper { my_test_function("a", "b") }
|
||||
|
||||
run_tests(sub { deeper() });
|
||||
|
||||
depth should be 2, that is 1 for the sub {} and one for deeper(). This
|
||||
might seem a little complex but if your tests look like the simple
|
||||
examples in this doc then you don't need to worry as the depth will
|
||||
always be 1 and that's what Test::Tester expects by default.
|
||||
|
||||
B<Note>: if you do not specify a value for depth in check_test() then it
|
||||
automatically compares it against 1, if you really want to skip the depth
|
||||
test then pass in undef.
|
||||
|
||||
B<Note>: depth will not be correctly calculated for tests that run from a
|
||||
signal handler or an END block or anywhere else that hides the call stack.
|
||||
|
||||
=back
|
||||
|
||||
Some of Test::Tester's functions return arrays of these hashes, just
|
||||
like Test::Builder->details. That is, the hash for the first test will
|
||||
be array element 1 (not 0). Element 0 will not be a hash it will be a
|
||||
string which contains any diagnostic output that came before the first
|
||||
test. This should usually be empty, if it's not, it means something
|
||||
output diagnostics before any test results showed up.
|
||||
|
||||
=head1 SPACES AND TABS
|
||||
|
||||
Appearances can be deceptive, especially when it comes to emptiness. If you
|
||||
are scratching your head trying to work out why Test::Tester is saying that
|
||||
your diagnostics are wrong when they look perfectly right then the answer is
|
||||
probably whitespace. From version 0.10 on, Test::Tester surrounds the
|
||||
expected and got diag values with single quotes to make it easier to spot
|
||||
trailing whitespace. So in this example
|
||||
|
||||
# Got diag (5 bytes):
|
||||
# 'abcd '
|
||||
# Expected diag (4 bytes):
|
||||
# 'abcd'
|
||||
|
||||
it is quite clear that there is a space at the end of the first string.
|
||||
Another way to solve this problem is to use colour and inverse video on an
|
||||
ANSI terminal, see below COLOUR below if you want this.
|
||||
|
||||
Unfortunately this is sometimes not enough, neither colour nor quotes will
|
||||
help you with problems involving tabs, other non-printing characters and
|
||||
certain kinds of problems inherent in Unicode. To deal with this, you can
|
||||
switch Test::Tester into a mode whereby all "tricky" characters are shown as
|
||||
\{xx}. Tricky characters are those with ASCII code less than 33 or higher
|
||||
than 126. This makes the output more difficult to read but much easier to
|
||||
find subtle differences between strings. To turn on this mode either call
|
||||
C<show_space()> in your test script or set the C<TESTTESTERSPACE> environment
|
||||
variable to be a true value. The example above would then look like
|
||||
|
||||
# Got diag (5 bytes):
|
||||
# abcd\x{20}
|
||||
# Expected diag (4 bytes):
|
||||
# abcd
|
||||
|
||||
=head1 COLOUR
|
||||
|
||||
If you prefer to use colour as a means of finding tricky whitespace
|
||||
characters then you can set the C<TESTTESTCOLOUR> environment variable to a
|
||||
comma separated pair of colours, the first for the foreground, the second
|
||||
for the background. For example "white,red" will print white text on a red
|
||||
background. This requires the Term::ANSIColor module. You can specify any
|
||||
colour that would be acceptable to the Term::ANSIColor::color function.
|
||||
|
||||
If you spell colour differently, that's no problem. The C<TESTTESTERCOLOR>
|
||||
variable also works (if both are set then the British spelling wins out).
|
||||
|
||||
=head1 EXPORTED FUNCTIONS
|
||||
|
||||
=head3 ($premature, @results) = run_tests(\&test_sub)
|
||||
|
||||
\&test_sub is a reference to a subroutine.
|
||||
|
||||
run_tests runs the subroutine in $test_sub and captures the results of any
|
||||
tests inside it. You can run more than 1 test inside this subroutine if you
|
||||
like.
|
||||
|
||||
$premature is a string containing any diagnostic output from before
|
||||
the first test.
|
||||
|
||||
@results is an array of test result hashes.
|
||||
|
||||
=head3 cmp_result(\%result, \%expect, $name)
|
||||
|
||||
\%result is a ref to a test result hash.
|
||||
|
||||
\%expect is a ref to a hash of expected values for the test result.
|
||||
|
||||
cmp_result compares the result with the expected values. If any differences
|
||||
are found it outputs diagnostics. You may leave out any field from the
|
||||
expected result and cmp_result will not do the comparison of that field.
|
||||
|
||||
=head3 cmp_results(\@results, \@expects, $name)
|
||||
|
||||
\@results is a ref to an array of test results.
|
||||
|
||||
\@expects is a ref to an array of hash refs.
|
||||
|
||||
cmp_results checks that the results match the expected results and if any
|
||||
differences are found it outputs diagnostics. It first checks that the
|
||||
number of elements in \@results and \@expects is the same. Then it goes
|
||||
through each result checking it against the expected result as in
|
||||
cmp_result() above.
|
||||
|
||||
=head3 ($premature, @results) = check_tests(\&test_sub, \@expects, $name)
|
||||
|
||||
\&test_sub is a reference to a subroutine.
|
||||
|
||||
\@expect is a ref to an array of hash refs which are expected test results.
|
||||
|
||||
check_tests combines run_tests and cmp_tests into a single call. It also
|
||||
checks if the tests died at any stage.
|
||||
|
||||
It returns the same values as run_tests, so you can further examine the test
|
||||
results if you need to.
|
||||
|
||||
=head3 ($premature, @results) = check_test(\&test_sub, \%expect, $name)
|
||||
|
||||
\&test_sub is a reference to a subroutine.
|
||||
|
||||
\%expect is a ref to an hash of expected values for the test result.
|
||||
|
||||
check_test is a wrapper around check_tests. It combines run_tests and
|
||||
cmp_tests into a single call, checking if the test died. It assumes
|
||||
that only a single test is run inside \&test_sub and include a test to
|
||||
make sure this is true.
|
||||
|
||||
It returns the same values as run_tests, so you can further examine the test
|
||||
results if you need to.
|
||||
|
||||
=head3 show_space()
|
||||
|
||||
Turn on the escaping of characters as described in the SPACES AND TABS
|
||||
section.
|
||||
|
||||
=head1 HOW IT WORKS
|
||||
|
||||
Normally, a test module (let's call it Test:MyStyle) calls
|
||||
Test::Builder->new to get the Test::Builder object. Test::MyStyle calls
|
||||
methods on this object to record information about test results. When
|
||||
Test::Tester is loaded, it replaces Test::Builder's new() method with one
|
||||
which returns a Test::Tester::Delegate object. Most of the time this object
|
||||
behaves as the real Test::Builder object. Any methods that are called are
|
||||
delegated to the real Test::Builder object so everything works perfectly.
|
||||
However once we go into test mode, the method calls are no longer passed to
|
||||
the real Test::Builder object, instead they go to the Test::Tester::Capture
|
||||
object. This object seems exactly like the real Test::Builder object,
|
||||
except, instead of outputting test results and diagnostics, it just records
|
||||
all the information for later analysis.
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Support for calling Test::Builder->note is minimal. It's implemented
|
||||
as an empty stub, so modules that use it will not crash but the calls
|
||||
are not recorded for testing purposes like the others. Patches
|
||||
welcome.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Test::Builder> the source of testing goodness. L<Test::Builder::Tester>
|
||||
for an alternative approach to the problem tackled by Test::Tester -
|
||||
captures the strings output by Test::Builder. This means you cannot get
|
||||
separate access to the individual pieces of information and you must predict
|
||||
B<exactly> what your test will output.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
This module is copyright 2005 Fergal Daly <fergal@esatclear.ie>, some parts
|
||||
are based on other people's work.
|
||||
|
||||
Plan handling lifted from Test::More. written by Michael G Schwern
|
||||
<schwern@pobox.com>.
|
||||
|
||||
Test::Tester::Capture is a cut down and hacked up version of Test::Builder.
|
||||
Test::Builder was written by chromatic <chromatic@wgz.org> and Michael G
|
||||
Schwern <schwern@pobox.com>.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Under the same license as Perl itself
|
||||
|
||||
See L<https://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
241
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Tester/Capture.pm
Normal file
241
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Tester/Capture.pm
Normal file
|
|
@ -0,0 +1,241 @@
|
|||
use strict;
|
||||
|
||||
package Test::Tester::Capture;
|
||||
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
|
||||
use Test::Builder;
|
||||
|
||||
use vars qw( @ISA );
|
||||
@ISA = qw( Test::Builder );
|
||||
|
||||
# Make Test::Tester::Capture thread-safe for ithreads.
|
||||
BEGIN {
|
||||
use Config;
|
||||
*share = sub { 0 };
|
||||
*lock = sub { 0 };
|
||||
}
|
||||
|
||||
my $Curr_Test = 0; share($Curr_Test);
|
||||
my @Test_Results = (); share(@Test_Results);
|
||||
my $Prem_Diag = {diag => ""}; share($Curr_Test);
|
||||
|
||||
sub new
|
||||
{
|
||||
# Test::Tester::Capgture::new used to just return __PACKAGE__
|
||||
# because Test::Builder::new enforced its singleton nature by
|
||||
# return __PACKAGE__. That has since changed, Test::Builder::new now
|
||||
# returns a blessed has and around version 0.78, Test::Builder::todo
|
||||
# started wanting to modify $self. To cope with this, we now return
|
||||
# a blessed hash. This is a short-term hack, the correct thing to do
|
||||
# is to detect which style of Test::Builder we're dealing with and
|
||||
# act appropriately.
|
||||
|
||||
my $class = shift;
|
||||
return bless {}, $class;
|
||||
}
|
||||
|
||||
sub ok {
|
||||
my($self, $test, $name) = @_;
|
||||
|
||||
my $ctx = $self->ctx;
|
||||
|
||||
# $test might contain an object which we don't want to accidentally
|
||||
# store, so we turn it into a boolean.
|
||||
$test = $test ? 1 : 0;
|
||||
|
||||
lock $Curr_Test;
|
||||
$Curr_Test++;
|
||||
|
||||
my($pack, $file, $line) = $self->caller;
|
||||
|
||||
my $todo = $self->todo();
|
||||
|
||||
my $result = {};
|
||||
share($result);
|
||||
|
||||
unless( $test ) {
|
||||
@$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
|
||||
}
|
||||
else {
|
||||
@$result{ 'ok', 'actual_ok' } = ( 1, $test );
|
||||
}
|
||||
|
||||
if( defined $name ) {
|
||||
$name =~ s|#|\\#|g; # # in a name can confuse Test::Harness.
|
||||
$result->{name} = $name;
|
||||
}
|
||||
else {
|
||||
$result->{name} = '';
|
||||
}
|
||||
|
||||
if( $todo ) {
|
||||
my $what_todo = $todo;
|
||||
$result->{reason} = $what_todo;
|
||||
$result->{type} = 'todo';
|
||||
}
|
||||
else {
|
||||
$result->{reason} = '';
|
||||
$result->{type} = '';
|
||||
}
|
||||
|
||||
$Test_Results[$Curr_Test-1] = $result;
|
||||
|
||||
unless( $test ) {
|
||||
my $msg = $todo ? "Failed (TODO)" : "Failed";
|
||||
$result->{fail_diag} = (" $msg test ($file at line $line)\n");
|
||||
}
|
||||
|
||||
$result->{diag} = "";
|
||||
$result->{_level} = $Test::Builder::Level;
|
||||
$result->{_depth} = Test::Tester::find_run_tests();
|
||||
|
||||
$ctx->release;
|
||||
|
||||
return $test ? 1 : 0;
|
||||
}
|
||||
|
||||
sub skip {
|
||||
my($self, $why) = @_;
|
||||
$why ||= '';
|
||||
|
||||
my $ctx = $self->ctx;
|
||||
|
||||
lock($Curr_Test);
|
||||
$Curr_Test++;
|
||||
|
||||
my %result;
|
||||
share(%result);
|
||||
%result = (
|
||||
'ok' => 1,
|
||||
actual_ok => 1,
|
||||
name => '',
|
||||
type => 'skip',
|
||||
reason => $why,
|
||||
diag => "",
|
||||
_level => $Test::Builder::Level,
|
||||
_depth => Test::Tester::find_run_tests(),
|
||||
);
|
||||
$Test_Results[$Curr_Test-1] = \%result;
|
||||
|
||||
$ctx->release;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub todo_skip {
|
||||
my($self, $why) = @_;
|
||||
$why ||= '';
|
||||
|
||||
my $ctx = $self->ctx;
|
||||
|
||||
lock($Curr_Test);
|
||||
$Curr_Test++;
|
||||
|
||||
my %result;
|
||||
share(%result);
|
||||
%result = (
|
||||
'ok' => 1,
|
||||
actual_ok => 0,
|
||||
name => '',
|
||||
type => 'todo_skip',
|
||||
reason => $why,
|
||||
diag => "",
|
||||
_level => $Test::Builder::Level,
|
||||
_depth => Test::Tester::find_run_tests(),
|
||||
);
|
||||
|
||||
$Test_Results[$Curr_Test-1] = \%result;
|
||||
|
||||
$ctx->release;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub diag {
|
||||
my($self, @msgs) = @_;
|
||||
return unless @msgs;
|
||||
|
||||
# Prevent printing headers when compiling (i.e. -c)
|
||||
return if $^C;
|
||||
|
||||
my $ctx = $self->ctx;
|
||||
|
||||
# Escape each line with a #.
|
||||
foreach (@msgs) {
|
||||
$_ = 'undef' unless defined;
|
||||
}
|
||||
|
||||
push @msgs, "\n" unless $msgs[-1] =~ /\n\Z/;
|
||||
|
||||
my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag;
|
||||
|
||||
$result->{diag} .= join("", @msgs);
|
||||
|
||||
$ctx->release;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub details {
|
||||
return @Test_Results;
|
||||
}
|
||||
|
||||
|
||||
# Stub. Feel free to send me a patch to implement this.
|
||||
sub note {
|
||||
}
|
||||
|
||||
sub explain {
|
||||
return Test::Builder::explain(@_);
|
||||
}
|
||||
|
||||
sub premature
|
||||
{
|
||||
return $Prem_Diag->{diag};
|
||||
}
|
||||
|
||||
sub current_test
|
||||
{
|
||||
if (@_ > 1)
|
||||
{
|
||||
die "Don't try to change the test number!";
|
||||
}
|
||||
else
|
||||
{
|
||||
return $Curr_Test;
|
||||
}
|
||||
}
|
||||
|
||||
sub reset
|
||||
{
|
||||
$Curr_Test = 0;
|
||||
@Test_Results = ();
|
||||
$Prem_Diag = {diag => ""};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Tester::Capture - Help testing test modules built with Test::Builder
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a subclass of Test::Builder that overrides many of the methods so
|
||||
that they don't output anything. It also keeps track of its own set of test
|
||||
results so that you can use Test::Builder based modules to perform tests on
|
||||
other Test::Builder based modules.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Most of the code here was lifted straight from Test::Builder and then had
|
||||
chunks removed by Fergal Daly <fergal@esatclear.ie>.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Under the same license as Perl itself
|
||||
|
||||
See L<https://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,79 @@
|
|||
# $Header: /home/fergal/my/cvs/Test-Tester/lib/Test/Tester/CaptureRunner.pm,v 1.3 2003/03/05 01:07:55 fergal Exp $
|
||||
use strict;
|
||||
|
||||
package Test::Tester::CaptureRunner;
|
||||
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
|
||||
use Test::Tester::Capture;
|
||||
require Exporter;
|
||||
|
||||
sub new
|
||||
{
|
||||
my $pkg = shift;
|
||||
my $self = bless {}, $pkg;
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub run_tests
|
||||
{
|
||||
my $self = shift;
|
||||
|
||||
my $test = shift;
|
||||
|
||||
capture()->reset;
|
||||
|
||||
$self->{StartLevel} = $Test::Builder::Level;
|
||||
&$test();
|
||||
}
|
||||
|
||||
sub get_results
|
||||
{
|
||||
my $self = shift;
|
||||
my @results = capture()->details;
|
||||
|
||||
my $start = $self->{StartLevel};
|
||||
foreach my $res (@results)
|
||||
{
|
||||
next if defined $res->{depth};
|
||||
my $depth = $res->{_depth} - $res->{_level} - $start - 3;
|
||||
# print "my $depth = $res->{_depth} - $res->{_level} - $start - 1\n";
|
||||
$res->{depth} = $depth;
|
||||
}
|
||||
|
||||
return @results;
|
||||
}
|
||||
|
||||
sub get_premature
|
||||
{
|
||||
return capture()->premature;
|
||||
}
|
||||
|
||||
sub capture
|
||||
{
|
||||
return Test::Tester::Capture->new;
|
||||
}
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::Tester::CaptureRunner - Help testing test modules built with Test::Builder
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This stuff if needed to allow me to play with other ways of monitoring the
|
||||
test results.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Copyright 2003 by Fergal Daly <fergal@esatclear.ie>.
|
||||
|
||||
=head1 LICENSE
|
||||
|
||||
Under the same license as Perl itself
|
||||
|
||||
See L<https://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
|
|
@ -0,0 +1,45 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
|
||||
package Test::Tester::Delegate;
|
||||
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
use Scalar::Util();
|
||||
|
||||
use vars '$AUTOLOAD';
|
||||
|
||||
sub new
|
||||
{
|
||||
my $pkg = shift;
|
||||
|
||||
my $obj = shift;
|
||||
my $self = bless {}, $pkg;
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub AUTOLOAD
|
||||
{
|
||||
my ($sub) = $AUTOLOAD =~ /.*::(.*?)$/;
|
||||
|
||||
return if $sub eq "DESTROY";
|
||||
|
||||
my $obj = $_[0]->{Object};
|
||||
|
||||
my $ref = $obj->can($sub);
|
||||
shift(@_);
|
||||
unshift(@_, $obj);
|
||||
goto &$ref;
|
||||
}
|
||||
|
||||
sub can {
|
||||
my $this = shift;
|
||||
my ($sub) = @_;
|
||||
|
||||
return $this->{Object}->can($sub) if Scalar::Util::blessed($this);
|
||||
|
||||
return $this->SUPER::can(@_);
|
||||
}
|
||||
|
||||
1;
|
||||
618
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Tutorial.pod
Normal file
618
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/Tutorial.pod
Normal file
|
|
@ -0,0 +1,618 @@
|
|||
=head1 NAME
|
||||
|
||||
Test::Tutorial - A tutorial about writing really basic tests
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
|
||||
I<AHHHHHHH!!!! NOT TESTING! Anything but testing!
|
||||
Beat me, whip me, send me to Detroit, but don't make
|
||||
me write tests!>
|
||||
|
||||
I<*sob*>
|
||||
|
||||
I<Besides, I don't know how to write the damned things.>
|
||||
|
||||
|
||||
Is this you? Is writing tests right up there with writing
|
||||
documentation and having your fingernails pulled out? Did you open up
|
||||
a test and read
|
||||
|
||||
######## We start with some black magic
|
||||
|
||||
and decide that's quite enough for you?
|
||||
|
||||
It's ok. That's all gone now. We've done all the black magic for
|
||||
you. And here are the tricks...
|
||||
|
||||
|
||||
=head2 Nuts and bolts of testing.
|
||||
|
||||
Here's the most basic test program.
|
||||
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
print "1..1\n";
|
||||
|
||||
print 1 + 1 == 2 ? "ok 1\n" : "not ok 1\n";
|
||||
|
||||
Because 1 + 1 is 2, it prints:
|
||||
|
||||
1..1
|
||||
ok 1
|
||||
|
||||
What this says is: C<1..1> "I'm going to run one test." [1] C<ok 1>
|
||||
"The first test passed". And that's about all magic there is to
|
||||
testing. Your basic unit of testing is the I<ok>. For each thing you
|
||||
test, an C<ok> is printed. Simple. L<Test::Harness> interprets your test
|
||||
results to determine if you succeeded or failed (more on that later).
|
||||
|
||||
Writing all these print statements rapidly gets tedious. Fortunately,
|
||||
there's L<Test::Simple>. It has one function, C<ok()>.
|
||||
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
use Test::Simple tests => 1;
|
||||
|
||||
ok( 1 + 1 == 2 );
|
||||
|
||||
That does the same thing as the previous code. C<ok()> is the backbone
|
||||
of Perl testing, and we'll be using it instead of roll-your-own from
|
||||
here on. If C<ok()> gets a true value, the test passes. False, it
|
||||
fails.
|
||||
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
use Test::Simple tests => 2;
|
||||
ok( 1 + 1 == 2 );
|
||||
ok( 2 + 2 == 5 );
|
||||
|
||||
From that comes:
|
||||
|
||||
1..2
|
||||
ok 1
|
||||
not ok 2
|
||||
# Failed test (test.pl at line 5)
|
||||
# Looks like you failed 1 tests of 2.
|
||||
|
||||
C<1..2> "I'm going to run two tests." This number is a I<plan>. It helps to
|
||||
ensure your test program ran all the way through and didn't die or skip some
|
||||
tests. C<ok 1> "The first test passed." C<not ok 2> "The second test failed".
|
||||
Test::Simple helpfully prints out some extra commentary about your tests.
|
||||
|
||||
It's not scary. Come, hold my hand. We're going to give an example
|
||||
of testing a module. For our example, we'll be testing a date
|
||||
library, L<Date::ICal>. It's on CPAN, so download a copy and follow
|
||||
along. [2]
|
||||
|
||||
|
||||
=head2 Where to start?
|
||||
|
||||
This is the hardest part of testing, where do you start? People often get
|
||||
overwhelmed at the apparent enormity of the task of testing a whole module.
|
||||
The best place to start is at the beginning. L<Date::ICal> is an
|
||||
object-oriented module, and that means you start by making an object. Test
|
||||
C<new()>.
|
||||
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
# assume these two lines are in all subsequent examples
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test::Simple tests => 2;
|
||||
|
||||
use Date::ICal;
|
||||
|
||||
my $ical = Date::ICal->new; # create an object
|
||||
ok( defined $ical ); # check that we got something
|
||||
ok( $ical->isa('Date::ICal') ); # and it's the right class
|
||||
|
||||
Run that and you should get:
|
||||
|
||||
1..2
|
||||
ok 1
|
||||
ok 2
|
||||
|
||||
Congratulations! You've written your first useful test.
|
||||
|
||||
|
||||
=head2 Names
|
||||
|
||||
That output isn't terribly descriptive, is it? When you have two tests you can
|
||||
figure out which one is #2, but what if you have 102 tests?
|
||||
|
||||
Each test can be given a little descriptive name as the second
|
||||
argument to C<ok()>.
|
||||
|
||||
use Test::Simple tests => 2;
|
||||
|
||||
ok( defined $ical, 'new() returned something' );
|
||||
ok( $ical->isa('Date::ICal'), " and it's the right class" );
|
||||
|
||||
Now you'll see:
|
||||
|
||||
1..2
|
||||
ok 1 - new() returned something
|
||||
ok 2 - and it's the right class
|
||||
|
||||
|
||||
=head2 Test the manual
|
||||
|
||||
The simplest way to build up a decent testing suite is to just test what
|
||||
the manual says it does. [3] Let's pull something out of the
|
||||
L<Date::ICal/SYNOPSIS> and test that all its bits work.
|
||||
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
use Test::Simple tests => 8;
|
||||
|
||||
use Date::ICal;
|
||||
|
||||
$ical = Date::ICal->new( year => 1964, month => 10, day => 16,
|
||||
hour => 16, min => 12, sec => 47,
|
||||
tz => '0530' );
|
||||
|
||||
ok( defined $ical, 'new() returned something' );
|
||||
ok( $ical->isa('Date::ICal'), " and it's the right class" );
|
||||
ok( $ical->sec == 47, ' sec()' );
|
||||
ok( $ical->min == 12, ' min()' );
|
||||
ok( $ical->hour == 16, ' hour()' );
|
||||
ok( $ical->day == 17, ' day()' );
|
||||
ok( $ical->month == 10, ' month()' );
|
||||
ok( $ical->year == 1964, ' year()' );
|
||||
|
||||
Run that and you get:
|
||||
|
||||
1..8
|
||||
ok 1 - new() returned something
|
||||
ok 2 - and it's the right class
|
||||
ok 3 - sec()
|
||||
ok 4 - min()
|
||||
ok 5 - hour()
|
||||
not ok 6 - day()
|
||||
# Failed test (- at line 16)
|
||||
ok 7 - month()
|
||||
ok 8 - year()
|
||||
# Looks like you failed 1 tests of 8.
|
||||
|
||||
Whoops, a failure! [4] L<Test::Simple> helpfully lets us know on what line the
|
||||
failure occurred, but not much else. We were supposed to get 17, but we
|
||||
didn't. What did we get?? Dunno. You could re-run the test in the debugger
|
||||
or throw in some print statements to find out.
|
||||
|
||||
Instead, switch from L<Test::Simple> to L<Test::More>. L<Test::More>
|
||||
does everything L<Test::Simple> does, and more! In fact, L<Test::More> does
|
||||
things I<exactly> the way L<Test::Simple> does. You can literally swap
|
||||
L<Test::Simple> out and put L<Test::More> in its place. That's just what
|
||||
we're going to do.
|
||||
|
||||
L<Test::More> does more than L<Test::Simple>. The most important difference at
|
||||
this point is it provides more informative ways to say "ok". Although you can
|
||||
write almost any test with a generic C<ok()>, it can't tell you what went
|
||||
wrong. The C<is()> function lets us declare that something is supposed to be
|
||||
the same as something else:
|
||||
|
||||
use Test::More tests => 8;
|
||||
|
||||
use Date::ICal;
|
||||
|
||||
$ical = Date::ICal->new( year => 1964, month => 10, day => 16,
|
||||
hour => 16, min => 12, sec => 47,
|
||||
tz => '0530' );
|
||||
|
||||
ok( defined $ical, 'new() returned something' );
|
||||
ok( $ical->isa('Date::ICal'), " and it's the right class" );
|
||||
is( $ical->sec, 47, ' sec()' );
|
||||
is( $ical->min, 12, ' min()' );
|
||||
is( $ical->hour, 16, ' hour()' );
|
||||
is( $ical->day, 17, ' day()' );
|
||||
is( $ical->month, 10, ' month()' );
|
||||
is( $ical->year, 1964, ' year()' );
|
||||
|
||||
"Is C<< $ical->sec >> 47?" "Is C<< $ical->min >> 12?" With C<is()> in place,
|
||||
you get more information:
|
||||
|
||||
1..8
|
||||
ok 1 - new() returned something
|
||||
ok 2 - and it's the right class
|
||||
ok 3 - sec()
|
||||
ok 4 - min()
|
||||
ok 5 - hour()
|
||||
not ok 6 - day()
|
||||
# Failed test (- at line 16)
|
||||
# got: '16'
|
||||
# expected: '17'
|
||||
ok 7 - month()
|
||||
ok 8 - year()
|
||||
# Looks like you failed 1 tests of 8.
|
||||
|
||||
Aha. C<< $ical->day >> returned 16, but we expected 17. A
|
||||
quick check shows that the code is working fine, we made a mistake
|
||||
when writing the tests. Change it to:
|
||||
|
||||
is( $ical->day, 16, ' day()' );
|
||||
|
||||
... and everything works.
|
||||
|
||||
Any time you're doing a "this equals that" sort of test, use C<is()>.
|
||||
It even works on arrays. The test is always in scalar context, so you
|
||||
can test how many elements are in an array this way. [5]
|
||||
|
||||
is( @foo, 5, 'foo has 5 elements' );
|
||||
|
||||
|
||||
=head2 Sometimes the tests are wrong
|
||||
|
||||
This brings up a very important lesson. Code has bugs. Tests are
|
||||
code. Ergo, tests have bugs. A failing test could mean a bug in the
|
||||
code, but don't discount the possibility that the test is wrong.
|
||||
|
||||
On the flip side, don't be tempted to prematurely declare a test
|
||||
incorrect just because you're having trouble finding the bug.
|
||||
Invalidating a test isn't something to be taken lightly, and don't use
|
||||
it as a cop out to avoid work.
|
||||
|
||||
|
||||
=head2 Testing lots of values
|
||||
|
||||
We're going to be wanting to test a lot of dates here, trying to trick
|
||||
the code with lots of different edge cases. Does it work before 1970?
|
||||
After 2038? Before 1904? Do years after 10,000 give it trouble?
|
||||
Does it get leap years right? We could keep repeating the code above,
|
||||
or we could set up a little try/expect loop.
|
||||
|
||||
use Test::More tests => 32;
|
||||
use Date::ICal;
|
||||
|
||||
my %ICal_Dates = (
|
||||
# An ICal string And the year, month, day
|
||||
# hour, minute and second we expect.
|
||||
'19971024T120000' => # from the docs.
|
||||
[ 1997, 10, 24, 12, 0, 0 ],
|
||||
'20390123T232832' => # after the Unix epoch
|
||||
[ 2039, 1, 23, 23, 28, 32 ],
|
||||
'19671225T000000' => # before the Unix epoch
|
||||
[ 1967, 12, 25, 0, 0, 0 ],
|
||||
'18990505T232323' => # before the MacOS epoch
|
||||
[ 1899, 5, 5, 23, 23, 23 ],
|
||||
);
|
||||
|
||||
|
||||
while( my($ical_str, $expect) = each %ICal_Dates ) {
|
||||
my $ical = Date::ICal->new( ical => $ical_str );
|
||||
|
||||
ok( defined $ical, "new(ical => '$ical_str')" );
|
||||
ok( $ical->isa('Date::ICal'), " and it's the right class" );
|
||||
|
||||
is( $ical->year, $expect->[0], ' year()' );
|
||||
is( $ical->month, $expect->[1], ' month()' );
|
||||
is( $ical->day, $expect->[2], ' day()' );
|
||||
is( $ical->hour, $expect->[3], ' hour()' );
|
||||
is( $ical->min, $expect->[4], ' min()' );
|
||||
is( $ical->sec, $expect->[5], ' sec()' );
|
||||
}
|
||||
|
||||
Now we can test bunches of dates by just adding them to
|
||||
C<%ICal_Dates>. Now that it's less work to test with more dates, you'll
|
||||
be inclined to just throw more in as you think of them.
|
||||
Only problem is, every time we add to that we have to keep adjusting
|
||||
the C<< use Test::More tests => ## >> line. That can rapidly get
|
||||
annoying. There are ways to make this work better.
|
||||
|
||||
First, we can calculate the plan dynamically using the C<plan()>
|
||||
function.
|
||||
|
||||
use Test::More;
|
||||
use Date::ICal;
|
||||
|
||||
my %ICal_Dates = (
|
||||
...same as before...
|
||||
);
|
||||
|
||||
# For each key in the hash we're running 8 tests.
|
||||
plan tests => keys(%ICal_Dates) * 8;
|
||||
|
||||
...and then your tests...
|
||||
|
||||
To be even more flexible, use C<done_testing>. This means we're just
|
||||
running some tests, don't know how many. [6]
|
||||
|
||||
use Test::More; # instead of tests => 32
|
||||
|
||||
... # tests here
|
||||
|
||||
done_testing(); # reached the end safely
|
||||
|
||||
If you don't specify a plan, L<Test::More> expects to see C<done_testing()>
|
||||
before your program exits. It will warn you if you forget it. You can give
|
||||
C<done_testing()> an optional number of tests you expected to run, and if the
|
||||
number ran differs, L<Test::More> will give you another kind of warning.
|
||||
|
||||
|
||||
=head2 Informative names
|
||||
|
||||
Take a look at the line:
|
||||
|
||||
ok( defined $ical, "new(ical => '$ical_str')" );
|
||||
|
||||
We've added more detail about what we're testing and the ICal string
|
||||
itself we're trying out to the name. So you get results like:
|
||||
|
||||
ok 25 - new(ical => '19971024T120000')
|
||||
ok 26 - and it's the right class
|
||||
ok 27 - year()
|
||||
ok 28 - month()
|
||||
ok 29 - day()
|
||||
ok 30 - hour()
|
||||
ok 31 - min()
|
||||
ok 32 - sec()
|
||||
|
||||
If something in there fails, you'll know which one it was and that
|
||||
will make tracking down the problem easier. Try to put a bit of
|
||||
debugging information into the test names.
|
||||
|
||||
Describe what the tests test, to make debugging a failed test easier
|
||||
for you or for the next person who runs your test.
|
||||
|
||||
|
||||
=head2 Skipping tests
|
||||
|
||||
Poking around in the existing L<Date::ICal> tests, I found this in
|
||||
F<t/01sanity.t> [7]
|
||||
|
||||
#!/usr/bin/perl -w
|
||||
|
||||
use Test::More tests => 7;
|
||||
use Date::ICal;
|
||||
|
||||
# Make sure epoch time is being handled sanely.
|
||||
my $t1 = Date::ICal->new( epoch => 0 );
|
||||
is( $t1->epoch, 0, "Epoch time of 0" );
|
||||
|
||||
# XXX This will only work on unix systems.
|
||||
is( $t1->ical, '19700101Z', " epoch to ical" );
|
||||
|
||||
is( $t1->year, 1970, " year()" );
|
||||
is( $t1->month, 1, " month()" );
|
||||
is( $t1->day, 1, " day()" );
|
||||
|
||||
# like the tests above, but starting with ical instead of epoch
|
||||
my $t2 = Date::ICal->new( ical => '19700101Z' );
|
||||
is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" );
|
||||
|
||||
is( $t2->epoch, 0, " and back to ICal" );
|
||||
|
||||
The beginning of the epoch is different on most non-Unix operating systems [8].
|
||||
Even though Perl smooths out the differences for the most part, certain ports
|
||||
do it differently. MacPerl is one off the top of my head. [9] Rather than
|
||||
putting a comment in the test and hoping someone will read the test while
|
||||
debugging the failure, we can explicitly say it's never going to work and skip
|
||||
the test.
|
||||
|
||||
use Test::More tests => 7;
|
||||
use Date::ICal;
|
||||
|
||||
# Make sure epoch time is being handled sanely.
|
||||
my $t1 = Date::ICal->new( epoch => 0 );
|
||||
is( $t1->epoch, 0, "Epoch time of 0" );
|
||||
|
||||
SKIP: {
|
||||
skip('epoch to ICal not working on Mac OS', 6)
|
||||
if $^O eq 'MacOS';
|
||||
|
||||
is( $t1->ical, '19700101Z', " epoch to ical" );
|
||||
|
||||
is( $t1->year, 1970, " year()" );
|
||||
is( $t1->month, 1, " month()" );
|
||||
is( $t1->day, 1, " day()" );
|
||||
|
||||
# like the tests above, but starting with ical instead of epoch
|
||||
my $t2 = Date::ICal->new( ical => '19700101Z' );
|
||||
is( $t2->ical, '19700101Z', "Start of epoch in ICal notation" );
|
||||
|
||||
is( $t2->epoch, 0, " and back to ICal" );
|
||||
}
|
||||
|
||||
A little bit of magic happens here. When running on anything but MacOS, all
|
||||
the tests run normally. But when on MacOS, C<skip()> causes the entire
|
||||
contents of the SKIP block to be jumped over. It never runs. Instead,
|
||||
C<skip()> prints special output that tells L<Test::Harness> that the tests have
|
||||
been skipped.
|
||||
|
||||
1..7
|
||||
ok 1 - Epoch time of 0
|
||||
ok 2 # skip epoch to ICal not working on MacOS
|
||||
ok 3 # skip epoch to ICal not working on MacOS
|
||||
ok 4 # skip epoch to ICal not working on MacOS
|
||||
ok 5 # skip epoch to ICal not working on MacOS
|
||||
ok 6 # skip epoch to ICal not working on MacOS
|
||||
ok 7 # skip epoch to ICal not working on MacOS
|
||||
|
||||
This means your tests won't fail on MacOS. This means fewer emails
|
||||
from MacPerl users telling you about failing tests that you know will
|
||||
never work. You've got to be careful with skip tests. These are for
|
||||
tests which don't work and I<never will>. It is not for skipping
|
||||
genuine bugs (we'll get to that in a moment).
|
||||
|
||||
The tests are wholly and completely skipped. [10] This will work.
|
||||
|
||||
SKIP: {
|
||||
skip("I don't wanna die!");
|
||||
|
||||
die, die, die, die, die;
|
||||
}
|
||||
|
||||
|
||||
=head2 Todo tests
|
||||
|
||||
While thumbing through the L<Date::ICal> man page, I came across this:
|
||||
|
||||
ical
|
||||
|
||||
$ical_string = $ical->ical;
|
||||
|
||||
Retrieves, or sets, the date on the object, using any
|
||||
valid ICal date/time string.
|
||||
|
||||
"Retrieves or sets". Hmmm. I didn't see a test for using C<ical()> to set
|
||||
the date in the Date::ICal test suite. So I wrote one:
|
||||
|
||||
use Test::More tests => 1;
|
||||
use Date::ICal;
|
||||
|
||||
my $ical = Date::ICal->new;
|
||||
$ical->ical('20201231Z');
|
||||
is( $ical->ical, '20201231Z', 'Setting via ical()' );
|
||||
|
||||
Run that. I saw:
|
||||
|
||||
1..1
|
||||
not ok 1 - Setting via ical()
|
||||
# Failed test (- at line 6)
|
||||
# got: '20010814T233649Z'
|
||||
# expected: '20201231Z'
|
||||
# Looks like you failed 1 tests of 1.
|
||||
|
||||
Whoops! Looks like it's unimplemented. Assume you don't have the time to fix
|
||||
this. [11] Normally, you'd just comment out the test and put a note in a todo
|
||||
list somewhere. Instead, explicitly state "this test will fail" by wrapping it
|
||||
in a C<TODO> block:
|
||||
|
||||
use Test::More tests => 1;
|
||||
|
||||
TODO: {
|
||||
local $TODO = 'ical($ical) not yet implemented';
|
||||
|
||||
my $ical = Date::ICal->new;
|
||||
$ical->ical('20201231Z');
|
||||
|
||||
is( $ical->ical, '20201231Z', 'Setting via ical()' );
|
||||
}
|
||||
|
||||
Now when you run, it's a little different:
|
||||
|
||||
1..1
|
||||
not ok 1 - Setting via ical() # TODO ical($ical) not yet implemented
|
||||
# got: '20010822T201551Z'
|
||||
# expected: '20201231Z'
|
||||
|
||||
L<Test::More> doesn't say "Looks like you failed 1 tests of 1". That '#
|
||||
TODO' tells L<Test::Harness> "this is supposed to fail" and it treats a
|
||||
failure as a successful test. You can write tests even before
|
||||
you've fixed the underlying code.
|
||||
|
||||
If a TODO test passes, L<Test::Harness> will report it "UNEXPECTEDLY
|
||||
SUCCEEDED". When that happens, remove the TODO block with C<local $TODO> and
|
||||
turn it into a real test.
|
||||
|
||||
|
||||
=head2 Testing with taint mode.
|
||||
|
||||
Taint mode is a funny thing. It's the globalest of all global
|
||||
features. Once you turn it on, it affects I<all> code in your program
|
||||
and I<all> modules used (and all the modules they use). If a single
|
||||
piece of code isn't taint clean, the whole thing explodes. With that
|
||||
in mind, it's very important to ensure your module works under taint
|
||||
mode.
|
||||
|
||||
It's very simple to have your tests run under taint mode. Just throw
|
||||
a C<-T> into the C<#!> line. L<Test::Harness> will read the switches
|
||||
in C<#!> and use them to run your tests.
|
||||
|
||||
#!/usr/bin/perl -Tw
|
||||
|
||||
...test normally here...
|
||||
|
||||
When you say C<make test> it will run with taint mode on.
|
||||
|
||||
|
||||
=head1 FOOTNOTES
|
||||
|
||||
=over 4
|
||||
|
||||
=item 1
|
||||
|
||||
The first number doesn't really mean anything, but it has to be 1.
|
||||
It's the second number that's important.
|
||||
|
||||
=item 2
|
||||
|
||||
For those following along at home, I'm using version 1.31. It has
|
||||
some bugs, which is good -- we'll uncover them with our tests.
|
||||
|
||||
=item 3
|
||||
|
||||
You can actually take this one step further and test the manual
|
||||
itself. Have a look at L<Test::Inline> (formerly L<Pod::Tests>).
|
||||
|
||||
=item 4
|
||||
|
||||
Yes, there's a mistake in the test suite. What! Me, contrived?
|
||||
|
||||
=item 5
|
||||
|
||||
We'll get to testing the contents of lists later.
|
||||
|
||||
=item 6
|
||||
|
||||
But what happens if your test program dies halfway through?! Since we
|
||||
didn't say how many tests we're going to run, how can we know it
|
||||
failed? No problem, L<Test::More> employs some magic to catch that death
|
||||
and turn the test into a failure, even if every test passed up to that
|
||||
point.
|
||||
|
||||
=item 7
|
||||
|
||||
I cleaned it up a little.
|
||||
|
||||
=item 8
|
||||
|
||||
Most Operating Systems record time as the number of seconds since a
|
||||
certain date. This date is the beginning of the epoch. Unix's starts
|
||||
at midnight January 1st, 1970 GMT.
|
||||
|
||||
=item 9
|
||||
|
||||
MacOS's epoch is midnight January 1st, 1904. VMS's is midnight,
|
||||
November 17th, 1858, but vmsperl emulates the Unix epoch so it's not a
|
||||
problem.
|
||||
|
||||
=item 10
|
||||
|
||||
As long as the code inside the SKIP block at least compiles. Please
|
||||
don't ask how. No, it's not a filter.
|
||||
|
||||
=item 11
|
||||
|
||||
Do NOT be tempted to use TODO tests as a way to avoid fixing simple
|
||||
bugs!
|
||||
|
||||
=back
|
||||
|
||||
=head1 AUTHORS
|
||||
|
||||
Michael G Schwern E<lt>schwern@pobox.comE<gt> and the perl-qa dancers!
|
||||
|
||||
=head1 MAINTAINERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2001 by Michael G Schwern E<lt>schwern@pobox.comE<gt>.
|
||||
|
||||
This documentation is free; you can redistribute it and/or modify it
|
||||
under the same terms as Perl itself.
|
||||
|
||||
Irrespective of its distribution, all code examples in these files
|
||||
are hereby placed into the public domain. You are permitted and
|
||||
encouraged to use this code in your own programs for fun
|
||||
or for profit as you see fit. A simple comment in the code giving
|
||||
credit would be courteous but is not required.
|
||||
|
||||
=cut
|
||||
64
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/use/ok.pm
Normal file
64
Agent-Windows/OGP64/usr/share/perl5/5.40/Test/use/ok.pm
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
package Test::use::ok;
|
||||
use 5.005;
|
||||
|
||||
our $VERSION = '1.302199';
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test::use::ok - Alternative to Test::More::use_ok
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use ok 'Some::Module';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
According to the B<Test::More> documentation, it is recommended to run
|
||||
C<use_ok()> inside a C<BEGIN> block, so functions are exported at
|
||||
compile-time and prototypes are properly honored.
|
||||
|
||||
That is, instead of writing this:
|
||||
|
||||
use_ok( 'Some::Module' );
|
||||
use_ok( 'Other::Module' );
|
||||
|
||||
One should write this:
|
||||
|
||||
BEGIN { use_ok( 'Some::Module' ); }
|
||||
BEGIN { use_ok( 'Other::Module' ); }
|
||||
|
||||
However, people often either forget to add C<BEGIN>, or mistakenly group
|
||||
C<use_ok> with other tests in a single C<BEGIN> block, which can create subtle
|
||||
differences in execution order.
|
||||
|
||||
With this module, simply change all C<use_ok> in test scripts to C<use ok>,
|
||||
and they will be executed at C<BEGIN> time. The explicit space after C<use>
|
||||
makes it clear that this is a single compile-time action.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Test::More>
|
||||
|
||||
=head1 MAINTAINER
|
||||
|
||||
=over 4
|
||||
|
||||
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=encoding utf8
|
||||
|
||||
=head1 CC0 1.0 Universal
|
||||
|
||||
To the extent possible under law, 唐鳳 has waived all copyright and related
|
||||
or neighboring rights to L<Test::use::ok>.
|
||||
|
||||
This work is published from Taiwan.
|
||||
|
||||
L<https://creativecommons.org/publicdomain/zero/1.0/>
|
||||
|
||||
=cut
|
||||
Loading…
Add table
Add a link
Reference in a new issue