Add Test::Simple v1.302175 to t/lib
The version of Test::More available in CentOS/RHEL 6 doesn't include `subtest`, which we want to use. We can revert this commit once we drop support for CentOS/RHEL 6. The code is licensed under the same terms as Perl 5 itself: https://github.com/Test-More/test-more/blob/v1.302175/LICENSE
This commit is contained in:
Richard Hansen
parent
ee4191f865
commit
94aaff67cd
68 changed files with 21140 additions and 2 deletions
68
Makefile.am
68
Makefile.am
|
|
@ -76,7 +76,73 @@ generated_tests = \
|
|||
t/version.pl
|
||||
TESTS = $(handwritten_tests) $(generated_tests)
|
||||
EXTRA_DIST += $(handwritten_tests) \
|
||||
t/lib/Test/Builder.pm \
|
||||
t/lib/Test/Builder/Formatter.pm \
|
||||
t/lib/Test/Builder/IO/Scalar.pm \
|
||||
t/lib/Test/Builder/Module.pm \
|
||||
t/lib/Test/Builder/Tester.pm \
|
||||
t/lib/Test/Builder/Tester/Color.pm \
|
||||
t/lib/Test/Builder/TodoDiag.pm \
|
||||
t/lib/Test/More.pm \
|
||||
t/lib/Test/Simple.pm \
|
||||
t/lib/Test/Tester.pm \
|
||||
t/lib/Test/Tester/Capture.pm \
|
||||
t/lib/Test/Tester/CaptureRunner.pm \
|
||||
t/lib/Test/Tester/Delegate.pm \
|
||||
t/lib/Test/use/ok.pm \
|
||||
t/lib/Test2.pm \
|
||||
t/lib/Test2/API.pm \
|
||||
t/lib/Test2/API/Breakage.pm \
|
||||
t/lib/Test2/API/Context.pm \
|
||||
t/lib/Test2/API/Instance.pm \
|
||||
t/lib/Test2/API/Stack.pm \
|
||||
t/lib/Test2/Event.pm \
|
||||
t/lib/Test2/Event/Bail.pm \
|
||||
t/lib/Test2/Event/Diag.pm \
|
||||
t/lib/Test2/Event/Encoding.pm \
|
||||
t/lib/Test2/Event/Exception.pm \
|
||||
t/lib/Test2/Event/Fail.pm \
|
||||
t/lib/Test2/Event/Generic.pm \
|
||||
t/lib/Test2/Event/Note.pm \
|
||||
t/lib/Test2/Event/Ok.pm \
|
||||
t/lib/Test2/Event/Pass.pm \
|
||||
t/lib/Test2/Event/Plan.pm \
|
||||
t/lib/Test2/Event/Skip.pm \
|
||||
t/lib/Test2/Event/Subtest.pm \
|
||||
t/lib/Test2/Event/TAP/Version.pm \
|
||||
t/lib/Test2/Event/V2.pm \
|
||||
t/lib/Test2/Event/Waiting.pm \
|
||||
t/lib/Test2/EventFacet.pm \
|
||||
t/lib/Test2/EventFacet/About.pm \
|
||||
t/lib/Test2/EventFacet/Amnesty.pm \
|
||||
t/lib/Test2/EventFacet/Assert.pm \
|
||||
t/lib/Test2/EventFacet/Control.pm \
|
||||
t/lib/Test2/EventFacet/Error.pm \
|
||||
t/lib/Test2/EventFacet/Hub.pm \
|
||||
t/lib/Test2/EventFacet/Info.pm \
|
||||
t/lib/Test2/EventFacet/Info/Table.pm \
|
||||
t/lib/Test2/EventFacet/Meta.pm \
|
||||
t/lib/Test2/EventFacet/Parent.pm \
|
||||
t/lib/Test2/EventFacet/Plan.pm \
|
||||
t/lib/Test2/EventFacet/Render.pm \
|
||||
t/lib/Test2/EventFacet/Trace.pm \
|
||||
t/lib/Test2/Formatter.pm \
|
||||
t/lib/Test2/Formatter/TAP.pm \
|
||||
t/lib/Test2/Hub.pm \
|
||||
t/lib/Test2/Hub/Interceptor.pm \
|
||||
t/lib/Test2/Hub/Interceptor/Terminator.pm \
|
||||
t/lib/Test2/Hub/Subtest.pm \
|
||||
t/lib/Test2/IPC.pm \
|
||||
t/lib/Test2/IPC/Driver.pm \
|
||||
t/lib/Test2/IPC/Driver/Files.pm \
|
||||
t/lib/Test2/Tools/Tiny.pm \
|
||||
t/lib/Test2/Util.pm \
|
||||
t/lib/Test2/Util/ExternalMeta.pm \
|
||||
t/lib/Test2/Util/Facets2Legacy.pm \
|
||||
t/lib/Test2/Util/HashBase.pm \
|
||||
t/lib/Test2/Util/Trace.pm \
|
||||
t/lib/ddclient/Test/Fake/HTTPD.pm \
|
||||
t/lib/ddclient/Test/Fake/HTTPD/dummy-ca-cert.pem \
|
||||
t/lib/ddclient/Test/Fake/HTTPD/dummy-server-cert.pem \
|
||||
t/lib/ddclient/Test/Fake/HTTPD/dummy-server-key.pem
|
||||
t/lib/ddclient/Test/Fake/HTTPD/dummy-server-key.pem \
|
||||
t/lib/ok.pm
|
||||
|
|
|
|||
|
|
@ -49,7 +49,6 @@ m4_foreach_w([_m], [
|
|||
Data::Dumper
|
||||
File::Spec::Functions
|
||||
File::Temp
|
||||
Test::More
|
||||
], [AX_PROG_PERL_MODULES([_m], [],
|
||||
[AC_MSG_WARN([some tests will fail due to missing module _m])])])
|
||||
|
||||
|
|
|
|||
2608
t/lib/Test/Builder.pm
Normal file
2608
t/lib/Test/Builder.pm
Normal file
File diff suppressed because it is too large
Load diff
107
t/lib/Test/Builder/Formatter.pm
Normal file
107
t/lib/Test/Builder/Formatter.pm
Normal file
|
|
@ -0,0 +1,107 @@
|
|||
package Test::Builder::Formatter;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
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
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
659
t/lib/Test/Builder/IO/Scalar.pm
Normal file
659
t/lib/Test/Builder/IO/Scalar.pm
Normal file
|
|
@ -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
t/lib/Test/Builder/Module.pm
Normal file
182
t/lib/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.302175';
|
||||
|
||||
|
||||
=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
t/lib/Test/Builder/Tester.pm
Normal file
675
t/lib/Test/Builder/Tester.pm
Normal file
|
|
@ -0,0 +1,675 @@
|
|||
package Test::Builder::Tester;
|
||||
|
||||
use strict;
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
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;
|
||||
51
t/lib/Test/Builder/Tester/Color.pm
Normal file
51
t/lib/Test/Builder/Tester/Color.pm
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
package Test::Builder::Tester::Color;
|
||||
|
||||
use strict;
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
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;
|
||||
68
t/lib/Test/Builder/TodoDiag.pm
Normal file
68
t/lib/Test/Builder/TodoDiag.pm
Normal file
|
|
@ -0,0 +1,68 @@
|
|||
package Test::Builder::TodoDiag;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
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
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
1997
t/lib/Test/More.pm
Normal file
1997
t/lib/Test/More.pm
Normal file
File diff suppressed because it is too large
Load diff
220
t/lib/Test/Simple.pm
Normal file
220
t/lib/Test/Simple.pm
Normal file
|
|
@ -0,0 +1,220 @@
|
|||
package Test::Simple;
|
||||
|
||||
use 5.006;
|
||||
|
||||
use strict;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
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 F<http://www.perl.com/perl/misc/Artistic.html>
|
||||
|
||||
=cut
|
||||
|
||||
1;
|
||||
695
t/lib/Test/Tester.pm
Normal file
695
t/lib/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.302175';
|
||||
|
||||
@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 http://www.perl.com/perl/misc/Artistic.html
|
||||
|
||||
=cut
|
||||
241
t/lib/Test/Tester/Capture.pm
Normal file
241
t/lib/Test/Tester/Capture.pm
Normal file
|
|
@ -0,0 +1,241 @@
|
|||
use strict;
|
||||
|
||||
package Test::Tester::Capture;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
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 http://www.perl.com/perl/misc/Artistic.html
|
||||
|
||||
=cut
|
||||
79
t/lib/Test/Tester/CaptureRunner.pm
Normal file
79
t/lib/Test/Tester/CaptureRunner.pm
Normal file
|
|
@ -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.302175';
|
||||
|
||||
|
||||
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 http://www.perl.com/perl/misc/Artistic.html
|
||||
|
||||
=cut
|
||||
45
t/lib/Test/Tester/Delegate.pm
Normal file
45
t/lib/Test/Tester/Delegate.pm
Normal file
|
|
@ -0,0 +1,45 @@
|
|||
use strict;
|
||||
use warnings;
|
||||
|
||||
package Test::Tester::Delegate;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
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;
|
||||
64
t/lib/Test/use/ok.pm
Normal file
64
t/lib/Test/use/ok.pm
Normal file
|
|
@ -0,0 +1,64 @@
|
|||
package Test::use::ok;
|
||||
use 5.005;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
__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<http://creativecommons.org/publicdomain/zero/1.0>
|
||||
|
||||
=cut
|
||||
213
t/lib/Test2.pm
Normal file
213
t/lib/Test2.pm
Normal file
|
|
@ -0,0 +1,213 @@
|
|||
package Test2;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2 - Framework for writing test tools that all work together.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Test2 is a new testing framework produced by forking L<Test::Builder>,
|
||||
completely refactoring it, adding many new features and capabilities.
|
||||
|
||||
=head2 WHAT IS NEW?
|
||||
|
||||
=over 4
|
||||
|
||||
=item Easier to test new testing tools.
|
||||
|
||||
From the beginning Test2 was built with introspection capabilities. With
|
||||
Test::Builder it was difficult at best to capture test tool output for
|
||||
verification. Test2 Makes it easy with C<Test2::API::intercept()>.
|
||||
|
||||
=item Better diagnostics capabilities.
|
||||
|
||||
Test2 uses an L<Test2::API::Context> object to track filename, line number, and
|
||||
tool details. This object greatly simplifies tracking for where errors should
|
||||
be reported.
|
||||
|
||||
=item Event driven.
|
||||
|
||||
Test2 based tools produce events which get passed through a processing system
|
||||
before being output by a formatter. This event system allows for rich plugin
|
||||
and extension support.
|
||||
|
||||
=item More complete API.
|
||||
|
||||
Test::Builder only provided a handful of methods for generating lines of TAP.
|
||||
Test2 took inventory of everything people were doing with Test::Builder that
|
||||
required hacking it up. Test2 made public API functions for nearly all the
|
||||
desired functionality people didn't previously have.
|
||||
|
||||
=item Support for output other than TAP.
|
||||
|
||||
Test::Builder assumed everything would end up as TAP. Test2 makes no such
|
||||
assumption. Test2 provides ways for you to specify alternative and custom
|
||||
formatters.
|
||||
|
||||
=item Subtest implementation is more sane.
|
||||
|
||||
The Test::Builder implementation of subtests was certifiably insane. Test2 uses
|
||||
a stacked event hub system that greatly improves how subtests are implemented.
|
||||
|
||||
=item Support for threading/forking.
|
||||
|
||||
Test2 support for forking and threading can be turned on using L<Test2::IPC>.
|
||||
Once turned on threading and forking operate sanely and work as one would
|
||||
expect.
|
||||
|
||||
=back
|
||||
|
||||
=head1 GETTING STARTED
|
||||
|
||||
If you are interested in writing tests using new tools then you should look at
|
||||
L<Test2::Suite>. L<Test2::Suite> is a separate cpan distribution that contains
|
||||
many tools implemented on Test2.
|
||||
|
||||
If you are interested in writing new tools you should take a look at
|
||||
L<Test2::API> first.
|
||||
|
||||
=head1 NAMESPACE LAYOUT
|
||||
|
||||
This describes the namespace layout for the Test2 ecosystem. Not all the
|
||||
namespaces listed here are part of the Test2 distribution, some are implemented
|
||||
in L<Test2::Suite>.
|
||||
|
||||
=head2 Test2::Tools::
|
||||
|
||||
This namespace is for sets of tools. Modules in this namespace should export
|
||||
tools like C<ok()> and C<is()>. Most things written for Test2 should go here.
|
||||
Modules in this namespace B<MUST NOT> export subs from other tools. See the
|
||||
L</Test2::Bundle::> namespace if you want to do that.
|
||||
|
||||
=head2 Test2::Plugin::
|
||||
|
||||
This namespace is for plugins. Plugins are modules that change or enhance the
|
||||
behavior of Test2. An example of a plugin is a module that sets the encoding to
|
||||
utf8 globally. Another example is a module that causes a bail-out event after
|
||||
the first test failure.
|
||||
|
||||
=head2 Test2::Bundle::
|
||||
|
||||
This namespace is for bundles of tools and plugins. Loading one of these may
|
||||
load multiple tools and plugins. Modules in this namespace should not implement
|
||||
tools directly. In general modules in this namespace should load tools and
|
||||
plugins, then re-export things into the consumers namespace.
|
||||
|
||||
=head2 Test2::Require::
|
||||
|
||||
This namespace is for modules that cause a test to be skipped when conditions
|
||||
do not allow it to run. Examples would be modules that skip the test on older
|
||||
perls, or when non-essential modules have not been installed.
|
||||
|
||||
=head2 Test2::Formatter::
|
||||
|
||||
Formatters live under this namespace. L<Test2::Formatter::TAP> is the only
|
||||
formatter currently. It is acceptable for third party distributions to create
|
||||
new formatters under this namespace.
|
||||
|
||||
=head2 Test2::Event::
|
||||
|
||||
Events live under this namespace. It is considered acceptable for third party
|
||||
distributions to add new event types in this namespace.
|
||||
|
||||
=head2 Test2::Hub::
|
||||
|
||||
Hub subclasses (and some hub utility objects) live under this namespace. It is
|
||||
perfectly reasonable for third party distributions to add new hub subclasses in
|
||||
this namespace.
|
||||
|
||||
=head2 Test2::IPC::
|
||||
|
||||
The IPC subsystem lives in this namespace. There are not many good reasons to
|
||||
add anything to this namespace, with exception of IPC drivers.
|
||||
|
||||
=head3 Test2::IPC::Driver::
|
||||
|
||||
IPC drivers live in this namespace. It is fine to create new IPC drivers and to
|
||||
put them in this namespace.
|
||||
|
||||
=head2 Test2::Util::
|
||||
|
||||
This namespace is for general utilities used by testing tools. Please be
|
||||
considerate when adding new modules to this namespace.
|
||||
|
||||
=head2 Test2::API::
|
||||
|
||||
This is for Test2 API and related packages.
|
||||
|
||||
=head2 Test2::
|
||||
|
||||
The Test2:: namespace is intended for extensions and frameworks. Tools,
|
||||
Plugins, etc should not go directly into this namespace. However extensions
|
||||
that are used to build tools and plugins may go here.
|
||||
|
||||
In short: If the module exports anything that should be run directly by a test
|
||||
script it should probably NOT go directly into C<Test2::XXX>.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Test2::API> - Primary API functions.
|
||||
|
||||
L<Test2::API::Context> - Detailed documentation of the context object.
|
||||
|
||||
L<Test2::IPC> - The IPC system used for threading/fork support.
|
||||
|
||||
L<Test2::Formatter> - Formatters such as TAP live here.
|
||||
|
||||
L<Test2::Event> - Events live in this namespace.
|
||||
|
||||
L<Test2::Hub> - All events eventually funnel through a hub. Custom hubs are how
|
||||
C<intercept()> and C<run_subtest()> are implemented.
|
||||
|
||||
=head1 CONTACTING US
|
||||
|
||||
Many Test2 developers and users lurk on L<irc://irc.perl.org/#perl-qa> and
|
||||
L<irc://irc.perl.org/#toolchain>. We also have a slack team that can be joined
|
||||
by anyone with an C<@cpan.org> email address L<https://perl-test2.slack.com/>
|
||||
If you do not have an C<@cpan.org> email you can ask for a slack invite by
|
||||
emailing Chad Granum E<lt>exodist@cpan.orgE<gt>.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
1689
t/lib/Test2/API.pm
Normal file
1689
t/lib/Test2/API.pm
Normal file
File diff suppressed because it is too large
Load diff
180
t/lib/Test2/API/Breakage.pm
Normal file
180
t/lib/Test2/API/Breakage.pm
Normal file
|
|
@ -0,0 +1,180 @@
|
|||
package Test2::API::Breakage;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
use Test2::Util qw/pkg_to_file/;
|
||||
|
||||
our @EXPORT_OK = qw{
|
||||
upgrade_suggested
|
||||
upgrade_required
|
||||
known_broken
|
||||
};
|
||||
BEGIN { require Exporter; our @ISA = qw(Exporter) }
|
||||
|
||||
sub upgrade_suggested {
|
||||
return (
|
||||
'Test::Exception' => '0.42',
|
||||
'Test::FITesque' => '0.04',
|
||||
'Test::Module::Used' => '0.2.5',
|
||||
'Test::Moose::More' => '0.025',
|
||||
);
|
||||
}
|
||||
|
||||
sub upgrade_required {
|
||||
return (
|
||||
'Test::Builder::Clutch' => '0.07',
|
||||
'Test::Dist::VersionSync' => '1.1.4',
|
||||
'Test::Modern' => '0.012',
|
||||
'Test::SharedFork' => '0.34',
|
||||
'Test::Alien' => '0.04',
|
||||
'Test::UseAllModules' => '0.14',
|
||||
'Test::More::Prefix' => '0.005',
|
||||
|
||||
'Test2::Tools::EventDumper' => 0.000007,
|
||||
'Test2::Harness' => 0.000013,
|
||||
|
||||
'Test::DBIx::Class::Schema' => '1.0.9',
|
||||
'Test::Clustericious::Cluster' => '0.30',
|
||||
);
|
||||
}
|
||||
|
||||
sub known_broken {
|
||||
return (
|
||||
'Net::BitTorrent' => '0.052',
|
||||
'Test::Able' => '0.11',
|
||||
'Test::Aggregate' => '0.373',
|
||||
'Test::Flatten' => '0.11',
|
||||
'Test::Group' => '0.20',
|
||||
'Test::ParallelSubtest' => '0.05',
|
||||
'Test::Pretty' => '0.32',
|
||||
'Test::Wrapper' => '0.3.0',
|
||||
|
||||
'Log::Dispatch::Config::TestLog' => '0.02',
|
||||
);
|
||||
}
|
||||
|
||||
# Not reportable:
|
||||
# Device::Chip => 0.07 - Tests will not pass, but not broken if already installed, also no fixed version we can upgrade to.
|
||||
|
||||
sub report {
|
||||
my $class = shift;
|
||||
my ($require) = @_;
|
||||
|
||||
my %suggest = __PACKAGE__->upgrade_suggested();
|
||||
my %required = __PACKAGE__->upgrade_required();
|
||||
my %broken = __PACKAGE__->known_broken();
|
||||
|
||||
my @warn;
|
||||
for my $mod (keys %suggest) {
|
||||
my $file = pkg_to_file($mod);
|
||||
next unless $INC{$file} || ($require && eval { require $file; 1 });
|
||||
my $want = $suggest{$mod};
|
||||
next if eval { $mod->VERSION($want); 1 };
|
||||
my $error = $@;
|
||||
chomp $error;
|
||||
push @warn => " * Module '$mod' is outdated, we recommed updating above $want. error was: '$error'; INC is $INC{$file}";
|
||||
}
|
||||
|
||||
for my $mod (keys %required) {
|
||||
my $file = pkg_to_file($mod);
|
||||
next unless $INC{$file} || ($require && eval { require $file; 1 });
|
||||
my $want = $required{$mod};
|
||||
next if eval { $mod->VERSION($want); 1 };
|
||||
push @warn => " * Module '$mod' is outdated and known to be broken, please update to $want or higher.";
|
||||
}
|
||||
|
||||
for my $mod (keys %broken) {
|
||||
my $file = pkg_to_file($mod);
|
||||
next unless $INC{$file} || ($require && eval { require $file; 1 });
|
||||
my $tested = $broken{$mod};
|
||||
push @warn => " * Module '$mod' is known to be broken in version $tested and below, newer versions have not been tested. You have: " . $mod->VERSION;
|
||||
}
|
||||
|
||||
return @warn;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::API::Breakage - What breaks at what version
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides lists of modules that are broken, or have been broken in
|
||||
the past, when upgrading L<Test::Builder> to use L<Test2>.
|
||||
|
||||
=head1 FUNCTIONS
|
||||
|
||||
These can be imported, or called as methods on the class.
|
||||
|
||||
=over 4
|
||||
|
||||
=item %mod_ver = upgrade_suggested()
|
||||
|
||||
=item %mod_ver = Test2::API::Breakage->upgrade_suggested()
|
||||
|
||||
This returns key/value pairs. The key is the module name, the value is the
|
||||
version number. If the installed version of the module is at or below the
|
||||
specified one then an upgrade would be a good idea, but not strictly necessary.
|
||||
|
||||
=item %mod_ver = upgrade_required()
|
||||
|
||||
=item %mod_ver = Test2::API::Breakage->upgrade_required()
|
||||
|
||||
This returns key/value pairs. The key is the module name, the value is the
|
||||
version number. If the installed version of the module is at or below the
|
||||
specified one then an upgrade is required for the module to work properly.
|
||||
|
||||
=item %mod_ver = known_broken()
|
||||
|
||||
=item %mod_ver = Test2::API::Breakage->known_broken()
|
||||
|
||||
This returns key/value pairs. The key is the module name, the value is the
|
||||
version number. If the installed version of the module is at or below the
|
||||
specified one then the module will not work. A newer version may work, but is
|
||||
not tested or verified.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
1019
t/lib/Test2/API/Context.pm
Normal file
1019
t/lib/Test2/API/Context.pm
Normal file
File diff suppressed because it is too large
Load diff
822
t/lib/Test2/API/Instance.pm
Normal file
822
t/lib/Test2/API/Instance.pm
Normal file
|
|
@ -0,0 +1,822 @@
|
|||
package Test2::API::Instance;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/;
|
||||
use Carp qw/confess carp/;
|
||||
use Scalar::Util qw/reftype/;
|
||||
|
||||
use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try CAN_SIGSYS/;
|
||||
|
||||
use Test2::EventFacet::Trace();
|
||||
use Test2::API::Stack();
|
||||
|
||||
use Test2::Util::HashBase qw{
|
||||
_pid _tid
|
||||
no_wait
|
||||
finalized loaded
|
||||
ipc stack formatter
|
||||
contexts
|
||||
|
||||
add_uuid_via
|
||||
|
||||
-preload
|
||||
|
||||
ipc_disabled
|
||||
ipc_polling
|
||||
ipc_drivers
|
||||
ipc_timeout
|
||||
formatters
|
||||
|
||||
exit_callbacks
|
||||
post_load_callbacks
|
||||
context_acquire_callbacks
|
||||
context_init_callbacks
|
||||
context_release_callbacks
|
||||
pre_subtest_callbacks
|
||||
};
|
||||
|
||||
sub DEFAULT_IPC_TIMEOUT() { 30 }
|
||||
|
||||
sub pid { $_[0]->{+_PID} }
|
||||
sub tid { $_[0]->{+_TID} }
|
||||
|
||||
# Wrap around the getters that should call _finalize.
|
||||
BEGIN {
|
||||
for my $finalizer (IPC, FORMATTER) {
|
||||
my $orig = __PACKAGE__->can($finalizer);
|
||||
my $new = sub {
|
||||
my $self = shift;
|
||||
$self->_finalize unless $self->{+FINALIZED};
|
||||
$self->$orig;
|
||||
};
|
||||
|
||||
no strict 'refs';
|
||||
no warnings 'redefine';
|
||||
*{$finalizer} = $new;
|
||||
}
|
||||
}
|
||||
|
||||
sub has_ipc { !!$_[0]->{+IPC} }
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
return unless @_;
|
||||
my ($ref) = @_;
|
||||
$$ref = $class->new;
|
||||
}
|
||||
|
||||
sub init { $_[0]->reset }
|
||||
|
||||
sub start_preload {
|
||||
my $self = shift;
|
||||
|
||||
confess "preload cannot be started, Test2::API has already been initialized"
|
||||
if $self->{+FINALIZED} || $self->{+LOADED};
|
||||
|
||||
return $self->{+PRELOAD} = 1;
|
||||
}
|
||||
|
||||
sub stop_preload {
|
||||
my $self = shift;
|
||||
|
||||
return 0 unless $self->{+PRELOAD};
|
||||
$self->{+PRELOAD} = 0;
|
||||
|
||||
$self->post_preload_reset();
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub post_preload_reset {
|
||||
my $self = shift;
|
||||
|
||||
delete $self->{+_PID};
|
||||
delete $self->{+_TID};
|
||||
|
||||
$self->{+ADD_UUID_VIA} = undef unless exists $self->{+ADD_UUID_VIA};
|
||||
|
||||
$self->{+CONTEXTS} = {};
|
||||
|
||||
$self->{+FORMATTERS} = [];
|
||||
|
||||
$self->{+FINALIZED} = undef;
|
||||
$self->{+IPC} = undef;
|
||||
$self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0;
|
||||
|
||||
$self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT};
|
||||
|
||||
$self->{+LOADED} = 0;
|
||||
|
||||
$self->{+STACK} ||= Test2::API::Stack->new;
|
||||
}
|
||||
|
||||
sub reset {
|
||||
my $self = shift;
|
||||
|
||||
delete $self->{+_PID};
|
||||
delete $self->{+_TID};
|
||||
|
||||
$self->{+ADD_UUID_VIA} = undef;
|
||||
|
||||
$self->{+CONTEXTS} = {};
|
||||
|
||||
$self->{+IPC_DRIVERS} = [];
|
||||
$self->{+IPC_POLLING} = undef;
|
||||
|
||||
$self->{+FORMATTERS} = [];
|
||||
$self->{+FORMATTER} = undef;
|
||||
|
||||
$self->{+FINALIZED} = undef;
|
||||
$self->{+IPC} = undef;
|
||||
$self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0;
|
||||
|
||||
$self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT};
|
||||
|
||||
$self->{+NO_WAIT} = 0;
|
||||
$self->{+LOADED} = 0;
|
||||
|
||||
$self->{+EXIT_CALLBACKS} = [];
|
||||
$self->{+POST_LOAD_CALLBACKS} = [];
|
||||
$self->{+CONTEXT_ACQUIRE_CALLBACKS} = [];
|
||||
$self->{+CONTEXT_INIT_CALLBACKS} = [];
|
||||
$self->{+CONTEXT_RELEASE_CALLBACKS} = [];
|
||||
$self->{+PRE_SUBTEST_CALLBACKS} = [];
|
||||
|
||||
$self->{+STACK} = Test2::API::Stack->new;
|
||||
}
|
||||
|
||||
sub _finalize {
|
||||
my $self = shift;
|
||||
my ($caller) = @_;
|
||||
$caller ||= [caller(1)];
|
||||
|
||||
confess "Attempt to initialize Test2::API during preload"
|
||||
if $self->{+PRELOAD};
|
||||
|
||||
$self->{+FINALIZED} = $caller;
|
||||
|
||||
$self->{+_PID} = $$ unless defined $self->{+_PID};
|
||||
$self->{+_TID} = get_tid() unless defined $self->{+_TID};
|
||||
|
||||
unless ($self->{+FORMATTER}) {
|
||||
my ($formatter, $source);
|
||||
if ($ENV{T2_FORMATTER}) {
|
||||
$source = "set by the 'T2_FORMATTER' environment variable";
|
||||
|
||||
if ($ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) {
|
||||
$formatter = $1 ? $2 : "Test2::Formatter::$2"
|
||||
}
|
||||
else {
|
||||
$formatter = '';
|
||||
}
|
||||
}
|
||||
elsif (@{$self->{+FORMATTERS}}) {
|
||||
($formatter) = @{$self->{+FORMATTERS}};
|
||||
$source = "Most recently added";
|
||||
}
|
||||
else {
|
||||
$formatter = 'Test2::Formatter::TAP';
|
||||
$source = 'default formatter';
|
||||
}
|
||||
|
||||
unless (ref($formatter) || $formatter->can('write')) {
|
||||
my $file = pkg_to_file($formatter);
|
||||
my ($ok, $err) = try { require $file };
|
||||
unless ($ok) {
|
||||
my $line = "* COULD NOT LOAD FORMATTER '$formatter' ($source) *";
|
||||
my $border = '*' x length($line);
|
||||
die "\n\n $border\n $line\n $border\n\n$err";
|
||||
}
|
||||
}
|
||||
|
||||
$self->{+FORMATTER} = $formatter;
|
||||
}
|
||||
|
||||
# Turn on IPC if threads are on, drivers are registered, or the Test2::IPC
|
||||
# module is loaded.
|
||||
return if $self->{+IPC_DISABLED};
|
||||
return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}};
|
||||
|
||||
# Turn on polling by default, people expect it.
|
||||
$self->enable_ipc_polling;
|
||||
|
||||
unless (@{$self->{+IPC_DRIVERS}}) {
|
||||
my ($ok, $error) = try { require Test2::IPC::Driver::Files };
|
||||
die $error unless $ok;
|
||||
push @{$self->{+IPC_DRIVERS}} => 'Test2::IPC::Driver::Files';
|
||||
}
|
||||
|
||||
for my $driver (@{$self->{+IPC_DRIVERS}}) {
|
||||
next unless $driver->can('is_viable') && $driver->is_viable;
|
||||
$self->{+IPC} = $driver->new or next;
|
||||
return;
|
||||
}
|
||||
|
||||
die "IPC has been requested, but no viable drivers were found. Aborting...\n";
|
||||
}
|
||||
|
||||
sub formatter_set { $_[0]->{+FORMATTER} ? 1 : 0 }
|
||||
|
||||
sub add_formatter {
|
||||
my $self = shift;
|
||||
my ($formatter) = @_;
|
||||
unshift @{$self->{+FORMATTERS}} => $formatter;
|
||||
|
||||
return unless $self->{+FINALIZED};
|
||||
|
||||
# Why is the @CARP_NOT entry not enough?
|
||||
local %Carp::Internal = %Carp::Internal;
|
||||
$Carp::Internal{'Test2::Formatter'} = 1;
|
||||
|
||||
carp "Formatter $formatter loaded too late to be used as the global formatter";
|
||||
}
|
||||
|
||||
sub add_context_acquire_callback {
|
||||
my $self = shift;
|
||||
my ($code) = @_;
|
||||
|
||||
my $rtype = reftype($code) || "";
|
||||
|
||||
confess "Context-acquire callbacks must be coderefs"
|
||||
unless $code && $rtype eq 'CODE';
|
||||
|
||||
push @{$self->{+CONTEXT_ACQUIRE_CALLBACKS}} => $code;
|
||||
}
|
||||
|
||||
sub add_context_init_callback {
|
||||
my $self = shift;
|
||||
my ($code) = @_;
|
||||
|
||||
my $rtype = reftype($code) || "";
|
||||
|
||||
confess "Context-init callbacks must be coderefs"
|
||||
unless $code && $rtype eq 'CODE';
|
||||
|
||||
push @{$self->{+CONTEXT_INIT_CALLBACKS}} => $code;
|
||||
}
|
||||
|
||||
sub add_context_release_callback {
|
||||
my $self = shift;
|
||||
my ($code) = @_;
|
||||
|
||||
my $rtype = reftype($code) || "";
|
||||
|
||||
confess "Context-release callbacks must be coderefs"
|
||||
unless $code && $rtype eq 'CODE';
|
||||
|
||||
push @{$self->{+CONTEXT_RELEASE_CALLBACKS}} => $code;
|
||||
}
|
||||
|
||||
sub add_post_load_callback {
|
||||
my $self = shift;
|
||||
my ($code) = @_;
|
||||
|
||||
my $rtype = reftype($code) || "";
|
||||
|
||||
confess "Post-load callbacks must be coderefs"
|
||||
unless $code && $rtype eq 'CODE';
|
||||
|
||||
push @{$self->{+POST_LOAD_CALLBACKS}} => $code;
|
||||
$code->() if $self->{+LOADED};
|
||||
}
|
||||
|
||||
sub add_pre_subtest_callback {
|
||||
my $self = shift;
|
||||
my ($code) = @_;
|
||||
|
||||
my $rtype = reftype($code) || "";
|
||||
|
||||
confess "Pre-subtest callbacks must be coderefs"
|
||||
unless $code && $rtype eq 'CODE';
|
||||
|
||||
push @{$self->{+PRE_SUBTEST_CALLBACKS}} => $code;
|
||||
}
|
||||
|
||||
sub load {
|
||||
my $self = shift;
|
||||
unless ($self->{+LOADED}) {
|
||||
confess "Attempt to initialize Test2::API during preload"
|
||||
if $self->{+PRELOAD};
|
||||
|
||||
$self->{+_PID} = $$ unless defined $self->{+_PID};
|
||||
$self->{+_TID} = get_tid() unless defined $self->{+_TID};
|
||||
|
||||
# This is for https://github.com/Test-More/test-more/issues/16
|
||||
# and https://rt.perl.org/Public/Bug/Display.html?id=127774
|
||||
# END blocks run in reverse order. This insures the END block is loaded
|
||||
# as late as possible. It will not solve all cases, but it helps.
|
||||
eval "END { Test2::API::test2_set_is_end() }; 1" or die $@;
|
||||
|
||||
$self->{+LOADED} = 1;
|
||||
$_->() for @{$self->{+POST_LOAD_CALLBACKS}};
|
||||
}
|
||||
return $self->{+LOADED};
|
||||
}
|
||||
|
||||
sub add_exit_callback {
|
||||
my $self = shift;
|
||||
my ($code) = @_;
|
||||
my $rtype = reftype($code) || "";
|
||||
|
||||
confess "End callbacks must be coderefs"
|
||||
unless $code && $rtype eq 'CODE';
|
||||
|
||||
push @{$self->{+EXIT_CALLBACKS}} => $code;
|
||||
}
|
||||
|
||||
sub ipc_disable {
|
||||
my $self = shift;
|
||||
|
||||
confess "Attempt to disable IPC after it has been initialized"
|
||||
if $self->{+IPC};
|
||||
|
||||
$self->{+IPC_DISABLED} = 1;
|
||||
}
|
||||
|
||||
sub add_ipc_driver {
|
||||
my $self = shift;
|
||||
my ($driver) = @_;
|
||||
unshift @{$self->{+IPC_DRIVERS}} => $driver;
|
||||
|
||||
return unless $self->{+FINALIZED};
|
||||
|
||||
# Why is the @CARP_NOT entry not enough?
|
||||
local %Carp::Internal = %Carp::Internal;
|
||||
$Carp::Internal{'Test2::IPC::Driver'} = 1;
|
||||
|
||||
carp "IPC driver $driver loaded too late to be used as the global ipc driver";
|
||||
}
|
||||
|
||||
sub enable_ipc_polling {
|
||||
my $self = shift;
|
||||
|
||||
$self->{+_PID} = $$ unless defined $self->{+_PID};
|
||||
$self->{+_TID} = get_tid() unless defined $self->{+_TID};
|
||||
|
||||
$self->add_context_init_callback(
|
||||
# This is called every time a context is created, it needs to be fast.
|
||||
# $_[0] is a context object
|
||||
sub {
|
||||
return unless $self->{+IPC_POLLING};
|
||||
return unless $self->{+IPC};
|
||||
return unless $self->{+IPC}->pending();
|
||||
return $_[0]->{hub}->cull;
|
||||
}
|
||||
) unless defined $self->ipc_polling;
|
||||
|
||||
$self->set_ipc_polling(1);
|
||||
}
|
||||
|
||||
sub get_ipc_pending {
|
||||
my $self = shift;
|
||||
return -1 unless $self->{+IPC};
|
||||
$self->{+IPC}->pending();
|
||||
}
|
||||
|
||||
sub _check_pid {
|
||||
my $self = shift;
|
||||
my ($pid) = @_;
|
||||
return kill(0, $pid);
|
||||
}
|
||||
|
||||
sub set_ipc_pending {
|
||||
my $self = shift;
|
||||
return unless $self->{+IPC};
|
||||
my ($val) = @_;
|
||||
|
||||
confess "value is required for set_ipc_pending"
|
||||
unless $val;
|
||||
|
||||
$self->{+IPC}->set_pending($val);
|
||||
}
|
||||
|
||||
sub disable_ipc_polling {
|
||||
my $self = shift;
|
||||
return unless defined $self->{+IPC_POLLING};
|
||||
$self->{+IPC_POLLING} = 0;
|
||||
}
|
||||
|
||||
sub _ipc_wait {
|
||||
my ($timeout) = @_;
|
||||
my $fail = 0;
|
||||
|
||||
$timeout = DEFAULT_IPC_TIMEOUT() unless defined $timeout;
|
||||
|
||||
my $ok = eval {
|
||||
if (CAN_FORK) {
|
||||
local $SIG{ALRM} = sub { die "Timeout waiting on child processes" };
|
||||
alarm $timeout;
|
||||
|
||||
while (1) {
|
||||
my $pid = CORE::wait();
|
||||
my $err = $?;
|
||||
last if $pid == -1;
|
||||
next unless $err;
|
||||
$fail++;
|
||||
|
||||
my $sig = $err & 127;
|
||||
my $exit = $err >> 8;
|
||||
warn "Process $pid did not exit cleanly (wstat: $err, exit: $exit, sig: $sig)\n";
|
||||
}
|
||||
|
||||
alarm 0;
|
||||
}
|
||||
|
||||
if (USE_THREADS) {
|
||||
my $start = time;
|
||||
|
||||
while (1) {
|
||||
last unless threads->list();
|
||||
die "Timeout waiting on child thread" if time - $start >= $timeout;
|
||||
sleep 1;
|
||||
for my $t (threads->list) {
|
||||
# threads older than 1.34 do not have this :-(
|
||||
next if $t->can('is_joinable') && !$t->is_joinable;
|
||||
$t->join;
|
||||
# In older threads we cannot check if a thread had an error unless
|
||||
# we control it and its return.
|
||||
my $err = $t->can('error') ? $t->error : undef;
|
||||
next unless $err;
|
||||
my $tid = $t->tid();
|
||||
$fail++;
|
||||
chomp($err);
|
||||
warn "Thread $tid did not end cleanly: $err\n";
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
};
|
||||
my $error = $@;
|
||||
|
||||
return 0 if $ok && !$fail;
|
||||
warn $error unless $ok;
|
||||
return 255;
|
||||
}
|
||||
|
||||
sub set_exit {
|
||||
my $self = shift;
|
||||
|
||||
return if $self->{+PRELOAD};
|
||||
|
||||
my $exit = $?;
|
||||
my $new_exit = $exit;
|
||||
|
||||
if ($INC{'Test/Builder.pm'} && $Test::Builder::VERSION ne $Test2::API::VERSION) {
|
||||
print STDERR <<" EOT";
|
||||
|
||||
********************************************************************************
|
||||
* *
|
||||
* Test::Builder -- Test2::API version mismatch detected *
|
||||
* *
|
||||
********************************************************************************
|
||||
Test2::API Version: $Test2::API::VERSION
|
||||
Test::Builder Version: $Test::Builder::VERSION
|
||||
|
||||
This is not a supported configuration, you will have problems.
|
||||
|
||||
EOT
|
||||
}
|
||||
|
||||
for my $ctx (values %{$self->{+CONTEXTS}}) {
|
||||
next unless $ctx;
|
||||
|
||||
next if $ctx->_aborted && ${$ctx->_aborted};
|
||||
|
||||
# Only worry about contexts in this PID
|
||||
my $trace = $ctx->trace || next;
|
||||
next unless $trace->pid && $trace->pid == $$;
|
||||
|
||||
# Do not worry about contexts that have no hub
|
||||
my $hub = $ctx->hub || next;
|
||||
|
||||
# Do not worry if the state came to a sudden end.
|
||||
next if $hub->bailed_out;
|
||||
next if defined $hub->skip_reason;
|
||||
|
||||
# now we worry
|
||||
$trace->alert("context object was never released! This means a testing tool is behaving very badly");
|
||||
|
||||
$exit = 255;
|
||||
$new_exit = 255;
|
||||
}
|
||||
|
||||
if (!defined($self->{+_PID}) or !defined($self->{+_TID}) or $self->{+_PID} != $$ or $self->{+_TID} != get_tid()) {
|
||||
$? = $exit;
|
||||
return;
|
||||
}
|
||||
|
||||
my @hubs = $self->{+STACK} ? $self->{+STACK}->all : ();
|
||||
|
||||
if (@hubs and $self->{+IPC} and !$self->{+NO_WAIT}) {
|
||||
local $?;
|
||||
my %seen;
|
||||
for my $hub (reverse @hubs) {
|
||||
my $ipc = $hub->ipc or next;
|
||||
next if $seen{$ipc}++;
|
||||
$ipc->waiting();
|
||||
}
|
||||
|
||||
my $ipc_exit = _ipc_wait($self->{+IPC_TIMEOUT});
|
||||
$new_exit ||= $ipc_exit;
|
||||
}
|
||||
|
||||
# None of this is necessary if we never got a root hub
|
||||
if(my $root = shift @hubs) {
|
||||
my $trace = Test2::EventFacet::Trace->new(
|
||||
frame => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'],
|
||||
detail => __PACKAGE__ . ' END Block finalization',
|
||||
);
|
||||
my $ctx = Test2::API::Context->new(
|
||||
trace => $trace,
|
||||
hub => $root,
|
||||
);
|
||||
|
||||
if (@hubs) {
|
||||
$ctx->diag("Test ended with extra hubs on the stack!");
|
||||
$new_exit = 255;
|
||||
}
|
||||
|
||||
unless ($root->no_ending) {
|
||||
local $?;
|
||||
$root->finalize($trace) unless $root->ended;
|
||||
$_->($ctx, $exit, \$new_exit) for @{$self->{+EXIT_CALLBACKS}};
|
||||
$new_exit ||= $root->failed;
|
||||
$new_exit ||= 255 unless $root->is_passing;
|
||||
}
|
||||
}
|
||||
|
||||
$new_exit = 255 if $new_exit > 255;
|
||||
|
||||
if ($new_exit && eval { require Test2::API::Breakage; 1 }) {
|
||||
my @warn = Test2::API::Breakage->report();
|
||||
|
||||
if (@warn) {
|
||||
print STDERR "\nYou have loaded versions of test modules known to have problems with Test2.\nThis could explain some test failures.\n";
|
||||
print STDERR "$_\n" for @warn;
|
||||
print STDERR "\n";
|
||||
}
|
||||
}
|
||||
|
||||
$? = $new_exit;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::API::Instance - Object used by Test2::API under the hood
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This object encapsulates the global shared state tracked by
|
||||
L<Test2>. A single global instance of this package is stored (and
|
||||
obscured) by the L<Test2::API> package.
|
||||
|
||||
There is no reason to directly use this package. This package is documented for
|
||||
completeness. This package can change, or go away completely at any time.
|
||||
Directly using, or monkeypatching this package is not supported in any way
|
||||
shape or form.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::API::Instance;
|
||||
|
||||
my $obj = Test2::API::Instance->new;
|
||||
|
||||
=over 4
|
||||
|
||||
=item $pid = $obj->pid
|
||||
|
||||
PID of this instance.
|
||||
|
||||
=item $obj->tid
|
||||
|
||||
Thread ID of this instance.
|
||||
|
||||
=item $obj->reset()
|
||||
|
||||
Reset the object to defaults.
|
||||
|
||||
=item $obj->load()
|
||||
|
||||
Set the internal state to loaded, and run and stored post-load callbacks.
|
||||
|
||||
=item $bool = $obj->loaded
|
||||
|
||||
Check if the state is set to loaded.
|
||||
|
||||
=item $arrayref = $obj->post_load_callbacks
|
||||
|
||||
Get the post-load callbacks.
|
||||
|
||||
=item $obj->add_post_load_callback(sub { ... })
|
||||
|
||||
Add a post-load callback. If C<load()> has already been called then the callback will
|
||||
be immediately executed. If C<load()> has not been called then the callback will be
|
||||
stored and executed later when C<load()> is called.
|
||||
|
||||
=item $hashref = $obj->contexts()
|
||||
|
||||
Get a hashref of all active contexts keyed by hub id.
|
||||
|
||||
=item $arrayref = $obj->context_acquire_callbacks
|
||||
|
||||
Get all context acquire callbacks.
|
||||
|
||||
=item $arrayref = $obj->context_init_callbacks
|
||||
|
||||
Get all context init callbacks.
|
||||
|
||||
=item $arrayref = $obj->context_release_callbacks
|
||||
|
||||
Get all context release callbacks.
|
||||
|
||||
=item $arrayref = $obj->pre_subtest_callbacks
|
||||
|
||||
Get all pre-subtest callbacks.
|
||||
|
||||
=item $obj->add_context_init_callback(sub { ... })
|
||||
|
||||
Add a context init callback. Subs are called every time a context is created. Subs
|
||||
get the newly created context as their only argument.
|
||||
|
||||
=item $obj->add_context_release_callback(sub { ... })
|
||||
|
||||
Add a context release callback. Subs are called every time a context is released. Subs
|
||||
get the released context as their only argument. These callbacks should not
|
||||
call release on the context.
|
||||
|
||||
=item $obj->add_pre_subtest_callback(sub { ... })
|
||||
|
||||
Add a pre-subtest callback. Subs are called every time a subtest is
|
||||
going to be run. Subs get the subtest name, coderef, and any
|
||||
arguments.
|
||||
|
||||
=item $obj->set_exit()
|
||||
|
||||
This is intended to be called in an C<END { ... }> block. This will look at
|
||||
test state and set $?. This will also call any end callbacks, and wait on child
|
||||
processes/threads.
|
||||
|
||||
=item $obj->set_ipc_pending($val)
|
||||
|
||||
Tell other processes and threads there is a pending event. C<$val> should be a
|
||||
unique value no other thread/process will generate.
|
||||
|
||||
B<Note:> This will also make the current process see a pending event.
|
||||
|
||||
=item $pending = $obj->get_ipc_pending()
|
||||
|
||||
This returns -1 if it is not possible to know.
|
||||
|
||||
This returns 0 if there are no pending events.
|
||||
|
||||
This returns 1 if there are pending events.
|
||||
|
||||
=item $timeout = $obj->ipc_timeout;
|
||||
|
||||
=item $obj->set_ipc_timeout($timeout);
|
||||
|
||||
How long to wait for child processes and threads before aborting.
|
||||
|
||||
=item $drivers = $obj->ipc_drivers
|
||||
|
||||
Get the list of IPC drivers.
|
||||
|
||||
=item $obj->add_ipc_driver($DRIVER_CLASS)
|
||||
|
||||
Add an IPC driver to the list. The most recently added IPC driver will become
|
||||
the global one during initialization. If a driver is added after initialization
|
||||
has occurred a warning will be generated:
|
||||
|
||||
"IPC driver $driver loaded too late to be used as the global ipc driver"
|
||||
|
||||
=item $bool = $obj->ipc_polling
|
||||
|
||||
Check if polling is enabled.
|
||||
|
||||
=item $obj->enable_ipc_polling
|
||||
|
||||
Turn on polling. This will cull events from other processes and threads every
|
||||
time a context is created.
|
||||
|
||||
=item $obj->disable_ipc_polling
|
||||
|
||||
Turn off IPC polling.
|
||||
|
||||
=item $bool = $obj->no_wait
|
||||
|
||||
=item $bool = $obj->set_no_wait($bool)
|
||||
|
||||
Get/Set no_wait. This option is used to turn off process/thread waiting at exit.
|
||||
|
||||
=item $arrayref = $obj->exit_callbacks
|
||||
|
||||
Get the exit callbacks.
|
||||
|
||||
=item $obj->add_exit_callback(sub { ... })
|
||||
|
||||
Add an exit callback. This callback will be called by C<set_exit()>.
|
||||
|
||||
=item $bool = $obj->finalized
|
||||
|
||||
Check if the object is finalized. Finalization happens when either C<ipc()>,
|
||||
C<stack()>, or C<format()> are called on the object. Once finalization happens
|
||||
these fields are considered unchangeable (not enforced here, enforced by
|
||||
L<Test2>).
|
||||
|
||||
=item $ipc = $obj->ipc
|
||||
|
||||
Get the one true IPC instance.
|
||||
|
||||
=item $obj->ipc_disable
|
||||
|
||||
Turn IPC off
|
||||
|
||||
=item $bool = $obj->ipc_disabled
|
||||
|
||||
Check if IPC is disabled
|
||||
|
||||
=item $stack = $obj->stack
|
||||
|
||||
Get the one true hub stack.
|
||||
|
||||
=item $formatter = $obj->formatter
|
||||
|
||||
Get the global formatter. By default this is the C<'Test2::Formatter::TAP'>
|
||||
package. This could be any package that implements the C<write()> method. This
|
||||
can also be an instantiated object.
|
||||
|
||||
=item $bool = $obj->formatter_set()
|
||||
|
||||
Check if a formatter has been set.
|
||||
|
||||
=item $obj->add_formatter($class)
|
||||
|
||||
=item $obj->add_formatter($obj)
|
||||
|
||||
Add a formatter. The most recently added formatter will become the global one
|
||||
during initialization. If a formatter is added after initialization has occurred
|
||||
a warning will be generated:
|
||||
|
||||
"Formatter $formatter loaded too late to be used as the global formatter"
|
||||
|
||||
=item $obj->set_add_uuid_via(sub { ... })
|
||||
|
||||
=item $sub = $obj->add_uuid_via()
|
||||
|
||||
This allows you to provide a UUID generator. If provided UUIDs will be attached
|
||||
to all events, hubs, and contexts. This is useful for storing, tracking, and
|
||||
linking these objects.
|
||||
|
||||
The sub you provide should always return a unique identifier. Most things will
|
||||
expect a proper UUID string, however nothing in Test2::API enforces this.
|
||||
|
||||
The sub will receive exactly 1 argument, the type of thing being tagged
|
||||
'context', 'hub', or 'event'. In the future additional things may be tagged, in
|
||||
which case new strings will be passed in. These are purely informative, you can
|
||||
(and usually should) ignore them.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
226
t/lib/Test2/API/Stack.pm
Normal file
226
t/lib/Test2/API/Stack.pm
Normal file
|
|
@ -0,0 +1,226 @@
|
|||
package Test2::API::Stack;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
use Test2::Hub();
|
||||
|
||||
use Carp qw/confess/;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
return bless [], $class;
|
||||
}
|
||||
|
||||
sub new_hub {
|
||||
my $self = shift;
|
||||
my %params = @_;
|
||||
|
||||
my $class = delete $params{class} || 'Test2::Hub';
|
||||
|
||||
my $hub = $class->new(%params);
|
||||
|
||||
if (@$self) {
|
||||
$hub->inherit($self->[-1], %params);
|
||||
}
|
||||
else {
|
||||
require Test2::API;
|
||||
$hub->format(Test2::API::test2_formatter()->new_root)
|
||||
unless $hub->format || exists($params{formatter});
|
||||
|
||||
my $ipc = Test2::API::test2_ipc();
|
||||
if ($ipc && !$hub->ipc && !exists($params{ipc})) {
|
||||
$hub->set_ipc($ipc);
|
||||
$ipc->add_hub($hub->hid);
|
||||
}
|
||||
}
|
||||
|
||||
push @$self => $hub;
|
||||
|
||||
$hub;
|
||||
}
|
||||
|
||||
sub top {
|
||||
my $self = shift;
|
||||
return $self->new_hub unless @$self;
|
||||
return $self->[-1];
|
||||
}
|
||||
|
||||
sub peek {
|
||||
my $self = shift;
|
||||
return @$self ? $self->[-1] : undef;
|
||||
}
|
||||
|
||||
sub cull {
|
||||
my $self = shift;
|
||||
$_->cull for reverse @$self;
|
||||
}
|
||||
|
||||
sub all {
|
||||
my $self = shift;
|
||||
return @$self;
|
||||
}
|
||||
|
||||
sub root {
|
||||
my $self = shift;
|
||||
return unless @$self;
|
||||
return $self->[0];
|
||||
}
|
||||
|
||||
sub clear {
|
||||
my $self = shift;
|
||||
@$self = ();
|
||||
}
|
||||
|
||||
# Do these last without keywords in order to prevent them from getting used
|
||||
# when we want the real push/pop.
|
||||
|
||||
{
|
||||
no warnings 'once';
|
||||
|
||||
*push = sub {
|
||||
my $self = shift;
|
||||
my ($hub) = @_;
|
||||
$hub->inherit($self->[-1]) if @$self;
|
||||
push @$self => $hub;
|
||||
};
|
||||
|
||||
*pop = sub {
|
||||
my $self = shift;
|
||||
my ($hub) = @_;
|
||||
confess "No hubs on the stack"
|
||||
unless @$self;
|
||||
confess "You cannot pop the root hub"
|
||||
if 1 == @$self;
|
||||
confess "Hub stack mismatch, attempted to pop incorrect hub"
|
||||
unless $self->[-1] == $hub;
|
||||
pop @$self;
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::API::Stack - Object to manage a stack of L<Test2::Hub>
|
||||
instances.
|
||||
|
||||
=head1 ***INTERNALS NOTE***
|
||||
|
||||
B<The internals of this package are subject to change at any time!> The public
|
||||
methods provided will not change in backwards incompatible ways, but the
|
||||
underlying implementation details might. B<Do not break encapsulation here!>
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module is used to represent and manage a stack of L<Test2::Hub>
|
||||
objects. Hubs are usually in a stack so that you can push a new hub into place
|
||||
that can intercept and handle events differently than the primary hub.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $stack = Test2::API::Stack->new;
|
||||
my $hub = $stack->top;
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $stack = Test2::API::Stack->new()
|
||||
|
||||
This will create a new empty stack instance. All arguments are ignored.
|
||||
|
||||
=item $hub = $stack->new_hub()
|
||||
|
||||
=item $hub = $stack->new_hub(%params)
|
||||
|
||||
=item $hub = $stack->new_hub(%params, class => $class)
|
||||
|
||||
This will generate a new hub and push it to the top of the stack. Optionally
|
||||
you can provide arguments that will be passed into the constructor for the
|
||||
L<Test2::Hub> object.
|
||||
|
||||
If you specify the C<< 'class' => $class >> argument, the new hub will be an
|
||||
instance of the specified class.
|
||||
|
||||
Unless your parameters specify C<'formatter'> or C<'ipc'> arguments, the
|
||||
formatter and IPC instance will be inherited from the current top hub. You can
|
||||
set the parameters to C<undef> to avoid having a formatter or IPC instance.
|
||||
|
||||
If there is no top hub, and you do not ask to leave IPC and formatter undef,
|
||||
then a new formatter will be created, and the IPC instance from
|
||||
L<Test2::API> will be used.
|
||||
|
||||
=item $hub = $stack->top()
|
||||
|
||||
This will return the top hub from the stack. If there is no top hub yet this
|
||||
will create it.
|
||||
|
||||
=item $hub = $stack->peek()
|
||||
|
||||
This will return the top hub from the stack. If there is no top hub yet this
|
||||
will return undef.
|
||||
|
||||
=item $stack->cull
|
||||
|
||||
This will call C<< $hub->cull >> on all hubs in the stack.
|
||||
|
||||
=item @hubs = $stack->all
|
||||
|
||||
This will return all the hubs in the stack as a list.
|
||||
|
||||
=item $stack->clear
|
||||
|
||||
This will completely remove all hubs from the stack. Normally you do not want
|
||||
to do this, but there are a few valid reasons for it.
|
||||
|
||||
=item $stack->push($hub)
|
||||
|
||||
This will push the new hub onto the stack.
|
||||
|
||||
=item $stack->pop($hub)
|
||||
|
||||
This will pop a hub from the stack, if the hub at the top of the stack does not
|
||||
match the hub you expect (passed in as an argument) it will throw an exception.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
778
t/lib/Test2/Event.pm
Normal file
778
t/lib/Test2/Event.pm
Normal file
|
|
@ -0,0 +1,778 @@
|
|||
package Test2::Event;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
use Scalar::Util qw/blessed reftype/;
|
||||
use Carp qw/croak/;
|
||||
|
||||
use Test2::Util::HashBase qw/trace -amnesty uuid -_eid -hubs/;
|
||||
use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
|
||||
use Test2::Util qw/pkg_to_file gen_uid/;
|
||||
|
||||
use Test2::EventFacet::About();
|
||||
use Test2::EventFacet::Amnesty();
|
||||
use Test2::EventFacet::Assert();
|
||||
use Test2::EventFacet::Control();
|
||||
use Test2::EventFacet::Error();
|
||||
use Test2::EventFacet::Info();
|
||||
use Test2::EventFacet::Meta();
|
||||
use Test2::EventFacet::Parent();
|
||||
use Test2::EventFacet::Plan();
|
||||
use Test2::EventFacet::Trace();
|
||||
use Test2::EventFacet::Hub();
|
||||
|
||||
# Legacy tools will expect this to be loaded now
|
||||
require Test2::Util::Trace;
|
||||
|
||||
my %LOADED_FACETS = (
|
||||
'about' => 'Test2::EventFacet::About',
|
||||
'amnesty' => 'Test2::EventFacet::Amnesty',
|
||||
'assert' => 'Test2::EventFacet::Assert',
|
||||
'control' => 'Test2::EventFacet::Control',
|
||||
'errors' => 'Test2::EventFacet::Error',
|
||||
'info' => 'Test2::EventFacet::Info',
|
||||
'meta' => 'Test2::EventFacet::Meta',
|
||||
'parent' => 'Test2::EventFacet::Parent',
|
||||
'plan' => 'Test2::EventFacet::Plan',
|
||||
'trace' => 'Test2::EventFacet::Trace',
|
||||
'hubs' => 'Test2::EventFacet::Hub',
|
||||
);
|
||||
|
||||
sub FACET_TYPES { sort values %LOADED_FACETS }
|
||||
|
||||
sub load_facet {
|
||||
my $class = shift;
|
||||
my ($facet) = @_;
|
||||
|
||||
return $LOADED_FACETS{$facet} if exists $LOADED_FACETS{$facet};
|
||||
|
||||
my @check = ($facet);
|
||||
if ('s' eq substr($facet, -1, 1)) {
|
||||
push @check => substr($facet, 0, -1);
|
||||
}
|
||||
else {
|
||||
push @check => $facet . 's';
|
||||
}
|
||||
|
||||
my $found;
|
||||
for my $check (@check) {
|
||||
my $mod = "Test2::EventFacet::" . ucfirst($facet);
|
||||
my $file = pkg_to_file($mod);
|
||||
next unless eval { require $file; 1 };
|
||||
$found = $mod;
|
||||
last;
|
||||
}
|
||||
|
||||
return undef unless $found;
|
||||
$LOADED_FACETS{$facet} = $found;
|
||||
}
|
||||
|
||||
sub causes_fail { 0 }
|
||||
sub increments_count { 0 }
|
||||
sub diagnostics { 0 }
|
||||
sub no_display { 0 }
|
||||
sub subtest_id { undef }
|
||||
|
||||
sub callback { }
|
||||
|
||||
sub terminate { () }
|
||||
sub global { () }
|
||||
sub sets_plan { () }
|
||||
|
||||
sub summary { ref($_[0]) }
|
||||
|
||||
sub related {
|
||||
my $self = shift;
|
||||
my ($event) = @_;
|
||||
|
||||
my $tracea = $self->trace or return undef;
|
||||
my $traceb = $event->trace or return undef;
|
||||
|
||||
my $uuida = $tracea->uuid;
|
||||
my $uuidb = $traceb->uuid;
|
||||
if ($uuida && $uuidb) {
|
||||
return 1 if $uuida eq $uuidb;
|
||||
return 0;
|
||||
}
|
||||
|
||||
my $siga = $tracea->signature or return undef;
|
||||
my $sigb = $traceb->signature or return undef;
|
||||
|
||||
return 1 if $siga eq $sigb;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub add_hub {
|
||||
my $self = shift;
|
||||
unshift @{$self->{+HUBS}} => @_;
|
||||
}
|
||||
|
||||
sub add_amnesty {
|
||||
my $self = shift;
|
||||
|
||||
for my $am (@_) {
|
||||
$am = {%$am} if ref($am) ne 'ARRAY';
|
||||
$am = Test2::EventFacet::Amnesty->new($am);
|
||||
|
||||
push @{$self->{+AMNESTY}} => $am;
|
||||
}
|
||||
}
|
||||
|
||||
sub eid { $_[0]->{+_EID} ||= gen_uid() }
|
||||
|
||||
sub common_facet_data {
|
||||
my $self = shift;
|
||||
|
||||
my %out;
|
||||
|
||||
$out{about} = {package => ref($self) || undef};
|
||||
if (my $uuid = $self->uuid) {
|
||||
$out{about}->{uuid} = $uuid;
|
||||
}
|
||||
|
||||
$out{about}->{eid} = $self->{+_EID} || $self->eid;
|
||||
|
||||
if (my $trace = $self->trace) {
|
||||
$out{trace} = { %$trace };
|
||||
}
|
||||
|
||||
if (my $hubs = $self->hubs) {
|
||||
$out{hubs} = $hubs;
|
||||
}
|
||||
|
||||
$out{amnesty} = [map {{ %{$_} }} @{$self->{+AMNESTY}}]
|
||||
if $self->{+AMNESTY};
|
||||
|
||||
if (my $meta = $self->meta_facet_data) {
|
||||
$out{meta} = $meta;
|
||||
}
|
||||
|
||||
return \%out;
|
||||
}
|
||||
|
||||
sub meta_facet_data {
|
||||
my $self = shift;
|
||||
|
||||
my $key = Test2::Util::ExternalMeta::META_KEY();
|
||||
|
||||
my $hash = $self->{$key} or return undef;
|
||||
return {%$hash};
|
||||
}
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
|
||||
my $out = $self->common_facet_data;
|
||||
|
||||
$out->{about}->{details} = $self->summary || undef;
|
||||
$out->{about}->{no_display} = $self->no_display || undef;
|
||||
|
||||
# Might be undef, we want to preserve that
|
||||
my $terminate = $self->terminate;
|
||||
$out->{control} = {
|
||||
global => $self->global || 0,
|
||||
terminate => $terminate,
|
||||
has_callback => $self->can('callback') == \&callback ? 0 : 1,
|
||||
};
|
||||
|
||||
$out->{assert} = {
|
||||
no_debug => 1, # Legacy behavior
|
||||
pass => $self->causes_fail ? 0 : 1,
|
||||
details => $self->summary,
|
||||
} if $self->increments_count;
|
||||
|
||||
$out->{parent} = {hid => $self->subtest_id} if $self->subtest_id;
|
||||
|
||||
if (my @plan = $self->sets_plan) {
|
||||
$out->{plan} = {};
|
||||
|
||||
$out->{plan}->{count} = $plan[0] if defined $plan[0];
|
||||
$out->{plan}->{details} = $plan[2] if defined $plan[2];
|
||||
|
||||
if ($plan[1]) {
|
||||
$out->{plan}->{skip} = 1 if $plan[1] eq 'SKIP';
|
||||
$out->{plan}->{none} = 1 if $plan[1] eq 'NO PLAN';
|
||||
}
|
||||
|
||||
$out->{control}->{terminate} ||= 0 if $out->{plan}->{skip};
|
||||
}
|
||||
|
||||
if ($self->causes_fail && !$out->{assert}) {
|
||||
$out->{errors} = [
|
||||
{
|
||||
tag => 'FAIL',
|
||||
fail => 1,
|
||||
details => $self->summary,
|
||||
}
|
||||
];
|
||||
}
|
||||
|
||||
my %IGNORE = (trace => 1, about => 1, control => 1);
|
||||
my $do_info = !grep { !$IGNORE{$_} } keys %$out;
|
||||
|
||||
if ($do_info && !$self->no_display && $self->diagnostics) {
|
||||
$out->{info} = [
|
||||
{
|
||||
tag => 'DIAG',
|
||||
debug => 1,
|
||||
details => $self->summary,
|
||||
}
|
||||
];
|
||||
}
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub facets {
|
||||
my $self = shift;
|
||||
my %out;
|
||||
|
||||
my $data = $self->facet_data;
|
||||
my @errors = $self->validate_facet_data($data);
|
||||
die join "\n" => @errors if @errors;
|
||||
|
||||
for my $facet (keys %$data) {
|
||||
my $class = $self->load_facet($facet);
|
||||
my $val = $data->{$facet};
|
||||
|
||||
unless($class) {
|
||||
$out{$facet} = $val;
|
||||
next;
|
||||
}
|
||||
|
||||
my $is_list = reftype($val) eq 'ARRAY' ? 1 : 0;
|
||||
if ($is_list) {
|
||||
$out{$facet} = [map { $class->new($_) } @$val];
|
||||
}
|
||||
else {
|
||||
$out{$facet} = $class->new($val);
|
||||
}
|
||||
}
|
||||
|
||||
return \%out;
|
||||
}
|
||||
|
||||
sub validate_facet_data {
|
||||
my $class_or_self = shift;
|
||||
my ($f, %params);
|
||||
|
||||
$f = shift if @_ && (reftype($_[0]) || '') eq 'HASH';
|
||||
%params = @_;
|
||||
|
||||
$f ||= $class_or_self->facet_data if blessed($class_or_self);
|
||||
croak "No facet data" unless $f;
|
||||
|
||||
my @errors;
|
||||
|
||||
for my $k (sort keys %$f) {
|
||||
my $fclass = $class_or_self->load_facet($k);
|
||||
|
||||
push @errors => "Could not find a facet class for facet '$k'"
|
||||
if $params{require_facet_class} && !$fclass;
|
||||
|
||||
next unless $fclass;
|
||||
|
||||
my $v = $f->{$k};
|
||||
next unless defined($v); # undef is always fine
|
||||
|
||||
my $is_list = $fclass->is_list();
|
||||
my $got_list = reftype($v) eq 'ARRAY' ? 1 : 0;
|
||||
|
||||
push @errors => "Facet '$k' should be a list, but got a single item ($v)"
|
||||
if $is_list && !$got_list;
|
||||
|
||||
push @errors => "Facet '$k' should not be a list, but got a a list ($v)"
|
||||
if $got_list && !$is_list;
|
||||
}
|
||||
|
||||
return @errors;
|
||||
}
|
||||
|
||||
sub nested {
|
||||
my $self = shift;
|
||||
|
||||
Carp::cluck("Use of Test2::Event->nested() is deprecated, use Test2::Event->trace->nested instead")
|
||||
if $ENV{AUTHOR_TESTING};
|
||||
|
||||
if (my $hubs = $self->{+HUBS}) {
|
||||
return $hubs->[0]->{nested} if @$hubs;
|
||||
}
|
||||
|
||||
my $trace = $self->{+TRACE} or return undef;
|
||||
return $trace->{nested};
|
||||
}
|
||||
|
||||
sub in_subtest {
|
||||
my $self = shift;
|
||||
|
||||
Carp::cluck("Use of Test2::Event->in_subtest() is deprecated, use Test2::Event->trace->hid instead")
|
||||
if $ENV{AUTHOR_TESTING};
|
||||
|
||||
my $hubs = $self->{+HUBS};
|
||||
if ($hubs && @$hubs) {
|
||||
return undef unless $hubs->[0]->{nested};
|
||||
return $hubs->[0]->{hid}
|
||||
}
|
||||
|
||||
my $trace = $self->{+TRACE} or return undef;
|
||||
return undef unless $trace->{nested};
|
||||
return $trace->{hid};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event - Base class for events
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Base class for all event objects that get passed through
|
||||
L<Test2>.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Test2::Event::MyEvent;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# This will make our class an event subclass (required)
|
||||
use base 'Test2::Event';
|
||||
|
||||
# Add some accessors (optional)
|
||||
# You are not obligated to use HashBase, you can use any object tool you
|
||||
# want, or roll your own accessors.
|
||||
use Test2::Util::HashBase qw/foo bar baz/;
|
||||
|
||||
# Use this if you want the legacy API to be written for you, for this to
|
||||
# work you will need to implement a facet_data() method.
|
||||
use Test2::Util::Facets2Legacy;
|
||||
|
||||
# Chance to initialize some defaults
|
||||
sub init {
|
||||
my $self = shift;
|
||||
# no other args in @_
|
||||
|
||||
$self->set_foo('xxx') unless defined $self->foo;
|
||||
|
||||
...
|
||||
}
|
||||
|
||||
# This is the new way for events to convey data to the Test2 system
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
|
||||
# Get common facets such as 'about', 'trace' 'amnesty', and 'meta'
|
||||
my $facet_data = $self->common_facet_data();
|
||||
|
||||
# Are you making an assertion?
|
||||
$facet_data->{assert} = {pass => 1, details => 'my assertion'};
|
||||
...
|
||||
|
||||
return $facet_data;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 GENERAL
|
||||
|
||||
=over 4
|
||||
|
||||
=item $trace = $e->trace
|
||||
|
||||
Get a snapshot of the L<Test2::EventFacet::Trace> as it was when this event was
|
||||
generated
|
||||
|
||||
=item $bool_or_undef = $e->related($e2)
|
||||
|
||||
Check if 2 events are related. In this case related means their traces share a
|
||||
signature meaning they were created with the same context (or at the very least
|
||||
by contexts which share an id, which is the same thing unless someone is doing
|
||||
something very bad).
|
||||
|
||||
This can be used to reliably link multiple events created by the same tool. For
|
||||
instance a failing test like C<ok(0, "fail"> will generate 2 events, one being
|
||||
a L<Test2::Event::Ok>, the other being a L<Test2::Event::Diag>, both of these
|
||||
events are related having been created under the same context and by the same
|
||||
initial tool (though multiple tools may have been nested under the initial
|
||||
one).
|
||||
|
||||
This will return C<undef> if the relationship cannot be checked, which happens
|
||||
if either event has an incomplete or missing trace. This will return C<0> if
|
||||
the traces are complete, but do not match. C<1> will be returned if there is a
|
||||
match.
|
||||
|
||||
=item $e->add_amnesty({tag => $TAG, details => $DETAILS});
|
||||
|
||||
This can be used to add amnesty to this event. Amnesty only effects failing
|
||||
assertions in most cases, but some formatters may display them for passing
|
||||
assertions, or even non-assertions as well.
|
||||
|
||||
Amnesty will prevent a failed assertion from causing the overall test to fail.
|
||||
In other words it marks a failure as expected and allowed.
|
||||
|
||||
B<Note:> This is how 'TODO' is implemented under the hood. TODO is essentially
|
||||
amnesty with the 'TODO' tag. The details are the reason for the TODO.
|
||||
|
||||
=item $uuid = $e->uuid
|
||||
|
||||
If UUID tagging is enabled (See L<Test::API>) then any event that has made its
|
||||
way through a hub will be tagged with a UUID. A newly created event will not
|
||||
yet be tagged in most cases.
|
||||
|
||||
=item $class = $e->load_facet($name)
|
||||
|
||||
This method is used to load a facet by name (or key). It will attempt to load
|
||||
the facet class, if it succeeds it will return the class it loaded. If it fails
|
||||
it will return C<undef>. This caches the result at the class level so that
|
||||
future calls will be faster.
|
||||
|
||||
The C<$name> variable should be the key used to access the facet in a facets
|
||||
hashref. For instance the assertion facet has the key 'assert', the information
|
||||
facet has the 'info' key, and the error facet has the key 'errors'. You may
|
||||
include or omit the 's' at the end of the name, the method is smart enough to
|
||||
try both the 's' and no-'s' forms, it will check what you provided first, and
|
||||
if that is not found it will add or strip the 's and try again.
|
||||
|
||||
=item @classes = $e->FACET_TYPES()
|
||||
|
||||
=item @classes = Test2::Event->FACET_TYPES()
|
||||
|
||||
This returns a list of all facets that have been loaded using the
|
||||
C<load_facet()> method. This will not return any classes that have not been
|
||||
loaded, or have been loaded directly without a call to C<load_facet()>.
|
||||
|
||||
B<Note:> The core facet types are automatically loaded and populated in this
|
||||
list.
|
||||
|
||||
=back
|
||||
|
||||
=head2 NEW API
|
||||
|
||||
=over 4
|
||||
|
||||
=item $hashref = $e->common_facet_data();
|
||||
|
||||
This can be used by subclasses to generate a starting facet data hashref. This
|
||||
will populate the hashref with the trace, meta, amnesty, and about facets.
|
||||
These facets are nearly always produced the same way for all events.
|
||||
|
||||
=item $hashref = $e->facet_data()
|
||||
|
||||
If you do not override this then the default implementation will attempt to
|
||||
generate facets from the legacy API. This generation is limited only to what
|
||||
the legacy API can provide. It is recommended that you override this method and
|
||||
write out explicit facet data.
|
||||
|
||||
=item $hashref = $e->facets()
|
||||
|
||||
This takes the hashref from C<facet_data()> and blesses each facet into the
|
||||
proper C<Test2::EventFacet::*> subclass. If no class can be found for any given
|
||||
facet it will be passed along unchanged.
|
||||
|
||||
=item @errors = $e->validate_facet_data();
|
||||
|
||||
=item @errors = $e->validate_facet_data(%params);
|
||||
|
||||
=item @errors = $e->validate_facet_data(\%facets, %params);
|
||||
|
||||
=item @errors = Test2::Event->validate_facet_data(%params);
|
||||
|
||||
=item @errors = Test2::Event->validate_facet_data(\%facets, %params);
|
||||
|
||||
This method will validate facet data and return a list of errors. If no errors
|
||||
are found this will return an empty list.
|
||||
|
||||
This can be called as an object method with no arguments, in which case the
|
||||
C<facet_data()> method will be called to get the facet data to be validated.
|
||||
|
||||
When used as an object method the C<\%facet_data> argument may be omitted.
|
||||
|
||||
When used as a class method the C<\%facet_data> argument is required.
|
||||
|
||||
Remaining arguments will be slurped into a C<%params> hash.
|
||||
|
||||
Currently only 1 parameter is defined:
|
||||
|
||||
=over 4
|
||||
|
||||
=item require_facet_class => $BOOL
|
||||
|
||||
When set to true (default is false) this will reject any facets where a facet
|
||||
class cannot be found. Normally facets without classes are assumed to be custom
|
||||
and are ignored.
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=head3 WHAT ARE FACETS?
|
||||
|
||||
Facets are how events convey their purpose to the Test2 internals and
|
||||
formatters. An event without facets will have no intentional effect on the
|
||||
overall test state, and will not be displayed at all by most formatters, except
|
||||
perhaps to say that an event of an unknown type was seen.
|
||||
|
||||
Facets are produced by the C<facet_data()> subroutine, which you should
|
||||
nearly-always override. C<facet_data()> is expected to return a hashref where
|
||||
each key is the facet type, and the value is either a hashref with the data for
|
||||
that facet, or an array of hashrefs. Some facets must be defined as single
|
||||
hashrefs, some must be defined as an array of hashrefs, No facets allow both.
|
||||
|
||||
C<facet_data()> B<MUST NOT> bless the data it returns, the main hashref, and
|
||||
nested facet hashrefs B<MUST> be bare, though items contained within each
|
||||
facet may be blessed. The data returned by this method B<should> also be copies
|
||||
of the internal data in order to prevent accidental state modification.
|
||||
|
||||
C<facets()> takes the data from C<facet_data()> and blesses it into the
|
||||
C<Test2::EventFacet::*> packages. This is rarely used however, the EventFacet
|
||||
packages are primarily for convenience and documentation. The EventFacet
|
||||
classes are not used at all internally, instead the raw data is used.
|
||||
|
||||
Here is a list of facet types by package. The packages are not used internally,
|
||||
but are where the documentation for each type is kept.
|
||||
|
||||
B<Note:> Every single facet type has the C<'details'> field. This field is
|
||||
always intended for human consumption, and when provided, should explain the
|
||||
'why' for the facet. All other fields are facet specific.
|
||||
|
||||
=over 4
|
||||
|
||||
=item about => {...}
|
||||
|
||||
L<Test2::EventFacet::About>
|
||||
|
||||
This contains information about the event itself such as the event package
|
||||
name. The C<details> field for this facet is an overall summary of the event.
|
||||
|
||||
=item assert => {...}
|
||||
|
||||
L<Test2::EventFacet::Assert>
|
||||
|
||||
This facet is used if an assertion was made. The C<details> field of this facet
|
||||
is the description of the assertion.
|
||||
|
||||
=item control => {...}
|
||||
|
||||
L<Test2::EventFacet::Control>
|
||||
|
||||
This facet is used to tell the L<Test2::Event::Hub> about special actions the
|
||||
event causes. Things like halting all testing, terminating the current test,
|
||||
etc. In this facet the C<details> field explains why any special action was
|
||||
taken.
|
||||
|
||||
B<Note:> This is how bail-out is implemented.
|
||||
|
||||
=item meta => {...}
|
||||
|
||||
L<Test2::EventFacet::Meta>
|
||||
|
||||
The meta facet contains all the meta-data attached to the event. In this case
|
||||
the C<details> field has no special meaning, but may be present if something
|
||||
sets the 'details' meta-key on the event.
|
||||
|
||||
=item parent => {...}
|
||||
|
||||
L<Test2::EventFacet::Parent>
|
||||
|
||||
This facet contains nested events and similar details for subtests. In this
|
||||
facet the C<details> field will typically be the name of the subtest.
|
||||
|
||||
=item plan => {...}
|
||||
|
||||
L<Test2::EventFacet::Plan>
|
||||
|
||||
This facet tells the system that a plan has been set. The C<details> field of
|
||||
this is usually left empty, but when present explains why the plan is what it
|
||||
is, this is most useful if the plan is to skip-all.
|
||||
|
||||
=item trace => {...}
|
||||
|
||||
L<Test2::EventFacet::Trace>
|
||||
|
||||
This facet contains information related to when and where the event was
|
||||
generated. This is how the test file and line number of a failure is known.
|
||||
This facet can also help you to tell if tests are related.
|
||||
|
||||
In this facet the C<details> field overrides the "failed at test_file.t line
|
||||
42." message provided on assertion failure.
|
||||
|
||||
=item amnesty => [{...}, ...]
|
||||
|
||||
L<Test2::EventFacet::Amnesty>
|
||||
|
||||
The amnesty facet is a list instead of a single item, this is important as
|
||||
amnesty can come from multiple places at once.
|
||||
|
||||
For each instance of amnesty the C<details> field explains why amnesty was
|
||||
granted.
|
||||
|
||||
B<Note:> Outside of formatters amnesty only acts to forgive a failing
|
||||
assertion.
|
||||
|
||||
=item errors => [{...}, ...]
|
||||
|
||||
L<Test2::EventFacet::Error>
|
||||
|
||||
The errors facet is a list instead of a single item, any number of errors can
|
||||
be listed. In this facet C<details> describes the error, or may contain the raw
|
||||
error message itself (such as an exception). In perl exception may be blessed
|
||||
objects, as such the raw data for this facet may contain nested items which are
|
||||
blessed.
|
||||
|
||||
Not all errors are considered fatal, there is a C<fail> field that must be set
|
||||
for an error to cause the test to fail.
|
||||
|
||||
B<Note:> This facet is unique in that the field name is 'errors' while the
|
||||
package is 'Error'. This is because this is the only facet type that is both a
|
||||
list, and has a name where the plural is not the same as the singular. This may
|
||||
cause some confusion, but I feel it will be less confusing than the
|
||||
alternative.
|
||||
|
||||
=item info => [{...}, ...]
|
||||
|
||||
L<Test2::EventFacet::Info>
|
||||
|
||||
The 'info' facet is a list instead of a single item, any quantity of extra
|
||||
information can be attached to an event. Some information may be critical
|
||||
diagnostics, others may be simply commentary in nature, this is determined by
|
||||
the C<debug> flag.
|
||||
|
||||
For this facet the C<details> flag is the info itself. This info may be a
|
||||
string, or it may be a data structure to display. This is one of the few facet
|
||||
types that may contain blessed items.
|
||||
|
||||
=back
|
||||
|
||||
=head2 LEGACY API
|
||||
|
||||
=over 4
|
||||
|
||||
=item $bool = $e->causes_fail
|
||||
|
||||
Returns true if this event should result in a test failure. In general this
|
||||
should be false.
|
||||
|
||||
=item $bool = $e->increments_count
|
||||
|
||||
Should be true if this event should result in a test count increment.
|
||||
|
||||
=item $e->callback($hub)
|
||||
|
||||
If your event needs to have extra effects on the L<Test2::Hub> you can override
|
||||
this method.
|
||||
|
||||
This is called B<BEFORE> your event is passed to the formatter.
|
||||
|
||||
=item $num = $e->nested
|
||||
|
||||
If this event is nested inside of other events, this should be the depth of
|
||||
nesting. (This is mainly for subtests)
|
||||
|
||||
=item $bool = $e->global
|
||||
|
||||
Set this to true if your event is global, that is ALL threads and processes
|
||||
should see it no matter when or where it is generated. This is not a common
|
||||
thing to want, it is used by bail-out and skip_all to end testing.
|
||||
|
||||
=item $code = $e->terminate
|
||||
|
||||
This is called B<AFTER> your event has been passed to the formatter. This
|
||||
should normally return undef, only change this if your event should cause the
|
||||
test to exit immediately.
|
||||
|
||||
If you want this event to cause the test to exit you should return the exit
|
||||
code here. Exit code of 0 means exit success, any other integer means exit with
|
||||
failure.
|
||||
|
||||
This is used by L<Test2::Event::Plan> to exit 0 when the plan is
|
||||
'skip_all'. This is also used by L<Test2::Event:Bail> to force the test
|
||||
to exit with a failure.
|
||||
|
||||
This is called after the event has been sent to the formatter in order to
|
||||
ensure the event is seen and understood.
|
||||
|
||||
=item $msg = $e->summary
|
||||
|
||||
This is intended to be a human readable summary of the event. This should
|
||||
ideally only be one line long, but you can use multiple lines if necessary. This
|
||||
is intended for human consumption. You do not need to make it easy for machines
|
||||
to understand.
|
||||
|
||||
The default is to simply return the event package name.
|
||||
|
||||
=item ($count, $directive, $reason) = $e->sets_plan()
|
||||
|
||||
Check if this event sets the testing plan. It will return an empty list if it
|
||||
does not. If it does set the plan it will return a list of 1 to 3 items in
|
||||
order: Expected Test Count, Test Directive, Reason for directive.
|
||||
|
||||
=item $bool = $e->diagnostics
|
||||
|
||||
True if the event contains diagnostics info. This is useful because a
|
||||
non-verbose harness may choose to hide events that are not in this category.
|
||||
Some formatters may choose to send these to STDERR instead of STDOUT to ensure
|
||||
they are seen.
|
||||
|
||||
=item $bool = $e->no_display
|
||||
|
||||
False by default. This will return true on events that should not be displayed
|
||||
by formatters.
|
||||
|
||||
=item $id = $e->in_subtest
|
||||
|
||||
If the event is inside a subtest this should have the subtest ID.
|
||||
|
||||
=item $id = $e->subtest_id
|
||||
|
||||
If the event is a final subtest event, this should contain the subtest ID.
|
||||
|
||||
=back
|
||||
|
||||
=head1 THIRD PARTY META-DATA
|
||||
|
||||
This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
|
||||
way for you to attach meta-data to instances of this class. This is useful for
|
||||
tools, plugins, and other extensions.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
109
t/lib/Test2/Event/Bail.pm
Normal file
109
t/lib/Test2/Event/Bail.pm
Normal file
|
|
@ -0,0 +1,109 @@
|
|||
package Test2::Event::Bail;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
|
||||
use Test2::Util::HashBase qw{reason buffered};
|
||||
|
||||
# Make sure the tests terminate
|
||||
sub terminate { 255 };
|
||||
|
||||
sub global { 1 };
|
||||
|
||||
sub causes_fail { 1 }
|
||||
|
||||
sub summary {
|
||||
my $self = shift;
|
||||
return "Bail out! " . $self->{+REASON}
|
||||
if $self->{+REASON};
|
||||
|
||||
return "Bail out!";
|
||||
}
|
||||
|
||||
sub diagnostics { 1 }
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
my $out = $self->common_facet_data;
|
||||
|
||||
$out->{control} = {
|
||||
global => 1,
|
||||
halt => 1,
|
||||
details => $self->{+REASON},
|
||||
terminate => 255,
|
||||
};
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Bail - Bailout!
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The bailout event is generated when things go horribly wrong and you need to
|
||||
halt all testing in the current file.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::API qw/context/;
|
||||
use Test2::Event::Bail;
|
||||
|
||||
my $ctx = context();
|
||||
my $event = $ctx->bail('Stuff is broken');
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
Inherits from L<Test2::Event>. Also defines:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $reason = $e->reason
|
||||
|
||||
The reason for the bailout.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
99
t/lib/Test2/Event/Diag.pm
Normal file
99
t/lib/Test2/Event/Diag.pm
Normal file
|
|
@ -0,0 +1,99 @@
|
|||
package Test2::Event::Diag;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
|
||||
use Test2::Util::HashBase qw/message/;
|
||||
|
||||
sub init {
|
||||
$_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE};
|
||||
}
|
||||
|
||||
sub summary { $_[0]->{+MESSAGE} }
|
||||
|
||||
sub diagnostics { 1 }
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
|
||||
my $out = $self->common_facet_data;
|
||||
|
||||
$out->{info} = [
|
||||
{
|
||||
tag => 'DIAG',
|
||||
debug => 1,
|
||||
details => $self->{+MESSAGE},
|
||||
}
|
||||
];
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Diag - Diag event type
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Diagnostics messages, typically rendered to STDERR.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::API qw/context/;
|
||||
use Test2::Event::Diag;
|
||||
|
||||
my $ctx = context();
|
||||
my $event = $ctx->diag($message);
|
||||
|
||||
=head1 ACCESSORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $diag->message
|
||||
|
||||
The message for the diag.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
97
t/lib/Test2/Event/Encoding.pm
Normal file
97
t/lib/Test2/Event/Encoding.pm
Normal file
|
|
@ -0,0 +1,97 @@
|
|||
package Test2::Event::Encoding;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
use Carp qw/croak/;
|
||||
|
||||
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
|
||||
use Test2::Util::HashBase qw/encoding/;
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
defined $self->{+ENCODING} or croak "'encoding' is a required attribute";
|
||||
}
|
||||
|
||||
sub summary { 'Encoding set to ' . $_[0]->{+ENCODING} }
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
my $out = $self->common_facet_data;
|
||||
$out->{control}->{encoding} = $self->{+ENCODING};
|
||||
$out->{about}->{details} = $self->summary;
|
||||
return $out;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Encoding - Set the encoding for the output stream
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The encoding event is generated when a test file wants to specify the encoding
|
||||
to be used when formatting its output. This event is intended to be produced
|
||||
by formatter classes and used for interpreting test names, message contents,
|
||||
etc.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::API qw/context/;
|
||||
use Test2::Event::Encoding;
|
||||
|
||||
my $ctx = context();
|
||||
my $event = $ctx->send_event('Encoding', encoding => 'UTF-8');
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
Inherits from L<Test2::Event>. Also defines:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $encoding = $e->encoding
|
||||
|
||||
The encoding being specified.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
113
t/lib/Test2/Event/Exception.pm
Normal file
113
t/lib/Test2/Event/Exception.pm
Normal file
|
|
@ -0,0 +1,113 @@
|
|||
package Test2::Event::Exception;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
|
||||
use Test2::Util::HashBase qw{error};
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->{+ERROR} = "$self->{+ERROR}";
|
||||
}
|
||||
|
||||
sub causes_fail { 1 }
|
||||
|
||||
sub summary {
|
||||
my $self = shift;
|
||||
chomp(my $msg = "Exception: " . $self->{+ERROR});
|
||||
return $msg;
|
||||
}
|
||||
|
||||
sub diagnostics { 1 }
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
my $out = $self->common_facet_data;
|
||||
|
||||
$out->{errors} = [
|
||||
{
|
||||
tag => 'ERROR',
|
||||
fail => 1,
|
||||
details => $self->{+ERROR},
|
||||
}
|
||||
];
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Exception - Exception event
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
An exception event will display to STDERR, and will prevent the overall test
|
||||
file from passing.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::API qw/context/;
|
||||
use Test2::Event::Exception;
|
||||
|
||||
my $ctx = context();
|
||||
my $event = $ctx->send_event('Exception', error => 'Stuff is broken');
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
Inherits from L<Test2::Event>. Also defines:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $reason = $e->error
|
||||
|
||||
The reason for the exception.
|
||||
|
||||
=back
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Be aware that all exceptions are stringified during construction.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
118
t/lib/Test2/Event/Fail.pm
Normal file
118
t/lib/Test2/Event/Fail.pm
Normal file
|
|
@ -0,0 +1,118 @@
|
|||
package Test2::Event::Fail;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
use Test2::EventFacet::Info;
|
||||
|
||||
BEGIN {
|
||||
require Test2::Event;
|
||||
our @ISA = qw(Test2::Event);
|
||||
*META_KEY = \&Test2::Util::ExternalMeta::META_KEY;
|
||||
}
|
||||
|
||||
use Test2::Util::HashBase qw{ -name -info };
|
||||
|
||||
#############
|
||||
# Old API
|
||||
sub summary { "fail" }
|
||||
sub increments_count { 1 }
|
||||
sub diagnostics { 0 }
|
||||
sub no_display { 0 }
|
||||
sub subtest_id { undef }
|
||||
sub terminate { () }
|
||||
sub global { () }
|
||||
sub sets_plan { () }
|
||||
|
||||
sub causes_fail {
|
||||
my $self = shift;
|
||||
return 0 if $self->{+AMNESTY} && @{$self->{+AMNESTY}};
|
||||
return 1;
|
||||
}
|
||||
|
||||
#############
|
||||
# New API
|
||||
|
||||
sub add_info {
|
||||
my $self = shift;
|
||||
|
||||
for my $in (@_) {
|
||||
$in = {%$in} if ref($in) ne 'ARRAY';
|
||||
$in = Test2::EventFacet::Info->new($in);
|
||||
|
||||
push @{$self->{+INFO}} => $in;
|
||||
}
|
||||
}
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
my $out = $self->common_facet_data;
|
||||
|
||||
$out->{about}->{details} = 'fail';
|
||||
|
||||
$out->{assert} = {pass => 0, details => $self->{+NAME}};
|
||||
|
||||
$out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO};
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Fail - Event for a simple failed assertion
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is an optimal representation of a failed assertion.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::API qw/context/;
|
||||
|
||||
sub fail {
|
||||
my ($name) = @_;
|
||||
my $ctx = context();
|
||||
$ctx->fail($name);
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
280
t/lib/Test2/Event/Generic.pm
Normal file
280
t/lib/Test2/Event/Generic.pm
Normal file
|
|
@ -0,0 +1,280 @@
|
|||
package Test2::Event::Generic;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp qw/croak/;
|
||||
use Scalar::Util qw/reftype/;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
|
||||
use Test2::Util::HashBase;
|
||||
|
||||
my @FIELDS = qw{
|
||||
causes_fail increments_count diagnostics no_display callback terminate
|
||||
global sets_plan summary facet_data
|
||||
};
|
||||
my %DEFAULTS = (
|
||||
causes_fail => 0,
|
||||
increments_count => 0,
|
||||
diagnostics => 0,
|
||||
no_display => 0,
|
||||
);
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
for my $field (@FIELDS) {
|
||||
my $val = defined $self->{$field} ? delete $self->{$field} : $DEFAULTS{$field};
|
||||
next unless defined $val;
|
||||
|
||||
my $set = "set_$field";
|
||||
$self->$set($val);
|
||||
}
|
||||
}
|
||||
|
||||
for my $field (@FIELDS) {
|
||||
no strict 'refs';
|
||||
|
||||
*$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () }
|
||||
unless exists &{$field};
|
||||
|
||||
*{"set_$field"} = sub { $_[0]->{$field} = $_[1] }
|
||||
unless exists &{"set_$field"};
|
||||
}
|
||||
|
||||
sub can {
|
||||
my $self = shift;
|
||||
my ($name) = @_;
|
||||
return $self->SUPER::can($name) unless $name eq 'callback';
|
||||
return $self->{callback} || \&Test2::Event::callback;
|
||||
}
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
return $self->{facet_data} || $self->SUPER::facet_data();
|
||||
}
|
||||
|
||||
sub summary {
|
||||
my $self = shift;
|
||||
return $self->{summary} if defined $self->{summary};
|
||||
$self->SUPER::summary();
|
||||
}
|
||||
|
||||
sub sets_plan {
|
||||
my $self = shift;
|
||||
return unless $self->{sets_plan};
|
||||
return @{$self->{sets_plan}};
|
||||
}
|
||||
|
||||
sub callback {
|
||||
my $self = shift;
|
||||
my $cb = $self->{callback} || return;
|
||||
$self->$cb(@_);
|
||||
}
|
||||
|
||||
sub set_global {
|
||||
my $self = shift;
|
||||
my ($bool) = @_;
|
||||
|
||||
if(!defined $bool) {
|
||||
delete $self->{global};
|
||||
return undef;
|
||||
}
|
||||
|
||||
$self->{global} = $bool;
|
||||
}
|
||||
|
||||
sub set_callback {
|
||||
my $self = shift;
|
||||
my ($cb) = @_;
|
||||
|
||||
if(!defined $cb) {
|
||||
delete $self->{callback};
|
||||
return undef;
|
||||
}
|
||||
|
||||
croak "callback must be a code reference"
|
||||
unless ref($cb) && reftype($cb) eq 'CODE';
|
||||
|
||||
$self->{callback} = $cb;
|
||||
}
|
||||
|
||||
sub set_terminate {
|
||||
my $self = shift;
|
||||
my ($exit) = @_;
|
||||
|
||||
if(!defined $exit) {
|
||||
delete $self->{terminate};
|
||||
return undef;
|
||||
}
|
||||
|
||||
croak "terminate must be a positive integer"
|
||||
unless $exit =~ m/^\d+$/;
|
||||
|
||||
$self->{terminate} = $exit;
|
||||
}
|
||||
|
||||
sub set_sets_plan {
|
||||
my $self = shift;
|
||||
my ($plan) = @_;
|
||||
|
||||
if(!defined $plan) {
|
||||
delete $self->{sets_plan};
|
||||
return undef;
|
||||
}
|
||||
|
||||
croak "'sets_plan' must be an array reference"
|
||||
unless ref($plan) && reftype($plan) eq 'ARRAY';
|
||||
|
||||
$self->{sets_plan} = $plan;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Generic - Generic event type.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a generic event that lets you customize all fields in the event API.
|
||||
This is useful if you have need for a custom event that does not make sense as
|
||||
a published reusable event subclass.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::API qw/context/;
|
||||
|
||||
sub send_custom_fail {
|
||||
my $ctx = shift;
|
||||
|
||||
$ctx->send_event('Generic', causes_fail => 1, summary => 'The sky is falling');
|
||||
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
send_custom_fail();
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $e->facet_data($data)
|
||||
|
||||
=item $data = $e->facet_data
|
||||
|
||||
Get or set the facet data (see L<Test2::Event>). If no facet_data is set then
|
||||
C<< Test2::Event->facet_data >> will be called to produce facets from the other
|
||||
data.
|
||||
|
||||
=item $e->callback($hub)
|
||||
|
||||
Call the custom callback if one is set, otherwise this does nothing.
|
||||
|
||||
=item $e->set_callback(sub { ... })
|
||||
|
||||
Set the custom callback. The custom callback must be a coderef. The first
|
||||
argument to your callback will be the event itself, the second will be the
|
||||
L<Test2::Event::Hub> that is using the callback.
|
||||
|
||||
=item $bool = $e->causes_fail
|
||||
|
||||
=item $e->set_causes_fail($bool)
|
||||
|
||||
Get/Set the C<causes_fail> attribute. This defaults to C<0>.
|
||||
|
||||
=item $bool = $e->diagnostics
|
||||
|
||||
=item $e->set_diagnostics($bool)
|
||||
|
||||
Get/Set the C<diagnostics> attribute. This defaults to C<0>.
|
||||
|
||||
=item $bool_or_undef = $e->global
|
||||
|
||||
=item @bool_or_empty = $e->global
|
||||
|
||||
=item $e->set_global($bool_or_undef)
|
||||
|
||||
Get/Set the C<diagnostics> attribute. This defaults to an empty list which is
|
||||
undef in scalar context.
|
||||
|
||||
=item $bool = $e->increments_count
|
||||
|
||||
=item $e->set_increments_count($bool)
|
||||
|
||||
Get/Set the C<increments_count> attribute. This defaults to C<0>.
|
||||
|
||||
=item $bool = $e->no_display
|
||||
|
||||
=item $e->set_no_display($bool)
|
||||
|
||||
Get/Set the C<no_display> attribute. This defaults to C<0>.
|
||||
|
||||
=item @plan = $e->sets_plan
|
||||
|
||||
Get the plan if this event sets one. The plan is a list of up to 3 items:
|
||||
C<($count, $directive, $reason)>. C<$count> must be defined, the others may be
|
||||
undef, or may not exist at all.
|
||||
|
||||
=item $e->set_sets_plan(\@plan)
|
||||
|
||||
Set the plan. You must pass in an arrayref with up to 3 elements.
|
||||
|
||||
=item $summary = $e->summary
|
||||
|
||||
=item $e->set_summary($summary_or_undef)
|
||||
|
||||
Get/Set the summary. This will default to the event package
|
||||
C<'Test2::Event::Generic'>. You can set it to any value. Setting this to
|
||||
C<undef> will reset it to the default.
|
||||
|
||||
=item $int_or_undef = $e->terminate
|
||||
|
||||
=item @int_or_empty = $e->terminate
|
||||
|
||||
=item $e->set_terminate($int_or_undef)
|
||||
|
||||
This will get/set the C<terminate> attribute. This defaults to undef in scalar
|
||||
context, or an empty list in list context. Setting this to undef will clear it
|
||||
completely. This must be set to a positive integer (0 or larger).
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
97
t/lib/Test2/Event/Note.pm
Normal file
97
t/lib/Test2/Event/Note.pm
Normal file
|
|
@ -0,0 +1,97 @@
|
|||
package Test2::Event::Note;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
|
||||
use Test2::Util::HashBase qw/message/;
|
||||
|
||||
sub init {
|
||||
$_[0]->{+MESSAGE} = 'undef' unless defined $_[0]->{+MESSAGE};
|
||||
}
|
||||
|
||||
sub summary { $_[0]->{+MESSAGE} }
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
|
||||
my $out = $self->common_facet_data;
|
||||
|
||||
$out->{info} = [
|
||||
{
|
||||
tag => 'NOTE',
|
||||
debug => 0,
|
||||
details => $self->{+MESSAGE},
|
||||
}
|
||||
];
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Note - Note event type
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Notes, typically rendered to STDOUT.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::API qw/context/;
|
||||
use Test2::Event::Note;
|
||||
|
||||
my $ctx = context();
|
||||
my $event = $ctx->Note($message);
|
||||
|
||||
=head1 ACCESSORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $note->message
|
||||
|
||||
The message for the note.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
162
t/lib/Test2/Event/Ok.pm
Normal file
162
t/lib/Test2/Event/Ok.pm
Normal file
|
|
@ -0,0 +1,162 @@
|
|||
package Test2::Event::Ok;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
|
||||
use Test2::Util::HashBase qw{
|
||||
pass effective_pass name todo
|
||||
};
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
# Do not store objects here, only true or false
|
||||
$self->{+PASS} = $self->{+PASS} ? 1 : 0;
|
||||
$self->{+EFFECTIVE_PASS} = $self->{+PASS} || (defined($self->{+TODO}) ? 1 : 0);
|
||||
}
|
||||
|
||||
{
|
||||
no warnings 'redefine';
|
||||
sub set_todo {
|
||||
my $self = shift;
|
||||
my ($todo) = @_;
|
||||
$self->{+TODO} = $todo;
|
||||
$self->{+EFFECTIVE_PASS} = defined($todo) ? 1 : $self->{+PASS};
|
||||
}
|
||||
}
|
||||
|
||||
sub increments_count { 1 };
|
||||
|
||||
sub causes_fail { !$_[0]->{+EFFECTIVE_PASS} }
|
||||
|
||||
sub summary {
|
||||
my $self = shift;
|
||||
|
||||
my $name = $self->{+NAME} || "Nameless Assertion";
|
||||
|
||||
my $todo = $self->{+TODO};
|
||||
if ($todo) {
|
||||
$name .= " (TODO: $todo)";
|
||||
}
|
||||
elsif (defined $todo) {
|
||||
$name .= " (TODO)"
|
||||
}
|
||||
|
||||
return $name;
|
||||
}
|
||||
|
||||
sub extra_amnesty {
|
||||
my $self = shift;
|
||||
return unless defined($self->{+TODO}) || ($self->{+EFFECTIVE_PASS} && !$self->{+PASS});
|
||||
return {
|
||||
tag => 'TODO',
|
||||
details => $self->{+TODO},
|
||||
};
|
||||
}
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
|
||||
my $out = $self->common_facet_data;
|
||||
|
||||
$out->{assert} = {
|
||||
no_debug => 1, # Legacy behavior
|
||||
pass => $self->{+PASS},
|
||||
details => $self->{+NAME},
|
||||
};
|
||||
|
||||
if (my @exra_amnesty = $self->extra_amnesty) {
|
||||
unshift @{$out->{amnesty}} => @exra_amnesty;
|
||||
}
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Ok - Ok event type
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Ok events are generated whenever you run a test that produces a result.
|
||||
Examples are C<ok()>, and C<is()>.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::API qw/context/;
|
||||
use Test2::Event::Ok;
|
||||
|
||||
my $ctx = context();
|
||||
my $event = $ctx->ok($bool, $name, \@diag);
|
||||
|
||||
or:
|
||||
|
||||
my $ctx = context();
|
||||
my $event = $ctx->send_event(
|
||||
'Ok',
|
||||
pass => $bool,
|
||||
name => $name,
|
||||
);
|
||||
|
||||
=head1 ACCESSORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $rb = $e->pass
|
||||
|
||||
The original true/false value of whatever was passed into the event (but
|
||||
reduced down to 1 or 0).
|
||||
|
||||
=item $name = $e->name
|
||||
|
||||
Name of the test.
|
||||
|
||||
=item $b = $e->effective_pass
|
||||
|
||||
This is the true/false value of the test after TODO and similar modifiers are
|
||||
taken into account.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
114
t/lib/Test2/Event/Pass.pm
Normal file
114
t/lib/Test2/Event/Pass.pm
Normal file
|
|
@ -0,0 +1,114 @@
|
|||
package Test2::Event::Pass;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
use Test2::EventFacet::Info;
|
||||
|
||||
BEGIN {
|
||||
require Test2::Event;
|
||||
our @ISA = qw(Test2::Event);
|
||||
*META_KEY = \&Test2::Util::ExternalMeta::META_KEY;
|
||||
}
|
||||
|
||||
use Test2::Util::HashBase qw{ -name -info };
|
||||
|
||||
##############
|
||||
# Old API
|
||||
sub summary { "pass" }
|
||||
sub increments_count { 1 }
|
||||
sub causes_fail { 0 }
|
||||
sub diagnostics { 0 }
|
||||
sub no_display { 0 }
|
||||
sub subtest_id { undef }
|
||||
sub terminate { () }
|
||||
sub global { () }
|
||||
sub sets_plan { () }
|
||||
|
||||
##############
|
||||
# New API
|
||||
|
||||
sub add_info {
|
||||
my $self = shift;
|
||||
|
||||
for my $in (@_) {
|
||||
$in = {%$in} if ref($in) ne 'ARRAY';
|
||||
$in = Test2::EventFacet::Info->new($in);
|
||||
|
||||
push @{$self->{+INFO}} => $in;
|
||||
}
|
||||
}
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
|
||||
my $out = $self->common_facet_data;
|
||||
|
||||
$out->{about}->{details} = 'pass';
|
||||
|
||||
$out->{assert} = {pass => 1, details => $self->{+NAME}};
|
||||
|
||||
$out->{info} = [map {{ %{$_} }} @{$self->{+INFO}}] if $self->{+INFO};
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Pass - Event for a simple passing assertion
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is an optimal representation of a passing assertion.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::API qw/context/;
|
||||
|
||||
sub pass {
|
||||
my ($name) = @_;
|
||||
my $ctx = context();
|
||||
$ctx->pass($name);
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
169
t/lib/Test2/Event/Plan.pm
Normal file
169
t/lib/Test2/Event/Plan.pm
Normal file
|
|
@ -0,0 +1,169 @@
|
|||
package Test2::Event::Plan;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
|
||||
use Test2::Util::HashBase qw{max directive reason};
|
||||
|
||||
use Carp qw/confess/;
|
||||
|
||||
my %ALLOWED = (
|
||||
'SKIP' => 1,
|
||||
'NO PLAN' => 1,
|
||||
);
|
||||
|
||||
sub init {
|
||||
if ($_[0]->{+DIRECTIVE}) {
|
||||
$_[0]->{+DIRECTIVE} = 'SKIP' if $_[0]->{+DIRECTIVE} eq 'skip_all';
|
||||
$_[0]->{+DIRECTIVE} = 'NO PLAN' if $_[0]->{+DIRECTIVE} eq 'no_plan';
|
||||
|
||||
confess "'" . $_[0]->{+DIRECTIVE} . "' is not a valid plan directive"
|
||||
unless $ALLOWED{$_[0]->{+DIRECTIVE}};
|
||||
}
|
||||
else {
|
||||
confess "Cannot have a reason without a directive!"
|
||||
if defined $_[0]->{+REASON};
|
||||
|
||||
confess "No number of tests specified"
|
||||
unless defined $_[0]->{+MAX};
|
||||
|
||||
confess "Plan test count '" . $_[0]->{+MAX} . "' does not appear to be a valid positive integer"
|
||||
unless $_[0]->{+MAX} =~ m/^\d+$/;
|
||||
|
||||
$_[0]->{+DIRECTIVE} = '';
|
||||
}
|
||||
}
|
||||
|
||||
sub sets_plan {
|
||||
my $self = shift;
|
||||
return (
|
||||
$self->{+MAX},
|
||||
$self->{+DIRECTIVE},
|
||||
$self->{+REASON},
|
||||
);
|
||||
}
|
||||
|
||||
sub terminate {
|
||||
my $self = shift;
|
||||
# On skip_all we want to terminate the hub
|
||||
return 0 if $self->{+DIRECTIVE} && $self->{+DIRECTIVE} eq 'SKIP';
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub summary {
|
||||
my $self = shift;
|
||||
my $max = $self->{+MAX};
|
||||
my $directive = $self->{+DIRECTIVE};
|
||||
my $reason = $self->{+REASON};
|
||||
|
||||
return "Plan is $max assertions"
|
||||
if $max || !$directive;
|
||||
|
||||
return "Plan is '$directive', $reason"
|
||||
if $reason;
|
||||
|
||||
return "Plan is '$directive'";
|
||||
}
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
|
||||
my $out = $self->common_facet_data;
|
||||
|
||||
$out->{control}->{terminate} = $self->{+DIRECTIVE} eq 'SKIP' ? 0 : undef
|
||||
unless defined $out->{control}->{terminate};
|
||||
|
||||
$out->{plan} = {count => $self->{+MAX}};
|
||||
$out->{plan}->{details} = $self->{+REASON} if defined $self->{+REASON};
|
||||
|
||||
if (my $dir = $self->{+DIRECTIVE}) {
|
||||
$out->{plan}->{skip} = 1 if $dir eq 'SKIP';
|
||||
$out->{plan}->{none} = 1 if $dir eq 'NO PLAN';
|
||||
}
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Plan - The event of a plan
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Plan events are fired off whenever a plan is declared, done testing is called,
|
||||
or a subtext completes.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::API qw/context/;
|
||||
use Test2::Event::Plan;
|
||||
|
||||
my $ctx = context();
|
||||
|
||||
# Plan for 10 tests to run
|
||||
my $event = $ctx->plan(10);
|
||||
|
||||
# Plan to skip all tests (will exit 0)
|
||||
$ctx->plan(0, skip_all => "These tests need to be skipped");
|
||||
|
||||
=head1 ACCESSORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $num = $plan->max
|
||||
|
||||
Get the number of expected tests
|
||||
|
||||
=item $dir = $plan->directive
|
||||
|
||||
Get the directive (such as TODO, skip_all, or no_plan).
|
||||
|
||||
=item $reason = $plan->reason
|
||||
|
||||
Get the reason for the directive.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
127
t/lib/Test2/Event/Skip.pm
Normal file
127
t/lib/Test2/Event/Skip.pm
Normal file
|
|
@ -0,0 +1,127 @@
|
|||
package Test2::Event::Skip;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
|
||||
use Test2::Util::HashBase qw{reason};
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->SUPER::init;
|
||||
$self->{+EFFECTIVE_PASS} = 1;
|
||||
}
|
||||
|
||||
sub causes_fail { 0 }
|
||||
|
||||
sub summary {
|
||||
my $self = shift;
|
||||
my $out = $self->SUPER::summary(@_);
|
||||
|
||||
if (my $reason = $self->reason) {
|
||||
$out .= " (SKIP: $reason)";
|
||||
}
|
||||
else {
|
||||
$out .= " (SKIP)";
|
||||
}
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub extra_amnesty {
|
||||
my $self = shift;
|
||||
|
||||
my @out;
|
||||
|
||||
push @out => {
|
||||
tag => 'TODO',
|
||||
details => $self->{+TODO},
|
||||
} if defined $self->{+TODO};
|
||||
|
||||
push @out => {
|
||||
tag => 'skip',
|
||||
details => $self->{+REASON},
|
||||
inherited => 0,
|
||||
};
|
||||
|
||||
return @out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Skip - Skip event type
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Skip events bump test counts just like L<Test2::Event::Ok> events, but
|
||||
they can never fail.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::API qw/context/;
|
||||
use Test2::Event::Skip;
|
||||
|
||||
my $ctx = context();
|
||||
my $event = $ctx->skip($name, $reason);
|
||||
|
||||
or:
|
||||
|
||||
my $ctx = context();
|
||||
my $event = $ctx->send_event(
|
||||
'Skip',
|
||||
name => $name,
|
||||
reason => $reason,
|
||||
);
|
||||
|
||||
=head1 ACCESSORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $reason = $e->reason
|
||||
|
||||
The original true/false value of whatever was passed into the event (but
|
||||
reduced down to 1 or 0).
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://www.perl.com/perl/misc/Artistic.html>
|
||||
|
||||
=cut
|
||||
160
t/lib/Test2/Event/Subtest.pm
Normal file
160
t/lib/Test2/Event/Subtest.pm
Normal file
|
|
@ -0,0 +1,160 @@
|
|||
package Test2::Event::Subtest;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
|
||||
use Test2::Util::HashBase qw{subevents buffered subtest_id subtest_uuid};
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->SUPER::init();
|
||||
$self->{+SUBEVENTS} ||= [];
|
||||
if ($self->{+EFFECTIVE_PASS}) {
|
||||
$_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}};
|
||||
}
|
||||
}
|
||||
|
||||
{
|
||||
no warnings 'redefine';
|
||||
|
||||
sub set_subevents {
|
||||
my $self = shift;
|
||||
my @subevents = @_;
|
||||
|
||||
if ($self->{+EFFECTIVE_PASS}) {
|
||||
$_->set_effective_pass(1) for grep { $_->can('effective_pass') } @subevents;
|
||||
}
|
||||
|
||||
$self->{+SUBEVENTS} = \@subevents;
|
||||
}
|
||||
|
||||
sub set_effective_pass {
|
||||
my $self = shift;
|
||||
my ($pass) = @_;
|
||||
|
||||
if ($pass) {
|
||||
$_->set_effective_pass(1) for grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}};
|
||||
}
|
||||
elsif ($self->{+EFFECTIVE_PASS} && !$pass) {
|
||||
for my $s (grep { $_->can('effective_pass') } @{$self->{+SUBEVENTS}}) {
|
||||
$_->set_effective_pass(0) unless $s->can('todo') && defined $s->todo;
|
||||
}
|
||||
}
|
||||
|
||||
$self->{+EFFECTIVE_PASS} = $pass;
|
||||
}
|
||||
}
|
||||
|
||||
sub summary {
|
||||
my $self = shift;
|
||||
|
||||
my $name = $self->{+NAME} || "Nameless Subtest";
|
||||
|
||||
my $todo = $self->{+TODO};
|
||||
if ($todo) {
|
||||
$name .= " (TODO: $todo)";
|
||||
}
|
||||
elsif (defined $todo) {
|
||||
$name .= " (TODO)";
|
||||
}
|
||||
|
||||
return $name;
|
||||
}
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
|
||||
my $out = $self->SUPER::facet_data();
|
||||
|
||||
$out->{parent} = {
|
||||
hid => $self->subtest_id,
|
||||
children => [map {$_->facet_data} @{$self->{+SUBEVENTS}}],
|
||||
buffered => $self->{+BUFFERED},
|
||||
};
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
sub add_amnesty {
|
||||
my $self = shift;
|
||||
|
||||
for my $am (@_) {
|
||||
$am = {%$am} if ref($am) ne 'ARRAY';
|
||||
$am = Test2::EventFacet::Amnesty->new($am);
|
||||
|
||||
push @{$self->{+AMNESTY}} => $am;
|
||||
|
||||
for my $e (@{$self->{+SUBEVENTS}}) {
|
||||
$e->add_amnesty($am->clone(inherited => 1));
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Subtest - Event for subtest types
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This class represents a subtest. This class is a subclass of
|
||||
L<Test2::Event::Ok>.
|
||||
|
||||
=head1 ACCESSORS
|
||||
|
||||
This class inherits from L<Test2::Event::Ok>.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $arrayref = $e->subevents
|
||||
|
||||
Returns the arrayref containing all the events from the subtest
|
||||
|
||||
=item $bool = $e->buffered
|
||||
|
||||
True if the subtest is buffered, that is all subevents render at once. If this
|
||||
is false it means all subevents render as they are produced.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
101
t/lib/Test2/Event/TAP/Version.pm
Normal file
101
t/lib/Test2/Event/TAP/Version.pm
Normal file
|
|
@ -0,0 +1,101 @@
|
|||
package Test2::Event::TAP::Version;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
use Carp qw/croak/;
|
||||
|
||||
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
|
||||
use Test2::Util::HashBase qw/version/;
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
defined $self->{+VERSION} or croak "'version' is a required attribute";
|
||||
}
|
||||
|
||||
sub summary { 'TAP version ' . $_[0]->{+VERSION} }
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
|
||||
my $out = $self->common_facet_data;
|
||||
|
||||
$out->{about}->{details} = $self->summary;
|
||||
|
||||
push @{$out->{info}} => {
|
||||
tag => 'INFO',
|
||||
debug => 0,
|
||||
details => $self->summary,
|
||||
};
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::TAP::Version - Event for TAP version.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This event is used if a TAP formatter wishes to set a version.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::API qw/context/;
|
||||
use Test2::Event::Encoding;
|
||||
|
||||
my $ctx = context();
|
||||
my $event = $ctx->send_event('TAP::Version', version => 42);
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
Inherits from L<Test2::Event>. Also defines:
|
||||
|
||||
=over 4
|
||||
|
||||
=item $version = $e->version
|
||||
|
||||
The TAP version being parsed.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
238
t/lib/Test2/Event/V2.pm
Normal file
238
t/lib/Test2/Event/V2.pm
Normal file
|
|
@ -0,0 +1,238 @@
|
|||
package Test2::Event::V2;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
use Scalar::Util qw/reftype/;
|
||||
use Carp qw/croak/;
|
||||
|
||||
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
|
||||
|
||||
use Test2::Util::Facets2Legacy qw{
|
||||
causes_fail diagnostics global increments_count no_display sets_plan
|
||||
subtest_id summary terminate
|
||||
};
|
||||
|
||||
use Test2::Util::HashBase qw/-about/;
|
||||
|
||||
sub non_facet_keys {
|
||||
return (
|
||||
+UUID,
|
||||
Test2::Util::ExternalMeta::META_KEY(),
|
||||
);
|
||||
}
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
my $uuid;
|
||||
if ($uuid = $self->{+UUID}) {
|
||||
croak "uuid '$uuid' passed to constructor, but uuid '$self->{+ABOUT}->{uuid}' is already set in the 'about' facet"
|
||||
if $self->{+ABOUT}->{uuid} && $self->{+ABOUT}->{uuid} ne $uuid;
|
||||
|
||||
$self->{+ABOUT}->{uuid} = $uuid;
|
||||
}
|
||||
elsif ($uuid = $self->{+ABOUT}->{uuid}) {
|
||||
$self->SUPER::set_uuid($uuid);
|
||||
}
|
||||
|
||||
# Clone the trace, make sure it is blessed
|
||||
if (my $trace = $self->{+TRACE}) {
|
||||
$self->{+TRACE} = Test2::EventFacet::Trace->new(%$trace);
|
||||
}
|
||||
}
|
||||
|
||||
sub set_uuid {
|
||||
my $self = shift;
|
||||
my ($uuid) = @_;
|
||||
$self->{+ABOUT}->{uuid} = $uuid;
|
||||
$self->SUPER::set_uuid($uuid);
|
||||
}
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
my $f = { %{$self} };
|
||||
|
||||
delete $f->{$_} for $self->non_facet_keys;
|
||||
|
||||
my %out;
|
||||
for my $k (keys %$f) {
|
||||
next if substr($k, 0, 1) eq '_';
|
||||
|
||||
my $data = $f->{$k} or next; # Key is there, but no facet
|
||||
my $is_list = 'ARRAY' eq (reftype($data) || '');
|
||||
$out{$k} = $is_list ? [ map { {%{$_}} } @$data ] : {%$data};
|
||||
}
|
||||
|
||||
if (my $meta = $self->meta_facet_data) {
|
||||
$out{meta} = {%$meta, %{$out{meta} || {}}};
|
||||
}
|
||||
|
||||
return \%out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::V2 - Second generation event.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the event type that should be used instead of L<Test2::Event> or its
|
||||
legacy subclasses.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
=head2 USING A CONTEXT
|
||||
|
||||
use Test2::API qw/context/;
|
||||
|
||||
sub my_tool {
|
||||
my $ctx = context();
|
||||
|
||||
my $event = $ctx->send_ev2(info => [{tag => 'NOTE', details => "This is a note"}]);
|
||||
|
||||
$ctx->release;
|
||||
|
||||
return $event;
|
||||
}
|
||||
|
||||
=head2 USING THE CONSTRUCTOR
|
||||
|
||||
use Test2::Event::V2;
|
||||
|
||||
my $e = Test2::Event::V2->new(
|
||||
trace => {frame => [$PKG, $FILE, $LINE, $SUBNAME]},
|
||||
info => [{tag => 'NOTE', details => "This is a note"}],
|
||||
);
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
This class inherits from L<Test2::Event>.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $fd = $e->facet_data()
|
||||
|
||||
This will return a hashref of facet data. Each facet hash will be a shallow
|
||||
copy of the original.
|
||||
|
||||
=item $about = $e->about()
|
||||
|
||||
This will return the 'about' facet hashref.
|
||||
|
||||
B<NOTE:> This will return the internal hashref, not a copy.
|
||||
|
||||
=item $trace = $e->trace()
|
||||
|
||||
This will return the 'trace' facet, normally blessed (but this is not enforced
|
||||
when the trace is set using C<set_trace()>.
|
||||
|
||||
B<NOTE:> This will return the internal trace, not a copy.
|
||||
|
||||
=back
|
||||
|
||||
=head2 MUTATION
|
||||
|
||||
=over 4
|
||||
|
||||
=item $e->add_amnesty({...})
|
||||
|
||||
Inherited from L<Test2::Event>. This can be used to add 'amnesty' facets to an
|
||||
existing event. Each new item is added to the B<END> of the list.
|
||||
|
||||
B<NOTE:> Items B<ARE> blessed when added.
|
||||
|
||||
=item $e->add_hub({...})
|
||||
|
||||
Inherited from L<Test2::Event>. This is used by hubs to stamp events as they
|
||||
pass through. New items are added to the B<START> of the list.
|
||||
|
||||
B<NOTE:> Items B<ARE NOT> blessed when added.
|
||||
|
||||
=item $e->set_uuid($UUID)
|
||||
|
||||
Inherited from L<Test2::Event>, overridden to also vivify/mutate the 'about'
|
||||
facet.
|
||||
|
||||
=item $e->set_trace($trace)
|
||||
|
||||
Inherited from L<Test2::Event> which allows you to change the trace.
|
||||
|
||||
B<Note:> This method does not bless/clone the trace for you. Many things will
|
||||
expect the trace to be blessed, so you should probably do that.
|
||||
|
||||
=back
|
||||
|
||||
=head2 LEGACY SUPPORT METHODS
|
||||
|
||||
These are all imported from L<Test2::Util::Facets2Legacy>, see that module or
|
||||
L<Test2::Event> for documentation on what they do.
|
||||
|
||||
=over 4
|
||||
|
||||
=item causes_fail
|
||||
|
||||
=item diagnostics
|
||||
|
||||
=item global
|
||||
|
||||
=item increments_count
|
||||
|
||||
=item no_display
|
||||
|
||||
=item sets_plan
|
||||
|
||||
=item subtest_id
|
||||
|
||||
=item summary
|
||||
|
||||
=item terminate
|
||||
|
||||
=back
|
||||
|
||||
=head1 THIRD PARTY META-DATA
|
||||
|
||||
This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
|
||||
way for you to attach meta-data to instances of this class. This is useful for
|
||||
tools, plugins, and other extensions.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
76
t/lib/Test2/Event/Waiting.pm
Normal file
76
t/lib/Test2/Event/Waiting.pm
Normal file
|
|
@ -0,0 +1,76 @@
|
|||
package Test2::Event::Waiting;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
|
||||
use Test2::Util::HashBase;
|
||||
|
||||
sub global { 1 };
|
||||
|
||||
sub summary { "IPC is waiting for children to finish..." }
|
||||
|
||||
sub facet_data {
|
||||
my $self = shift;
|
||||
|
||||
my $out = $self->common_facet_data;
|
||||
|
||||
push @{$out->{info}} => {
|
||||
tag => 'INFO',
|
||||
debug => 0,
|
||||
details => $self->summary,
|
||||
};
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Waiting - Tell all procs/threads it is time to be done
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This event has no data of its own. This event is sent out by the IPC system
|
||||
when the main process/thread is ready to end.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
93
t/lib/Test2/EventFacet.pm
Normal file
93
t/lib/Test2/EventFacet.pm
Normal file
|
|
@ -0,0 +1,93 @@
|
|||
package Test2::EventFacet;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
use Test2::Util::HashBase qw/-details/;
|
||||
use Carp qw/croak/;
|
||||
|
||||
my $SUBLEN = length(__PACKAGE__ . '::');
|
||||
sub facet_key {
|
||||
my $key = ref($_[0]) || $_[0];
|
||||
substr($key, 0, $SUBLEN, '');
|
||||
return lc($key);
|
||||
}
|
||||
|
||||
sub is_list { 0 }
|
||||
|
||||
sub clone {
|
||||
my $self = shift;
|
||||
my $type = ref($self);
|
||||
return bless {%$self, @_}, $type;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet - Base class for all event facets.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Base class for all event facets.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $key = $facet_class->facet_key()
|
||||
|
||||
This will return the key for the facet in the facet data hash.
|
||||
|
||||
=item $bool = $facet_class->is_list()
|
||||
|
||||
This will return true if the facet should be in a list instead of a single
|
||||
item.
|
||||
|
||||
=item $clone = $facet->clone()
|
||||
|
||||
=item $clone = $facet->clone(%replace)
|
||||
|
||||
This will make a shallow clone of the facet. You may specify fields to override
|
||||
as arguments.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
92
t/lib/Test2/EventFacet/About.pm
Normal file
92
t/lib/Test2/EventFacet/About.pm
Normal file
|
|
@ -0,0 +1,92 @@
|
|||
package Test2::EventFacet::About;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
|
||||
use Test2::Util::HashBase qw{ -package -no_display -uuid -eid };
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet::About - Facet with event details.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This facet has information about the event, such as event package.
|
||||
|
||||
=head1 FIELDS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $string = $about->{details}
|
||||
|
||||
=item $string = $about->details()
|
||||
|
||||
Summary about the event.
|
||||
|
||||
=item $package = $about->{package}
|
||||
|
||||
=item $package = $about->package()
|
||||
|
||||
Event package name.
|
||||
|
||||
=item $bool = $about->{no_display}
|
||||
|
||||
=item $bool = $about->no_display()
|
||||
|
||||
True if the event should be skipped by formatters.
|
||||
|
||||
=item $uuid = $about->{uuid}
|
||||
|
||||
=item $uuid = $about->uuid()
|
||||
|
||||
Will be set to a uuid if uuid tagging was enabled.
|
||||
|
||||
=item $uuid = $about->{eid}
|
||||
|
||||
=item $uuid = $about->eid()
|
||||
|
||||
A unique (for the test job) identifier for the event.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
91
t/lib/Test2/EventFacet/Amnesty.pm
Normal file
91
t/lib/Test2/EventFacet/Amnesty.pm
Normal file
|
|
@ -0,0 +1,91 @@
|
|||
package Test2::EventFacet::Amnesty;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
sub is_list { 1 }
|
||||
|
||||
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
|
||||
use Test2::Util::HashBase qw{ -tag -inherited };
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet::Amnesty - Facet for assertion amnesty.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package represents what is expected in units of amnesty.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
This facet appears in a list instead of being a single item.
|
||||
|
||||
=head1 FIELDS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $string = $amnesty->{details}
|
||||
|
||||
=item $string = $amnesty->details()
|
||||
|
||||
Human readable explanation of why amnesty was granted.
|
||||
|
||||
Example: I<Not implemented yet, will fix>
|
||||
|
||||
=item $short_string = $amnesty->{tag}
|
||||
|
||||
=item $short_string = $amnesty->tag()
|
||||
|
||||
Short string (usually 10 characters or less, not enforced, but may be truncated
|
||||
by renderers) categorizing the amnesty.
|
||||
|
||||
=item $bool = $amnesty->{inherited}
|
||||
|
||||
=item $bool = $amnesty->inherited()
|
||||
|
||||
This will be true if the amnesty was granted to a parent event and inherited by
|
||||
this event, which is a child, such as an assertion within a subtest that is
|
||||
marked todo.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
93
t/lib/Test2/EventFacet/Assert.pm
Normal file
93
t/lib/Test2/EventFacet/Assert.pm
Normal file
|
|
@ -0,0 +1,93 @@
|
|||
package Test2::EventFacet::Assert;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
|
||||
use Test2::Util::HashBase qw{ -pass -no_debug -number };
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet::Assert - Facet representing an assertion.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The assertion facet is provided by any event representing an assertion that was
|
||||
made.
|
||||
|
||||
=head1 FIELDS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $string = $assert->{details}
|
||||
|
||||
=item $string = $assert->details()
|
||||
|
||||
Human readable description of the assertion.
|
||||
|
||||
=item $bool = $assert->{pass}
|
||||
|
||||
=item $bool = $assert->pass()
|
||||
|
||||
True if the assertion passed.
|
||||
|
||||
=item $bool = $assert->{no_debug}
|
||||
|
||||
=item $bool = $assert->no_debug()
|
||||
|
||||
Set this to true if you have provided custom diagnostics and do not want the
|
||||
defaults to be displayed.
|
||||
|
||||
=item $int = $assert->{number}
|
||||
|
||||
=item $int = $assert->number()
|
||||
|
||||
(Optional) assertion number. This may be omitted or ignored. This is usually
|
||||
only useful when parsing/processing TAP.
|
||||
|
||||
B<Note>: This is not set by the Test2 system, assertion number is not known
|
||||
until AFTER the assertion has been processed. This attribute is part of the
|
||||
spec only for harnesses.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
107
t/lib/Test2/EventFacet/Control.pm
Normal file
107
t/lib/Test2/EventFacet/Control.pm
Normal file
|
|
@ -0,0 +1,107 @@
|
|||
package Test2::EventFacet::Control;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
|
||||
use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding -phase };
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet::Control - Facet for hub actions and behaviors.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This facet is used when the event needs to give instructions to the Test2
|
||||
internals.
|
||||
|
||||
=head1 FIELDS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $string = $control->{details}
|
||||
|
||||
=item $string = $control->details()
|
||||
|
||||
Human readable explanation for the special behavior.
|
||||
|
||||
=item $bool = $control->{global}
|
||||
|
||||
=item $bool = $control->global()
|
||||
|
||||
True if the event is global in nature and should be seen by all hubs.
|
||||
|
||||
=item $exit = $control->{terminate}
|
||||
|
||||
=item $exit = $control->terminate()
|
||||
|
||||
Defined if the test should immediately exit, the value is the exit code and may
|
||||
be C<0>.
|
||||
|
||||
=item $bool = $control->{halt}
|
||||
|
||||
=item $bool = $control->halt()
|
||||
|
||||
True if all testing should be halted immediately.
|
||||
|
||||
=item $bool = $control->{has_callback}
|
||||
|
||||
=item $bool = $control->has_callback()
|
||||
|
||||
True if the C<callback($hub)> method on the event should be called.
|
||||
|
||||
=item $encoding = $control->{encoding}
|
||||
|
||||
=item $encoding = $control->encoding()
|
||||
|
||||
This can be used to change the encoding from this event onward.
|
||||
|
||||
=item $phase = $control->{phase}
|
||||
|
||||
=item $phase = $control->phase()
|
||||
|
||||
Used to signal that a phase change has occurred. Currently only the perl END
|
||||
phase is signaled.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
93
t/lib/Test2/EventFacet/Error.pm
Normal file
93
t/lib/Test2/EventFacet/Error.pm
Normal file
|
|
@ -0,0 +1,93 @@
|
|||
package Test2::EventFacet::Error;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
sub facet_key { 'errors' }
|
||||
sub is_list { 1 }
|
||||
|
||||
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
|
||||
use Test2::Util::HashBase qw{ -tag -fail };
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet::Error - Facet for errors that need to be shown.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This facet is used when an event needs to convey errors.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
This facet has the hash key C<'errors'>, and is a list of facets instead of a
|
||||
single item.
|
||||
|
||||
=head1 FIELDS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $string = $error->{details}
|
||||
|
||||
=item $string = $error->details()
|
||||
|
||||
Explanation of the error, or the error itself (such as an exception). In perl
|
||||
exceptions may be blessed objects, so this field may contain a blessed object.
|
||||
|
||||
=item $short_string = $error->{tag}
|
||||
|
||||
=item $short_string = $error->tag()
|
||||
|
||||
Short tag to categorize the error. This is usually 10 characters or less,
|
||||
formatters may truncate longer tags.
|
||||
|
||||
=item $bool = $error->{fail}
|
||||
|
||||
=item $bool = $error->fail()
|
||||
|
||||
Not all errors are fatal, some are displayed having already been handled. Set
|
||||
this to true if you want the error to cause the test to fail. Without this the
|
||||
error is simply a diagnostics message that has no effect on the overall
|
||||
pass/fail result.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
109
t/lib/Test2/EventFacet/Hub.pm
Normal file
109
t/lib/Test2/EventFacet/Hub.pm
Normal file
|
|
@ -0,0 +1,109 @@
|
|||
package Test2::EventFacet::Hub;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
sub is_list { 1 }
|
||||
sub facet_key { 'hubs' }
|
||||
|
||||
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
|
||||
use Test2::Util::HashBase qw{-pid -tid -hid -nested -buffered -uuid -ipc};
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet::Hub - Facet for the hubs an event passes through.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
These are a record of the hubs an event passes through. Most recent hub is the
|
||||
first one in the list.
|
||||
|
||||
=head1 FACET FIELDS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $string = $trace->{details}
|
||||
|
||||
=item $string = $trace->details()
|
||||
|
||||
The hub class or subclass
|
||||
|
||||
=item $int = $trace->{pid}
|
||||
|
||||
=item $int = $trace->pid()
|
||||
|
||||
PID of the hub this event was sent to.
|
||||
|
||||
=item $int = $trace->{tid}
|
||||
|
||||
=item $int = $trace->tid()
|
||||
|
||||
The thread ID of the hub the event was sent to.
|
||||
|
||||
=item $hid = $trace->{hid}
|
||||
|
||||
=item $hid = $trace->hid()
|
||||
|
||||
The ID of the hub that the event was send to.
|
||||
|
||||
=item $huuid = $trace->{huuid}
|
||||
|
||||
=item $huuid = $trace->huuid()
|
||||
|
||||
The UUID of the hub that the event was sent to.
|
||||
|
||||
=item $int = $trace->{nested}
|
||||
|
||||
=item $int = $trace->nested()
|
||||
|
||||
How deeply nested the hub was.
|
||||
|
||||
=item $bool = $trace->{buffered}
|
||||
|
||||
=item $bool = $trace->buffered()
|
||||
|
||||
True if the event was buffered and not sent to the formatter independent of a
|
||||
parent (This should never be set when nested is C<0> or C<undef>).
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
132
t/lib/Test2/EventFacet/Info.pm
Normal file
132
t/lib/Test2/EventFacet/Info.pm
Normal file
|
|
@ -0,0 +1,132 @@
|
|||
package Test2::EventFacet::Info;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
sub is_list { 1 }
|
||||
|
||||
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
|
||||
use Test2::Util::HashBase qw{-tag -debug -important -table};
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet::Info - Facet for information a developer might care about.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This facet represents messages intended for humans that will help them either
|
||||
understand a result, or diagnose a failure.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
This facet appears in a list instead of being a single item.
|
||||
|
||||
=head1 FIELDS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $string_or_structure = $info->{details}
|
||||
|
||||
=item $string_or_structure = $info->details()
|
||||
|
||||
Human readable string or data structure, this is the information to display.
|
||||
Formatters are free to render the structures however they please. This may
|
||||
contain a blessed object.
|
||||
|
||||
If the C<table> attribute (see below) is set then a renderer may choose to
|
||||
display the table instead of the details.
|
||||
|
||||
=item $structure = $info->{table}
|
||||
|
||||
=item $structure = $info->table()
|
||||
|
||||
If the data the C<info> facet needs to convey can be represented as a table
|
||||
then the data may be placed in this attribute in a more raw form for better
|
||||
display. The data must also be represented in the C<details> attribute for
|
||||
renderers which do not support rendering tables directly.
|
||||
|
||||
The table structure:
|
||||
|
||||
my %table = {
|
||||
header => [ 'column 1 header', 'column 2 header', ... ], # Optional
|
||||
|
||||
rows => [
|
||||
['row 1 column 1', 'row 1, column 2', ... ],
|
||||
['row 2 column 1', 'row 2, column 2', ... ],
|
||||
...
|
||||
],
|
||||
|
||||
# Allow the renderer to hide empty columns when true, Optional
|
||||
collapse => $BOOL,
|
||||
|
||||
# List by name or number columns that should never be collapsed
|
||||
no_collapse => \@LIST,
|
||||
}
|
||||
|
||||
=item $short_string = $info->{tag}
|
||||
|
||||
=item $short_string = $info->tag()
|
||||
|
||||
Short tag to categorize the info. This is usually 10 characters or less,
|
||||
formatters may truncate longer tags.
|
||||
|
||||
=item $bool = $info->{debug}
|
||||
|
||||
=item $bool = $info->debug()
|
||||
|
||||
Set this to true if the message is critical, or explains a failure. This is
|
||||
info that should be displayed by formatters even in less-verbose modes.
|
||||
|
||||
When false the information is not considered critical and may not be rendered
|
||||
in less-verbose modes.
|
||||
|
||||
=item $bool = $info->{important}
|
||||
|
||||
=item $bool = $info->important
|
||||
|
||||
This should be set for non debug messages that are still important enough to
|
||||
show when a formatter is in quiet mode. A formatter should send these to STDOUT
|
||||
not STDERR, but should show them even in non-verbose mode.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
144
t/lib/Test2/EventFacet/Info/Table.pm
Normal file
144
t/lib/Test2/EventFacet/Info/Table.pm
Normal file
|
|
@ -0,0 +1,144 @@
|
|||
package Test2::EventFacet::Info::Table;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
use Carp qw/confess/;
|
||||
|
||||
use Test2::Util::HashBase qw{-header -rows -collapse -no_collapse -as_string};
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
confess "Table may not be empty" unless ref($self->{+ROWS}) eq 'ARRAY' && @{$self->{+ROWS}};
|
||||
|
||||
$self->{+AS_STRING} ||= '<TABLE NOT DISPLAYED>';
|
||||
}
|
||||
|
||||
sub as_hash { my $out = +{%{$_[0]}}; delete $out->{as_string}; $out }
|
||||
|
||||
sub info_args {
|
||||
my $self = shift;
|
||||
|
||||
my $hash = $self->as_hash;
|
||||
my $desc = $self->as_string;
|
||||
|
||||
return (table => $hash, details => $desc);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet::Info::Table - Intermediary representation of a table.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Intermediary representation of a table for use in specialized
|
||||
L<Test::API::Context> methods which generate L<Test2::EventFacet::Info> facets.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::EventFacet::Info::Table;
|
||||
use Test2::API qw/context/;
|
||||
|
||||
sub my_tool {
|
||||
my $ctx = context();
|
||||
|
||||
...
|
||||
|
||||
$ctx->fail(
|
||||
$name,
|
||||
"failure diag message",
|
||||
Test2::EventFacet::Info::Table->new(
|
||||
# Required
|
||||
rows => [['a', 'b'], ['c', 'd'], ...],
|
||||
|
||||
# Strongly Recommended
|
||||
as_string => "... string to print when table cannot be rendered ...",
|
||||
|
||||
# Optional
|
||||
header => ['col1', 'col2'],
|
||||
collapse => $bool,
|
||||
no_collapse => ['col1', ...],
|
||||
),
|
||||
);
|
||||
|
||||
...
|
||||
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
my_tool();
|
||||
|
||||
=head1 ATTRIBUTES
|
||||
|
||||
=over 4
|
||||
|
||||
=item $header_aref = $t->header()
|
||||
|
||||
=item $rows_aref = $t->rows()
|
||||
|
||||
=item $bool = $t->collapse()
|
||||
|
||||
=item $aref = $t->no_collapse()
|
||||
|
||||
The above are all directly tied to the table hashref structure described in
|
||||
L<Test2::EventFacet::Info>.
|
||||
|
||||
=item $str = $t->as_string()
|
||||
|
||||
This returns the string form of the table if it was set, otherwise it returns
|
||||
the string C<< "<TABLE NOT DISPLAYED>" >>.
|
||||
|
||||
=item $href = $t->as_hash()
|
||||
|
||||
This returns the data structure used for tables by L<Test2::EventFacet::Info>.
|
||||
|
||||
=item %args = $t->info_args()
|
||||
|
||||
This returns the arguments that should be used to construct the proper
|
||||
L<Test2::EventFacet::Info> structure.
|
||||
|
||||
return (table => $t->as_hash(), details => $t->as_string());
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
104
t/lib/Test2/EventFacet/Meta.pm
Normal file
104
t/lib/Test2/EventFacet/Meta.pm
Normal file
|
|
@ -0,0 +1,104 @@
|
|||
package Test2::EventFacet::Meta;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
|
||||
use vars qw/$AUTOLOAD/;
|
||||
|
||||
# replace set_details
|
||||
{
|
||||
no warnings 'redefine';
|
||||
sub set_details { $_[0]->{'set_details'} }
|
||||
}
|
||||
|
||||
sub can {
|
||||
my $self = shift;
|
||||
my ($name) = @_;
|
||||
|
||||
my $existing = $self->SUPER::can($name);
|
||||
return $existing if $existing;
|
||||
|
||||
# Only vivify when called on an instance, do not vivify for a class. There
|
||||
# are a lot of magic class methods used in things like serialization (or
|
||||
# the forks.pm module) which cause problems when vivified.
|
||||
return undef unless ref($self);
|
||||
|
||||
my $sub = sub { $_[0]->{$name} };
|
||||
{
|
||||
no strict 'refs';
|
||||
*$name = $sub;
|
||||
}
|
||||
|
||||
return $sub;
|
||||
}
|
||||
|
||||
sub AUTOLOAD {
|
||||
my $name = $AUTOLOAD;
|
||||
$name =~ s/^.*:://g;
|
||||
my $sub = $_[0]->can($name);
|
||||
goto &$sub;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet::Meta - Facet for meta-data
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This facet can contain any random meta-data that has been attached to the
|
||||
event.
|
||||
|
||||
=head1 METHODS AND FIELDS
|
||||
|
||||
Any/all fields and accessors are autovivified into existence. There is no way
|
||||
to know what metadata may be added, so any is allowed.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $anything = $meta->{anything}
|
||||
|
||||
=item $anything = $meta->anything()
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
98
t/lib/Test2/EventFacet/Parent.pm
Normal file
98
t/lib/Test2/EventFacet/Parent.pm
Normal file
|
|
@ -0,0 +1,98 @@
|
|||
package Test2::EventFacet::Parent;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
use Carp qw/confess/;
|
||||
|
||||
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
|
||||
use Test2::Util::HashBase qw{ -hid -children -buffered };
|
||||
|
||||
sub init {
|
||||
confess "Attribute 'hid' must be set"
|
||||
unless defined $_[0]->{+HID};
|
||||
|
||||
$_[0]->{+CHILDREN} ||= [];
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet::Parent - Facet for events contains other events
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This facet is used when an event contains other events, such as a subtest.
|
||||
|
||||
=head1 FIELDS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $string = $parent->{details}
|
||||
|
||||
=item $string = $parent->details()
|
||||
|
||||
Human readable description of the event.
|
||||
|
||||
=item $hid = $parent->{hid}
|
||||
|
||||
=item $hid = $parent->hid()
|
||||
|
||||
Hub ID of the hub that is represented in the parent-child relationship.
|
||||
|
||||
=item $arrayref = $parent->{children}
|
||||
|
||||
=item $arrayref = $parent->children()
|
||||
|
||||
Arrayref containing the facet-data hashes of events nested under this one.
|
||||
|
||||
I<To get the actual events you need to get them from the parent event directly>
|
||||
|
||||
=item $bool = $parent->{buffered}
|
||||
|
||||
=item $bool = $parent->buffered()
|
||||
|
||||
True if the subtest is buffered (meaning the formatter has probably not seen
|
||||
them yet).
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
94
t/lib/Test2/EventFacet/Plan.pm
Normal file
94
t/lib/Test2/EventFacet/Plan.pm
Normal file
|
|
@ -0,0 +1,94 @@
|
|||
package Test2::EventFacet::Plan;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
|
||||
use Test2::Util::HashBase qw{ -count -skip -none };
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet::Plan - Facet for setting the plan
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Events use this facet when they need to set the plan.
|
||||
|
||||
=head1 FIELDS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $string = $plan->{details}
|
||||
|
||||
=item $string = $plan->details()
|
||||
|
||||
Human readable explanation for the plan being set. This is normally not
|
||||
rendered by most formatters except when the C<skip> field is also set.
|
||||
|
||||
=item $positive_int = $plan->{count}
|
||||
|
||||
=item $positive_int = $plan->count()
|
||||
|
||||
Set the number of expected assertions. This should usually be set to C<0> when
|
||||
C<skip> or C<none> are also set.
|
||||
|
||||
=item $bool = $plan->{skip}
|
||||
|
||||
=item $bool = $plan->skip()
|
||||
|
||||
When true the entire test should be skipped. This is usually paired with an
|
||||
explanation in the C<details> field, and a C<control> facet that has
|
||||
C<terminate> set to C<0>.
|
||||
|
||||
=item $bool = $plan->{none}
|
||||
|
||||
=item $bool = $plan->none()
|
||||
|
||||
This is mainly used by legacy L<Test::Builder> tests which set the plan to C<no
|
||||
plan>, a construct that predates the much better C<done_testing()>.
|
||||
|
||||
If you are using this in non-legacy code you may need to reconsider the course
|
||||
of your life, maybe a hermitage would suite you?
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
106
t/lib/Test2/EventFacet/Render.pm
Normal file
106
t/lib/Test2/EventFacet/Render.pm
Normal file
|
|
@ -0,0 +1,106 @@
|
|||
package Test2::EventFacet::Render;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
sub is_list { 1 }
|
||||
|
||||
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
|
||||
use Test2::Util::HashBase qw{ -tag -facet -mode };
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet::Render - Facet that dictates how to render an event.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This facet is used to dictate how the event should be rendered by the standard
|
||||
test2 rendering tools. If this facet is present then ONLY what is specified by
|
||||
it will be rendered. It is assumed that anything important or note-worthy will
|
||||
be present here, no other facets will be considered for rendering/display.
|
||||
|
||||
This facet is a list type, you can add as many items as needed.
|
||||
|
||||
=head1 FIELDS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $string = $render->[#]->{details}
|
||||
|
||||
=item $string = $render->[#]->details()
|
||||
|
||||
Human readable text for display.
|
||||
|
||||
=item $string = $render->[#]->{tag}
|
||||
|
||||
=item $string = $render->[#]->tag()
|
||||
|
||||
Tag that should prefix/identify the main text.
|
||||
|
||||
=item $string = $render->[#]->{facet}
|
||||
|
||||
=item $string = $render->[#]->facet()
|
||||
|
||||
Optional, if the display text was generated from another facet this should
|
||||
state what facet it was.
|
||||
|
||||
=item $mode = $render->[#]->{mode}
|
||||
|
||||
=item $mode = $render->[#]->mode()
|
||||
|
||||
=over 4
|
||||
|
||||
=item calculated
|
||||
|
||||
Calculated means the facet was generated from another facet. Calculated facets
|
||||
may be cleared and regenerated whenever the event state changes.
|
||||
|
||||
=item replace
|
||||
|
||||
Replace means the facet is intended to replace the normal rendering of the
|
||||
event.
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
279
t/lib/Test2/EventFacet/Trace.pm
Normal file
279
t/lib/Test2/EventFacet/Trace.pm
Normal file
|
|
@ -0,0 +1,279 @@
|
|||
package Test2::EventFacet::Trace;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
|
||||
|
||||
use Test2::Util qw/get_tid pkg_to_file gen_uid/;
|
||||
use Carp qw/confess/;
|
||||
|
||||
use Test2::Util::HashBase qw{^frame ^pid ^tid ^cid -hid -nested details -buffered -uuid -huuid};
|
||||
|
||||
{
|
||||
no warnings 'once';
|
||||
*DETAIL = \&DETAILS;
|
||||
*detail = \&details;
|
||||
*set_detail = \&set_details;
|
||||
}
|
||||
|
||||
sub init {
|
||||
confess "The 'frame' attribute is required"
|
||||
unless $_[0]->{+FRAME};
|
||||
|
||||
$_[0]->{+DETAILS} = delete $_[0]->{detail} if $_[0]->{detail};
|
||||
|
||||
unless (defined($_[0]->{+PID}) || defined($_[0]->{+TID}) || defined($_[0]->{+CID})) {
|
||||
$_[0]->{+PID} = $$ unless defined $_[0]->{+PID};
|
||||
$_[0]->{+TID} = get_tid() unless defined $_[0]->{+TID};
|
||||
}
|
||||
}
|
||||
|
||||
sub snapshot {
|
||||
my ($orig, @override) = @_;
|
||||
bless {%$orig, @override}, __PACKAGE__;
|
||||
}
|
||||
|
||||
sub signature {
|
||||
my $self = shift;
|
||||
|
||||
# Signature is only valid if all of these fields are defined, there is no
|
||||
# signature if any is missing. '0' is ok, but '' is not.
|
||||
return join ':' => map { (defined($_) && length($_)) ? $_ : return undef } (
|
||||
$self->{+CID},
|
||||
$self->{+PID},
|
||||
$self->{+TID},
|
||||
$self->{+FRAME}->[1],
|
||||
$self->{+FRAME}->[2],
|
||||
);
|
||||
}
|
||||
|
||||
sub debug {
|
||||
my $self = shift;
|
||||
return $self->{+DETAILS} if $self->{+DETAILS};
|
||||
my ($pkg, $file, $line) = $self->call;
|
||||
return "at $file line $line";
|
||||
}
|
||||
|
||||
sub alert {
|
||||
my $self = shift;
|
||||
my ($msg) = @_;
|
||||
warn $msg . ' ' . $self->debug . ".\n";
|
||||
}
|
||||
|
||||
sub throw {
|
||||
my $self = shift;
|
||||
my ($msg) = @_;
|
||||
die $msg . ' ' . $self->debug . ".\n";
|
||||
}
|
||||
|
||||
sub call { @{$_[0]->{+FRAME}} }
|
||||
|
||||
sub package { $_[0]->{+FRAME}->[0] }
|
||||
sub file { $_[0]->{+FRAME}->[1] }
|
||||
sub line { $_[0]->{+FRAME}->[2] }
|
||||
sub subname { $_[0]->{+FRAME}->[3] }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::EventFacet::Trace - Debug information for events
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The L<Test2::API::Context> object, as well as all L<Test2::Event> types need to
|
||||
have access to information about where they were created. This object
|
||||
represents that information.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::EventFacet::Trace;
|
||||
|
||||
my $trace = Test2::EventFacet::Trace->new(
|
||||
frame => [$package, $file, $line, $subname],
|
||||
);
|
||||
|
||||
=head1 FACET FIELDS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $string = $trace->{details}
|
||||
|
||||
=item $string = $trace->details()
|
||||
|
||||
Used as a custom trace message that will be used INSTEAD of
|
||||
C<< at <FILE> line <LINE> >> when calling C<< $trace->debug >>.
|
||||
|
||||
=item $frame = $trace->{frame}
|
||||
|
||||
=item $frame = $trace->frame()
|
||||
|
||||
Get the call frame arrayref.
|
||||
|
||||
=item $int = $trace->{pid}
|
||||
|
||||
=item $int = $trace->pid()
|
||||
|
||||
The process ID in which the event was generated.
|
||||
|
||||
=item $int = $trace->{tid}
|
||||
|
||||
=item $int = $trace->tid()
|
||||
|
||||
The thread ID in which the event was generated.
|
||||
|
||||
=item $id = $trace->{cid}
|
||||
|
||||
=item $id = $trace->cid()
|
||||
|
||||
The ID of the context that was used to create the event.
|
||||
|
||||
=item $uuid = $trace->{uuid}
|
||||
|
||||
=item $uuid = $trace->uuid()
|
||||
|
||||
The UUID of the context that was used to create the event. (If uuid tagging was
|
||||
enabled)
|
||||
|
||||
=back
|
||||
|
||||
=head2 DISCOURAGED HUB RELATED FIELDS
|
||||
|
||||
These fields were not always set properly by tools. These are B<MOSTLY>
|
||||
deprecated by the L<Test2::EventFacet::Hub> facets. These fields are not
|
||||
required, and may only reflect the hub that was current when the event was
|
||||
created, which is not necessarily the same as the hub the event was sent
|
||||
through.
|
||||
|
||||
Some tools did do a good job setting these to the correct hub, but you cannot
|
||||
always rely on that. Use the 'hubs' facet list instead.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $hid = $trace->{hid}
|
||||
|
||||
=item $hid = $trace->hid()
|
||||
|
||||
The ID of the hub that was current when the event was created.
|
||||
|
||||
=item $huuid = $trace->{huuid}
|
||||
|
||||
=item $huuid = $trace->huuid()
|
||||
|
||||
The UUID of the hub that was current when the event was created. (If uuid
|
||||
tagging was enabled).
|
||||
|
||||
=item $int = $trace->{nested}
|
||||
|
||||
=item $int = $trace->nested()
|
||||
|
||||
How deeply nested the event is.
|
||||
|
||||
=item $bool = $trace->{buffered}
|
||||
|
||||
=item $bool = $trace->buffered()
|
||||
|
||||
True if the event was buffered and not sent to the formatter independent of a
|
||||
parent (This should never be set when nested is C<0> or C<undef>).
|
||||
|
||||
=back
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
B<Note:> All facet frames are also methods.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $trace->set_detail($msg)
|
||||
|
||||
=item $msg = $trace->detail
|
||||
|
||||
Used to get/set a custom trace message that will be used INSTEAD of
|
||||
C<< at <FILE> line <LINE> >> when calling C<< $trace->debug >>.
|
||||
|
||||
C<detail()> is an alias to the C<details> facet field for backwards
|
||||
compatibility.
|
||||
|
||||
=item $str = $trace->debug
|
||||
|
||||
Typically returns the string C<< at <FILE> line <LINE> >>. If C<detail> is set
|
||||
then its value will be returned instead.
|
||||
|
||||
=item $trace->alert($MESSAGE)
|
||||
|
||||
This issues a warning at the frame (filename and line number where
|
||||
errors should be reported).
|
||||
|
||||
=item $trace->throw($MESSAGE)
|
||||
|
||||
This throws an exception at the frame (filename and line number where
|
||||
errors should be reported).
|
||||
|
||||
=item ($package, $file, $line, $subname) = $trace->call()
|
||||
|
||||
Get the caller details for the debug-info. This is where errors should be
|
||||
reported.
|
||||
|
||||
=item $pkg = $trace->package
|
||||
|
||||
Get the debug-info package.
|
||||
|
||||
=item $file = $trace->file
|
||||
|
||||
Get the debug-info filename.
|
||||
|
||||
=item $line = $trace->line
|
||||
|
||||
Get the debug-info line number.
|
||||
|
||||
=item $subname = $trace->subname
|
||||
|
||||
Get the debug-info subroutine name.
|
||||
|
||||
=item $sig = trace->signature
|
||||
|
||||
Get a signature string that identifies this trace. This is used to check if
|
||||
multiple events are related. The signature includes pid, tid, file, line
|
||||
number, and the cid.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
158
t/lib/Test2/Formatter.pm
Normal file
158
t/lib/Test2/Formatter.pm
Normal file
|
|
@ -0,0 +1,158 @@
|
|||
package Test2::Formatter;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
my %ADDED;
|
||||
sub import {
|
||||
my $class = shift;
|
||||
return if $class eq __PACKAGE__;
|
||||
return if $ADDED{$class}++;
|
||||
require Test2::API;
|
||||
Test2::API::test2_formatter_add($class);
|
||||
}
|
||||
|
||||
sub new_root {
|
||||
my $class = shift;
|
||||
return $class->new(@_);
|
||||
}
|
||||
|
||||
sub supports_tables { 0 }
|
||||
|
||||
sub hide_buffered { 1 }
|
||||
|
||||
sub terminate { }
|
||||
|
||||
sub finalize { }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Formatter - Namespace for formatters.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the namespace for formatters. This is an empty package.
|
||||
|
||||
=head1 CREATING FORMATTERS
|
||||
|
||||
A formatter is any package or object with a C<write($event, $num)> method.
|
||||
|
||||
package Test2::Formatter::Foo;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
sub write {
|
||||
my $self_or_class = shift;
|
||||
my ($event, $assert_num) = @_;
|
||||
...
|
||||
}
|
||||
|
||||
sub hide_buffered { 1 }
|
||||
|
||||
sub terminate { }
|
||||
|
||||
sub finalize { }
|
||||
|
||||
sub supports_tables { return $BOOL }
|
||||
|
||||
sub new_root {
|
||||
my $class = shift;
|
||||
...
|
||||
$class->new(@_);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
The C<write> method is a method, so it either gets a class or instance. The two
|
||||
arguments are the C<$event> object it should record, and the C<$assert_num>
|
||||
which is the number of the current assertion (ok), or the last assertion if
|
||||
this event is not itself an assertion. The assertion number may be any integer 0
|
||||
or greater, and may be undefined in some cases.
|
||||
|
||||
The C<hide_buffered()> method must return a boolean. This is used to tell
|
||||
buffered subtests whether or not to send it events as they are being buffered.
|
||||
See L<Test2::API/"run_subtest(...)"> for more information.
|
||||
|
||||
The C<terminate> and C<finalize> methods are optional methods called that you
|
||||
can implement if the format you're generating needs to handle these cases, for
|
||||
example if you are generating XML and need close open tags.
|
||||
|
||||
The C<terminate> method is called when an event's C<terminate> method returns
|
||||
true, for example when a L<Test2::Event::Plan> has a C<'skip_all'> plan, or
|
||||
when a L<Test2::Event::Bail> event is sent. The C<terminate> method is passed
|
||||
a single argument, the L<Test2::Event> object which triggered the terminate.
|
||||
|
||||
The C<finalize> method is always the last thing called on the formatter, I<<
|
||||
except when C<terminate> is called for a Bail event >>. It is passed the
|
||||
following arguments:
|
||||
|
||||
The C<supports_tables> method should be true if the formatter supports directly
|
||||
rendering table data from the C<info> facets. This is a newer feature and many
|
||||
older formatters may not support it. When not supported the formatter falls
|
||||
back to rendering C<detail> instead of the C<table> data.
|
||||
|
||||
The C<new_root> method is used when constructing a root formatter. The default
|
||||
is to just delegate to the regular C<new()> method, most formatters can ignore
|
||||
this.
|
||||
|
||||
=over 4
|
||||
|
||||
=item * The number of tests that were planned
|
||||
|
||||
=item * The number of tests actually seen
|
||||
|
||||
=item * The number of tests which failed
|
||||
|
||||
=item * A boolean indicating whether or not the test suite passed
|
||||
|
||||
=item * A boolean indicating whether or not this call is for a subtest
|
||||
|
||||
=back
|
||||
|
||||
The C<new_root> method is called when C<Test2::API::Stack> Initializes the root
|
||||
hub for the first time. Most formatters will simply have this call C<<
|
||||
$class->new >>, which is the default behavior. Some formatters however may want
|
||||
to take extra action during construction of the root formatter, this is where
|
||||
they can do that.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
528
t/lib/Test2/Formatter/TAP.pm
Normal file
528
t/lib/Test2/Formatter/TAP.pm
Normal file
|
|
@ -0,0 +1,528 @@
|
|||
package Test2::Formatter::TAP;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
use Test2::Util qw/clone_io/;
|
||||
|
||||
use Test2::Util::HashBase qw{
|
||||
no_numbers handles _encoding _last_fh
|
||||
-made_assertion
|
||||
};
|
||||
|
||||
sub OUT_STD() { 0 }
|
||||
sub OUT_ERR() { 1 }
|
||||
|
||||
BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) }
|
||||
|
||||
my $supports_tables;
|
||||
sub supports_tables {
|
||||
if (!defined $supports_tables) {
|
||||
local $SIG{__DIE__} = 'DEFAULT';
|
||||
local $@;
|
||||
$supports_tables
|
||||
= ($INC{'Term/Table.pm'} && $INC{'Term/Table/Util.pm'})
|
||||
|| eval { require Term::Table; require Term::Table::Util; 1 }
|
||||
|| 0;
|
||||
}
|
||||
return $supports_tables;
|
||||
}
|
||||
|
||||
sub _autoflush {
|
||||
my($fh) = pop;
|
||||
my $old_fh = select $fh;
|
||||
$| = 1;
|
||||
select $old_fh;
|
||||
}
|
||||
|
||||
_autoflush(\*STDOUT);
|
||||
_autoflush(\*STDERR);
|
||||
|
||||
sub hide_buffered { 1 }
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
$self->{+HANDLES} ||= $self->_open_handles;
|
||||
if(my $enc = delete $self->{encoding}) {
|
||||
$self->encoding($enc);
|
||||
}
|
||||
}
|
||||
|
||||
sub _open_handles {
|
||||
my $self = shift;
|
||||
|
||||
require Test2::API;
|
||||
my $out = clone_io(Test2::API::test2_stdout());
|
||||
my $err = clone_io(Test2::API::test2_stderr());
|
||||
|
||||
_autoflush($out);
|
||||
_autoflush($err);
|
||||
|
||||
return [$out, $err];
|
||||
}
|
||||
|
||||
sub encoding {
|
||||
my $self = shift;
|
||||
|
||||
if ($] ge "5.007003" and @_) {
|
||||
my ($enc) = @_;
|
||||
my $handles = $self->{+HANDLES};
|
||||
|
||||
# https://rt.perl.org/Public/Bug/Display.html?id=31923
|
||||
# If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in
|
||||
# order to avoid the thread segfault.
|
||||
if ($enc =~ m/^utf-?8$/i) {
|
||||
binmode($_, ":utf8") for @$handles;
|
||||
}
|
||||
else {
|
||||
binmode($_, ":encoding($enc)") for @$handles;
|
||||
}
|
||||
$self->{+_ENCODING} = $enc;
|
||||
}
|
||||
|
||||
return $self->{+_ENCODING};
|
||||
}
|
||||
|
||||
if ($^C) {
|
||||
no warnings 'redefine';
|
||||
*write = sub {};
|
||||
}
|
||||
sub write {
|
||||
my ($self, $e, $num, $f) = @_;
|
||||
|
||||
# The most common case, a pass event with no amnesty and a normal name.
|
||||
return if $self->print_optimal_pass($e, $num);
|
||||
|
||||
$f ||= $e->facet_data;
|
||||
|
||||
$self->encoding($f->{control}->{encoding}) if $f->{control}->{encoding};
|
||||
|
||||
my @tap = $self->event_tap($f, $num) or return;
|
||||
|
||||
$self->{+MADE_ASSERTION} = 1 if $f->{assert};
|
||||
|
||||
my $nesting = $f->{trace}->{nested} || 0;
|
||||
my $handles = $self->{+HANDLES};
|
||||
my $indent = ' ' x $nesting;
|
||||
|
||||
# Local is expensive! Only do it if we really need to.
|
||||
local($\, $,) = (undef, '') if $\ || $,;
|
||||
for my $set (@tap) {
|
||||
no warnings 'uninitialized';
|
||||
my ($hid, $msg) = @$set;
|
||||
next unless $msg;
|
||||
my $io = $handles->[$hid] or next;
|
||||
|
||||
print $io "\n"
|
||||
if $ENV{HARNESS_ACTIVE}
|
||||
&& $hid == OUT_ERR
|
||||
&& $self->{+_LAST_FH} != $io
|
||||
&& $msg =~ m/^#\s*Failed( \(TODO\))? test /;
|
||||
|
||||
$msg =~ s/^/$indent/mg if $nesting;
|
||||
print $io $msg;
|
||||
$self->{+_LAST_FH} = $io;
|
||||
}
|
||||
}
|
||||
|
||||
sub print_optimal_pass {
|
||||
my ($self, $e, $num) = @_;
|
||||
|
||||
my $type = ref($e);
|
||||
|
||||
# Only optimal if this is a Pass or a passing Ok
|
||||
return unless $type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass});
|
||||
|
||||
# Amnesty requires further processing (todo is a form of amnesty)
|
||||
return if ($e->{amnesty} && @{$e->{amnesty}}) || defined($e->{todo});
|
||||
|
||||
# A name with a newline or hash symbol needs extra processing
|
||||
return if defined($e->{name}) && (-1 != index($e->{name}, "\n") || -1 != index($e->{name}, '#'));
|
||||
|
||||
my $ok = 'ok';
|
||||
$ok .= " $num" if $num && !$self->{+NO_NUMBERS};
|
||||
$ok .= defined($e->{name}) ? " - $e->{name}\n" : "\n";
|
||||
|
||||
if (my $nesting = $e->{trace}->{nested}) {
|
||||
my $indent = ' ' x $nesting;
|
||||
$ok = "$indent$ok";
|
||||
}
|
||||
|
||||
my $io = $self->{+HANDLES}->[OUT_STD];
|
||||
|
||||
local($\, $,) = (undef, '') if $\ || $,;
|
||||
print $io $ok;
|
||||
$self->{+_LAST_FH} = $io;
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub event_tap {
|
||||
my ($self, $f, $num) = @_;
|
||||
|
||||
my @tap;
|
||||
|
||||
# If this IS the first event the plan should come first
|
||||
# (plan must be before or after assertions, not in the middle)
|
||||
push @tap => $self->plan_tap($f) if $f->{plan} && !$self->{+MADE_ASSERTION};
|
||||
|
||||
# The assertion is most important, if present.
|
||||
if ($f->{assert}) {
|
||||
push @tap => $self->assert_tap($f, $num);
|
||||
push @tap => $self->debug_tap($f, $num) unless $f->{assert}->{no_debug} || $f->{assert}->{pass};
|
||||
}
|
||||
|
||||
# Almost as important as an assertion
|
||||
push @tap => $self->error_tap($f) if $f->{errors};
|
||||
|
||||
# Now lets see the diagnostics messages
|
||||
push @tap => $self->info_tap($f) if $f->{info};
|
||||
|
||||
# If this IS NOT the first event the plan should come last
|
||||
# (plan must be before or after assertions, not in the middle)
|
||||
push @tap => $self->plan_tap($f) if $self->{+MADE_ASSERTION} && $f->{plan};
|
||||
|
||||
# Bail out
|
||||
push @tap => $self->halt_tap($f) if $f->{control}->{halt};
|
||||
|
||||
return @tap if @tap;
|
||||
return @tap if $f->{control}->{halt};
|
||||
return @tap if grep { $f->{$_} } qw/assert plan info errors/;
|
||||
|
||||
# Use the summary as a fallback if nothing else is usable.
|
||||
return $self->summary_tap($f, $num);
|
||||
}
|
||||
|
||||
sub error_tap {
|
||||
my $self = shift;
|
||||
my ($f) = @_;
|
||||
|
||||
my $IO = ($f->{amnesty} && @{$f->{amnesty}}) ? OUT_STD : OUT_ERR;
|
||||
|
||||
return map {
|
||||
my $details = $_->{details};
|
||||
|
||||
my $msg;
|
||||
if (ref($details)) {
|
||||
require Data::Dumper;
|
||||
my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1);
|
||||
chomp($msg = $dumper->Dump);
|
||||
}
|
||||
else {
|
||||
chomp($msg = $details);
|
||||
$msg =~ s/^/# /;
|
||||
$msg =~ s/\n/\n# /g;
|
||||
}
|
||||
|
||||
[$IO, "$msg\n"];
|
||||
} @{$f->{errors}};
|
||||
}
|
||||
|
||||
sub plan_tap {
|
||||
my $self = shift;
|
||||
my ($f) = @_;
|
||||
my $plan = $f->{plan} or return;
|
||||
|
||||
return if $plan->{none};
|
||||
|
||||
if ($plan->{skip}) {
|
||||
my $reason = $plan->{details} or return [OUT_STD, "1..0 # SKIP\n"];
|
||||
chomp($reason);
|
||||
return [OUT_STD, '1..0 # SKIP ' . $reason . "\n"];
|
||||
}
|
||||
|
||||
return [OUT_STD, "1.." . $plan->{count} . "\n"];
|
||||
}
|
||||
|
||||
sub no_subtest_space { 0 }
|
||||
sub assert_tap {
|
||||
my $self = shift;
|
||||
my ($f, $num) = @_;
|
||||
|
||||
my $assert = $f->{assert} or return;
|
||||
my $pass = $assert->{pass};
|
||||
my $name = $assert->{details};
|
||||
|
||||
my $ok = $pass ? 'ok' : 'not ok';
|
||||
$ok .= " $num" if $num && !$self->{+NO_NUMBERS};
|
||||
|
||||
# The regex form is ~250ms, the index form is ~50ms
|
||||
my @extra;
|
||||
defined($name) && (
|
||||
(index($name, "\n") != -1 && (($name, @extra) = split(/\n\r?/, $name, -1))),
|
||||
((index($name, "#" ) != -1 || substr($name, -1) eq '\\') && (($name =~ s|\\|\\\\|g), ($name =~ s|#|\\#|g)))
|
||||
);
|
||||
|
||||
my $extra_space = @extra ? ' ' x (length($ok) + 2) : '';
|
||||
my $extra_indent = '';
|
||||
|
||||
my ($directives, $reason, $is_skip);
|
||||
if ($f->{amnesty}) {
|
||||
my %directives;
|
||||
|
||||
for my $am (@{$f->{amnesty}}) {
|
||||
next if $am->{inherited};
|
||||
my $tag = $am->{tag} or next;
|
||||
$is_skip = 1 if $tag eq 'skip';
|
||||
|
||||
$directives{$tag} ||= $am->{details};
|
||||
}
|
||||
|
||||
my %seen;
|
||||
|
||||
# Sort so that TODO comes before skip even on systems where lc sorts
|
||||
# before uc, as other code depends on that ordering.
|
||||
my @order = grep { !$seen{$_}++ } sort { lc $b cmp lc $a } keys %directives;
|
||||
|
||||
$directives = ' # ' . join ' & ' => @order;
|
||||
|
||||
for my $tag ('skip', @order) {
|
||||
next unless defined($directives{$tag}) && length($directives{$tag});
|
||||
$reason = $directives{$tag};
|
||||
last;
|
||||
}
|
||||
}
|
||||
|
||||
$ok .= " - $name" if defined $name && !($is_skip && !$name);
|
||||
|
||||
my @subtap;
|
||||
if ($f->{parent} && $f->{parent}->{buffered}) {
|
||||
$ok .= ' {';
|
||||
|
||||
# In a verbose harness we indent the extra since they will appear
|
||||
# inside the subtest braces. This helps readability. In a non-verbose
|
||||
# harness we do not do this because it is less readable.
|
||||
if ($ENV{HARNESS_IS_VERBOSE} || !$ENV{HARNESS_ACTIVE}) {
|
||||
$extra_indent = " ";
|
||||
$extra_space = ' ';
|
||||
}
|
||||
|
||||
# Render the sub-events, we use our own counter for these.
|
||||
my $count = 0;
|
||||
@subtap = map {
|
||||
my $f2 = $_;
|
||||
|
||||
# Bump the count for any event that should bump it.
|
||||
$count++ if $f2->{assert};
|
||||
|
||||
# This indents all output lines generated for the sub-events.
|
||||
# index 0 is the filehandle, index 1 is the message we want to indent.
|
||||
map { $_->[1] =~ s/^(.*\S.*)$/ $1/mg; $_ } $self->event_tap($f2, $count);
|
||||
} @{$f->{parent}->{children}};
|
||||
|
||||
push @subtap => [OUT_STD, "}\n"];
|
||||
}
|
||||
|
||||
if ($directives) {
|
||||
$directives = ' # TODO & SKIP' if $directives eq ' # TODO & skip';
|
||||
$ok .= $directives;
|
||||
$ok .= " $reason" if defined($reason);
|
||||
}
|
||||
|
||||
$extra_space = ' ' if $self->no_subtest_space;
|
||||
|
||||
my @out = ([OUT_STD, "$ok\n"]);
|
||||
push @out => map {[OUT_STD, "${extra_indent}#${extra_space}$_\n"]} @extra if @extra;
|
||||
push @out => @subtap;
|
||||
|
||||
return @out;
|
||||
}
|
||||
|
||||
sub debug_tap {
|
||||
my ($self, $f, $num) = @_;
|
||||
|
||||
# Figure out the debug info, this is typically the file name and line
|
||||
# number, but can also be a custom message. If no trace object is provided
|
||||
# then we have nothing useful to display.
|
||||
my $name = $f->{assert}->{details};
|
||||
my $trace = $f->{trace};
|
||||
|
||||
my $debug = "[No trace info available]";
|
||||
if ($trace->{details}) {
|
||||
$debug = $trace->{details};
|
||||
}
|
||||
elsif ($trace->{frame}) {
|
||||
my ($pkg, $file, $line) = @{$trace->{frame}};
|
||||
$debug = "at $file line $line." if $file && $line;
|
||||
}
|
||||
|
||||
my $amnesty = $f->{amnesty} && @{$f->{amnesty}}
|
||||
? ' (with amnesty)'
|
||||
: '';
|
||||
|
||||
# Create the initial diagnostics. If the test has a name we put the debug
|
||||
# info on a second line, this behavior is inherited from Test::Builder.
|
||||
my $msg = defined($name)
|
||||
? qq[# Failed test${amnesty} '$name'\n# $debug\n]
|
||||
: qq[# Failed test${amnesty} $debug\n];
|
||||
|
||||
my $IO = $f->{amnesty} && @{$f->{amnesty}} ? OUT_STD : OUT_ERR;
|
||||
|
||||
return [$IO, $msg];
|
||||
}
|
||||
|
||||
sub halt_tap {
|
||||
my ($self, $f) = @_;
|
||||
|
||||
return if $f->{trace}->{nested} && !$f->{trace}->{buffered};
|
||||
my $details = $f->{control}->{details};
|
||||
|
||||
return [OUT_STD, "Bail out!\n"] unless defined($details) && length($details);
|
||||
return [OUT_STD, "Bail out! $details\n"];
|
||||
}
|
||||
|
||||
sub info_tap {
|
||||
my ($self, $f) = @_;
|
||||
|
||||
return map {
|
||||
my $details = $_->{details};
|
||||
my $table = $_->{table};
|
||||
|
||||
my $IO = $_->{debug} && !($f->{amnesty} && @{$f->{amnesty}}) ? OUT_ERR : OUT_STD;
|
||||
|
||||
my $msg;
|
||||
if ($table && $self->supports_tables) {
|
||||
$msg = join "\n" => map { "# $_" } Term::Table->new(
|
||||
header => $table->{header},
|
||||
rows => $table->{rows},
|
||||
collapse => $table->{collapse},
|
||||
no_collapse => $table->{no_collapse},
|
||||
sanitize => 1,
|
||||
mark_tail => 1,
|
||||
max_width => $self->calc_table_size($f),
|
||||
)->render();
|
||||
}
|
||||
elsif (ref($details)) {
|
||||
require Data::Dumper;
|
||||
my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1);
|
||||
chomp($msg = $dumper->Dump);
|
||||
}
|
||||
else {
|
||||
chomp($msg = $details);
|
||||
$msg =~ s/^/# /;
|
||||
$msg =~ s/\n/\n# /g;
|
||||
}
|
||||
|
||||
[$IO, "$msg\n"];
|
||||
} @{$f->{info}};
|
||||
}
|
||||
|
||||
sub summary_tap {
|
||||
my ($self, $f, $num) = @_;
|
||||
|
||||
return if $f->{about}->{no_display};
|
||||
|
||||
my $summary = $f->{about}->{details} or return;
|
||||
chomp($summary);
|
||||
$summary =~ s/^/# /smg;
|
||||
|
||||
return [OUT_STD, "$summary\n"];
|
||||
}
|
||||
|
||||
sub calc_table_size {
|
||||
my $self = shift;
|
||||
my ($f) = @_;
|
||||
|
||||
my $term = Term::Table::Util::term_size();
|
||||
my $nesting = 2 + (($f->{trace}->{nested} || 0) * 4); # 4 spaces per level, also '# ' prefix
|
||||
my $total = $term - $nesting;
|
||||
|
||||
# Sane minimum width, any smaller and we are asking for pain
|
||||
return 50 if $total < 50;
|
||||
|
||||
return $total;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Formatter::TAP - Standard TAP formatter
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is what takes events and turns them into TAP.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Formatter::TAP;
|
||||
my $tap = Test2::Formatter::TAP->new();
|
||||
|
||||
# Switch to utf8
|
||||
$tap->encoding('utf8');
|
||||
|
||||
$tap->write($event, $number); # Output an event
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $bool = $tap->no_numbers
|
||||
|
||||
=item $tap->set_no_numbers($bool)
|
||||
|
||||
Use to turn numbers on and off.
|
||||
|
||||
=item $arrayref = $tap->handles
|
||||
|
||||
=item $tap->set_handles(\@handles);
|
||||
|
||||
Can be used to get/set the filehandles. Indexes are identified by the
|
||||
C<OUT_STD> and C<OUT_ERR> constants.
|
||||
|
||||
=item $encoding = $tap->encoding
|
||||
|
||||
=item $tap->encoding($encoding)
|
||||
|
||||
Get or set the encoding. By default no encoding is set, the original settings
|
||||
of STDOUT and STDERR are used.
|
||||
|
||||
This directly modifies the stored filehandles, it does not create new ones.
|
||||
|
||||
=item $tap->write($e, $num)
|
||||
|
||||
Write an event to the console.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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>
|
||||
|
||||
=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
909
t/lib/Test2/Hub.pm
Normal file
909
t/lib/Test2/Hub.pm
Normal file
|
|
@ -0,0 +1,909 @@
|
|||
package Test2::Hub;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
use Carp qw/carp croak confess/;
|
||||
use Test2::Util qw/get_tid gen_uid/;
|
||||
|
||||
use Scalar::Util qw/weaken/;
|
||||
use List::Util qw/first/;
|
||||
|
||||
use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
|
||||
use Test2::Util::HashBase qw{
|
||||
pid tid hid ipc
|
||||
nested buffered
|
||||
no_ending
|
||||
_filters
|
||||
_pre_filters
|
||||
_listeners
|
||||
_follow_ups
|
||||
_formatter
|
||||
_context_acquire
|
||||
_context_init
|
||||
_context_release
|
||||
|
||||
uuid
|
||||
active
|
||||
count
|
||||
failed
|
||||
ended
|
||||
bailed_out
|
||||
_passing
|
||||
_plan
|
||||
skip_reason
|
||||
};
|
||||
|
||||
my $UUID_VIA;
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
$self->{+PID} = $$;
|
||||
$self->{+TID} = get_tid();
|
||||
$self->{+HID} = gen_uid();
|
||||
|
||||
$UUID_VIA ||= Test2::API::_add_uuid_via_ref();
|
||||
$self->{+UUID} = ${$UUID_VIA}->('hub') if $$UUID_VIA;
|
||||
|
||||
$self->{+NESTED} = 0 unless defined $self->{+NESTED};
|
||||
$self->{+BUFFERED} = 0 unless defined $self->{+BUFFERED};
|
||||
|
||||
$self->{+COUNT} = 0;
|
||||
$self->{+FAILED} = 0;
|
||||
$self->{+_PASSING} = 1;
|
||||
|
||||
if (my $formatter = delete $self->{formatter}) {
|
||||
$self->format($formatter);
|
||||
}
|
||||
|
||||
if (my $ipc = $self->{+IPC}) {
|
||||
$ipc->add_hub($self->{+HID});
|
||||
}
|
||||
}
|
||||
|
||||
sub is_subtest { 0 }
|
||||
|
||||
sub _tb_reset {
|
||||
my $self = shift;
|
||||
|
||||
# Nothing to do
|
||||
return if $self->{+PID} == $$ && $self->{+TID} == get_tid();
|
||||
|
||||
$self->{+PID} = $$;
|
||||
$self->{+TID} = get_tid();
|
||||
$self->{+HID} = gen_uid();
|
||||
|
||||
if (my $ipc = $self->{+IPC}) {
|
||||
$ipc->add_hub($self->{+HID});
|
||||
}
|
||||
}
|
||||
|
||||
sub reset_state {
|
||||
my $self = shift;
|
||||
|
||||
$self->{+COUNT} = 0;
|
||||
$self->{+FAILED} = 0;
|
||||
$self->{+_PASSING} = 1;
|
||||
|
||||
delete $self->{+_PLAN};
|
||||
delete $self->{+ENDED};
|
||||
delete $self->{+BAILED_OUT};
|
||||
delete $self->{+SKIP_REASON};
|
||||
}
|
||||
|
||||
sub inherit {
|
||||
my $self = shift;
|
||||
my ($from, %params) = @_;
|
||||
|
||||
$self->{+NESTED} ||= 0;
|
||||
|
||||
$self->{+_FORMATTER} = $from->{+_FORMATTER}
|
||||
unless $self->{+_FORMATTER} || exists($params{formatter});
|
||||
|
||||
if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) {
|
||||
my $ipc = $from->{+IPC};
|
||||
$self->{+IPC} = $ipc;
|
||||
$ipc->add_hub($self->{+HID});
|
||||
}
|
||||
|
||||
if (my $ls = $from->{+_LISTENERS}) {
|
||||
push @{$self->{+_LISTENERS}} => grep { $_->{inherit} } @$ls;
|
||||
}
|
||||
|
||||
if (my $pfs = $from->{+_PRE_FILTERS}) {
|
||||
push @{$self->{+_PRE_FILTERS}} => grep { $_->{inherit} } @$pfs;
|
||||
}
|
||||
|
||||
if (my $fs = $from->{+_FILTERS}) {
|
||||
push @{$self->{+_FILTERS}} => grep { $_->{inherit} } @$fs;
|
||||
}
|
||||
}
|
||||
|
||||
sub format {
|
||||
my $self = shift;
|
||||
|
||||
my $old = $self->{+_FORMATTER};
|
||||
($self->{+_FORMATTER}) = @_ if @_;
|
||||
|
||||
return $old;
|
||||
}
|
||||
|
||||
sub is_local {
|
||||
my $self = shift;
|
||||
return $$ == $self->{+PID}
|
||||
&& get_tid() == $self->{+TID};
|
||||
}
|
||||
|
||||
sub listen {
|
||||
my $self = shift;
|
||||
my ($sub, %params) = @_;
|
||||
|
||||
carp "Useless addition of a listener in a child process or thread!"
|
||||
if $$ != $self->{+PID} || get_tid() != $self->{+TID};
|
||||
|
||||
croak "listen only takes coderefs for arguments, got '$sub'"
|
||||
unless ref $sub && ref $sub eq 'CODE';
|
||||
|
||||
push @{$self->{+_LISTENERS}} => { %params, code => $sub };
|
||||
|
||||
$sub; # Intentional return.
|
||||
}
|
||||
|
||||
sub unlisten {
|
||||
my $self = shift;
|
||||
|
||||
carp "Useless removal of a listener in a child process or thread!"
|
||||
if $$ != $self->{+PID} || get_tid() != $self->{+TID};
|
||||
|
||||
my %subs = map {$_ => $_} @_;
|
||||
|
||||
@{$self->{+_LISTENERS}} = grep { !$subs{$_->{code}} } @{$self->{+_LISTENERS}};
|
||||
}
|
||||
|
||||
sub filter {
|
||||
my $self = shift;
|
||||
my ($sub, %params) = @_;
|
||||
|
||||
carp "Useless addition of a filter in a child process or thread!"
|
||||
if $$ != $self->{+PID} || get_tid() != $self->{+TID};
|
||||
|
||||
croak "filter only takes coderefs for arguments, got '$sub'"
|
||||
unless ref $sub && ref $sub eq 'CODE';
|
||||
|
||||
push @{$self->{+_FILTERS}} => { %params, code => $sub };
|
||||
|
||||
$sub; # Intentional Return
|
||||
}
|
||||
|
||||
sub unfilter {
|
||||
my $self = shift;
|
||||
carp "Useless removal of a filter in a child process or thread!"
|
||||
if $$ != $self->{+PID} || get_tid() != $self->{+TID};
|
||||
my %subs = map {$_ => $_} @_;
|
||||
@{$self->{+_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_FILTERS}};
|
||||
}
|
||||
|
||||
sub pre_filter {
|
||||
my $self = shift;
|
||||
my ($sub, %params) = @_;
|
||||
|
||||
croak "pre_filter only takes coderefs for arguments, got '$sub'"
|
||||
unless ref $sub && ref $sub eq 'CODE';
|
||||
|
||||
push @{$self->{+_PRE_FILTERS}} => { %params, code => $sub };
|
||||
|
||||
$sub; # Intentional Return
|
||||
}
|
||||
|
||||
sub pre_unfilter {
|
||||
my $self = shift;
|
||||
my %subs = map {$_ => $_} @_;
|
||||
@{$self->{+_PRE_FILTERS}} = grep { !$subs{$_->{code}} } @{$self->{+_PRE_FILTERS}};
|
||||
}
|
||||
|
||||
sub follow_up {
|
||||
my $self = shift;
|
||||
my ($sub) = @_;
|
||||
|
||||
carp "Useless addition of a follow-up in a child process or thread!"
|
||||
if $$ != $self->{+PID} || get_tid() != $self->{+TID};
|
||||
|
||||
croak "follow_up only takes coderefs for arguments, got '$sub'"
|
||||
unless ref $sub && ref $sub eq 'CODE';
|
||||
|
||||
push @{$self->{+_FOLLOW_UPS}} => $sub;
|
||||
}
|
||||
|
||||
*add_context_aquire = \&add_context_acquire;
|
||||
sub add_context_acquire {
|
||||
my $self = shift;
|
||||
my ($sub) = @_;
|
||||
|
||||
croak "add_context_acquire only takes coderefs for arguments, got '$sub'"
|
||||
unless ref $sub && ref $sub eq 'CODE';
|
||||
|
||||
push @{$self->{+_CONTEXT_ACQUIRE}} => $sub;
|
||||
|
||||
$sub; # Intentional return.
|
||||
}
|
||||
|
||||
*remove_context_aquire = \&remove_context_acquire;
|
||||
sub remove_context_acquire {
|
||||
my $self = shift;
|
||||
my %subs = map {$_ => $_} @_;
|
||||
@{$self->{+_CONTEXT_ACQUIRE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_ACQUIRE}};
|
||||
}
|
||||
|
||||
sub add_context_init {
|
||||
my $self = shift;
|
||||
my ($sub) = @_;
|
||||
|
||||
croak "add_context_init only takes coderefs for arguments, got '$sub'"
|
||||
unless ref $sub && ref $sub eq 'CODE';
|
||||
|
||||
push @{$self->{+_CONTEXT_INIT}} => $sub;
|
||||
|
||||
$sub; # Intentional return.
|
||||
}
|
||||
|
||||
sub remove_context_init {
|
||||
my $self = shift;
|
||||
my %subs = map {$_ => $_} @_;
|
||||
@{$self->{+_CONTEXT_INIT}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_INIT}};
|
||||
}
|
||||
|
||||
sub add_context_release {
|
||||
my $self = shift;
|
||||
my ($sub) = @_;
|
||||
|
||||
croak "add_context_release only takes coderefs for arguments, got '$sub'"
|
||||
unless ref $sub && ref $sub eq 'CODE';
|
||||
|
||||
push @{$self->{+_CONTEXT_RELEASE}} => $sub;
|
||||
|
||||
$sub; # Intentional return.
|
||||
}
|
||||
|
||||
sub remove_context_release {
|
||||
my $self = shift;
|
||||
my %subs = map {$_ => $_} @_;
|
||||
@{$self->{+_CONTEXT_RELEASE}} = grep { !$subs{$_} == $_ } @{$self->{+_CONTEXT_RELEASE}};
|
||||
}
|
||||
|
||||
sub send {
|
||||
my $self = shift;
|
||||
my ($e) = @_;
|
||||
|
||||
$e->eid;
|
||||
|
||||
$e->add_hub(
|
||||
{
|
||||
details => ref($self),
|
||||
|
||||
buffered => $self->{+BUFFERED},
|
||||
hid => $self->{+HID},
|
||||
nested => $self->{+NESTED},
|
||||
pid => $self->{+PID},
|
||||
tid => $self->{+TID},
|
||||
uuid => $self->{+UUID},
|
||||
|
||||
ipc => $self->{+IPC} ? 1 : 0,
|
||||
}
|
||||
);
|
||||
|
||||
$e->set_uuid(${$UUID_VIA}->('event')) if $$UUID_VIA;
|
||||
|
||||
if ($self->{+_PRE_FILTERS}) {
|
||||
for (@{$self->{+_PRE_FILTERS}}) {
|
||||
$e = $_->{code}->($self, $e);
|
||||
return unless $e;
|
||||
}
|
||||
}
|
||||
|
||||
my $ipc = $self->{+IPC} || return $self->process($e);
|
||||
|
||||
if($e->global) {
|
||||
$ipc->send($self->{+HID}, $e, 'GLOBAL');
|
||||
return $self->process($e);
|
||||
}
|
||||
|
||||
return $ipc->send($self->{+HID}, $e)
|
||||
if $$ != $self->{+PID} || get_tid() != $self->{+TID};
|
||||
|
||||
$self->process($e);
|
||||
}
|
||||
|
||||
sub process {
|
||||
my $self = shift;
|
||||
my ($e) = @_;
|
||||
|
||||
if ($self->{+_FILTERS}) {
|
||||
for (@{$self->{+_FILTERS}}) {
|
||||
$e = $_->{code}->($self, $e);
|
||||
return unless $e;
|
||||
}
|
||||
}
|
||||
|
||||
# Optimize the most common case
|
||||
my $type = ref($e);
|
||||
if ($type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass})) {
|
||||
my $count = ++($self->{+COUNT});
|
||||
$self->{+_FORMATTER}->write($e, $count) if $self->{+_FORMATTER};
|
||||
|
||||
if ($self->{+_LISTENERS}) {
|
||||
$_->{code}->($self, $e, $count) for @{$self->{+_LISTENERS}};
|
||||
}
|
||||
|
||||
return $e;
|
||||
}
|
||||
|
||||
my $f = $e->facet_data;
|
||||
|
||||
my $fail = 0;
|
||||
$fail = 1 if $f->{assert} && !$f->{assert}->{pass};
|
||||
$fail = 1 if $f->{errors} && grep { $_->{fail} } @{$f->{errors}};
|
||||
$fail = 0 if $f->{amnesty};
|
||||
|
||||
$self->{+COUNT}++ if $f->{assert};
|
||||
$self->{+FAILED}++ if $fail && $f->{assert};
|
||||
$self->{+_PASSING} = 0 if $fail;
|
||||
|
||||
my $code = $f->{control}->{terminate};
|
||||
my $count = $self->{+COUNT};
|
||||
|
||||
if (my $plan = $f->{plan}) {
|
||||
if ($plan->{skip}) {
|
||||
$self->plan('SKIP');
|
||||
$self->set_skip_reason($plan->{details} || 1);
|
||||
$code ||= 0;
|
||||
}
|
||||
elsif ($plan->{none}) {
|
||||
$self->plan('NO PLAN');
|
||||
}
|
||||
else {
|
||||
$self->plan($plan->{count});
|
||||
}
|
||||
}
|
||||
|
||||
$e->callback($self) if $f->{control}->{has_callback};
|
||||
|
||||
$self->{+_FORMATTER}->write($e, $count, $f) if $self->{+_FORMATTER};
|
||||
|
||||
if ($self->{+_LISTENERS}) {
|
||||
$_->{code}->($self, $e, $count, $f) for @{$self->{+_LISTENERS}};
|
||||
}
|
||||
|
||||
if ($f->{control}->{halt}) {
|
||||
$code ||= 255;
|
||||
$self->set_bailed_out($e);
|
||||
}
|
||||
|
||||
if (defined $code) {
|
||||
$self->{+_FORMATTER}->terminate($e, $f) if $self->{+_FORMATTER};
|
||||
$self->terminate($code, $e, $f);
|
||||
}
|
||||
|
||||
return $e;
|
||||
}
|
||||
|
||||
sub terminate {
|
||||
my $self = shift;
|
||||
my ($code) = @_;
|
||||
exit($code);
|
||||
}
|
||||
|
||||
sub cull {
|
||||
my $self = shift;
|
||||
|
||||
my $ipc = $self->{+IPC} || return;
|
||||
return if $self->{+PID} != $$ || $self->{+TID} != get_tid();
|
||||
|
||||
# No need to do IPC checks on culled events
|
||||
$self->process($_) for $ipc->cull($self->{+HID});
|
||||
}
|
||||
|
||||
sub finalize {
|
||||
my $self = shift;
|
||||
my ($trace, $do_plan) = @_;
|
||||
|
||||
$self->cull();
|
||||
|
||||
my $plan = $self->{+_PLAN};
|
||||
my $count = $self->{+COUNT};
|
||||
my $failed = $self->{+FAILED};
|
||||
my $active = $self->{+ACTIVE};
|
||||
|
||||
# return if NOTHING was done.
|
||||
unless ($active || $do_plan || defined($plan) || $count || $failed) {
|
||||
$self->{+_FORMATTER}->finalize($plan, $count, $failed, 0, $self->is_subtest) if $self->{+_FORMATTER};
|
||||
return;
|
||||
}
|
||||
|
||||
unless ($self->{+ENDED}) {
|
||||
if ($self->{+_FOLLOW_UPS}) {
|
||||
$_->($trace, $self) for reverse @{$self->{+_FOLLOW_UPS}};
|
||||
}
|
||||
|
||||
# These need to be refreshed now
|
||||
$plan = $self->{+_PLAN};
|
||||
$count = $self->{+COUNT};
|
||||
$failed = $self->{+FAILED};
|
||||
|
||||
if (($plan && $plan eq 'NO PLAN') || ($do_plan && !$plan)) {
|
||||
$self->send(
|
||||
Test2::Event::Plan->new(
|
||||
trace => $trace,
|
||||
max => $count,
|
||||
)
|
||||
);
|
||||
}
|
||||
$plan = $self->{+_PLAN};
|
||||
}
|
||||
|
||||
my $frame = $trace->frame;
|
||||
if($self->{+ENDED}) {
|
||||
my (undef, $ffile, $fline) = @{$self->{+ENDED}};
|
||||
my (undef, $sfile, $sline) = @$frame;
|
||||
|
||||
die <<" EOT"
|
||||
Test already ended!
|
||||
First End: $ffile line $fline
|
||||
Second End: $sfile line $sline
|
||||
EOT
|
||||
}
|
||||
|
||||
$self->{+ENDED} = $frame;
|
||||
my $pass = $self->is_passing(); # Generate the final boolean.
|
||||
|
||||
$self->{+_FORMATTER}->finalize($plan, $count, $failed, $pass, $self->is_subtest) if $self->{+_FORMATTER};
|
||||
|
||||
return $pass;
|
||||
}
|
||||
|
||||
sub is_passing {
|
||||
my $self = shift;
|
||||
|
||||
($self->{+_PASSING}) = @_ if @_;
|
||||
|
||||
# If we already failed just return 0.
|
||||
my $pass = $self->{+_PASSING} or return 0;
|
||||
return $self->{+_PASSING} = 0 if $self->{+FAILED};
|
||||
|
||||
my $count = $self->{+COUNT};
|
||||
my $ended = $self->{+ENDED};
|
||||
my $plan = $self->{+_PLAN};
|
||||
|
||||
return $pass if !$count && $plan && $plan =~ m/^SKIP$/;
|
||||
|
||||
return $self->{+_PASSING} = 0
|
||||
if $ended && (!$count || !$plan);
|
||||
|
||||
return $pass unless $plan && $plan =~ m/^\d+$/;
|
||||
|
||||
if ($ended) {
|
||||
return $self->{+_PASSING} = 0 if $count != $plan;
|
||||
}
|
||||
else {
|
||||
return $self->{+_PASSING} = 0 if $count > $plan;
|
||||
}
|
||||
|
||||
return $pass;
|
||||
}
|
||||
|
||||
sub plan {
|
||||
my $self = shift;
|
||||
|
||||
return $self->{+_PLAN} unless @_;
|
||||
|
||||
my ($plan) = @_;
|
||||
|
||||
confess "You cannot unset the plan"
|
||||
unless defined $plan;
|
||||
|
||||
confess "You cannot change the plan"
|
||||
if $self->{+_PLAN} && $self->{+_PLAN} !~ m/^NO PLAN$/;
|
||||
|
||||
confess "'$plan' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'"
|
||||
unless $plan =~ m/^(\d+|NO PLAN|SKIP)$/;
|
||||
|
||||
$self->{+_PLAN} = $plan;
|
||||
}
|
||||
|
||||
sub check_plan {
|
||||
my $self = shift;
|
||||
|
||||
return undef unless $self->{+ENDED};
|
||||
my $plan = $self->{+_PLAN} || return undef;
|
||||
|
||||
return 1 if $plan !~ m/^\d+$/;
|
||||
|
||||
return 1 if $plan == $self->{+COUNT};
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
my $ipc = $self->{+IPC} || return;
|
||||
return unless $$ == $self->{+PID};
|
||||
return unless get_tid() == $self->{+TID};
|
||||
$ipc->drop_hub($self->{+HID});
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Hub - The conduit through which all events flow.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Hub;
|
||||
|
||||
my $hub = Test2::Hub->new();
|
||||
$hub->send(...);
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
The hub is the place where all events get processed and handed off to the
|
||||
formatter. The hub also tracks test state, and provides several hooks into the
|
||||
event pipeline.
|
||||
|
||||
=head1 COMMON TASKS
|
||||
|
||||
=head2 SENDING EVENTS
|
||||
|
||||
$hub->send($event)
|
||||
|
||||
The C<send()> method is used to issue an event to the hub. This method will
|
||||
handle thread/fork sync, filters, listeners, TAP output, etc.
|
||||
|
||||
=head2 ALTERING OR REMOVING EVENTS
|
||||
|
||||
You can use either C<filter()> or C<pre_filter()>, depending on your
|
||||
needs. Both have identical syntax, so only C<filter()> is shown here.
|
||||
|
||||
$hub->filter(sub {
|
||||
my ($hub, $event) = @_;
|
||||
|
||||
my $action = get_action($event);
|
||||
|
||||
# No action should be taken
|
||||
return $event if $action eq 'none';
|
||||
|
||||
# You want your filter to remove the event
|
||||
return undef if $action eq 'delete';
|
||||
|
||||
if ($action eq 'do_it') {
|
||||
my $new_event = copy_event($event);
|
||||
... Change your copy of the event ...
|
||||
return $new_event;
|
||||
}
|
||||
|
||||
die "Should not happen";
|
||||
});
|
||||
|
||||
By default, filters are not inherited by child hubs. That means if you start a
|
||||
subtest, the subtest will not inherit the filter. You can change this behavior
|
||||
with the C<inherit> parameter:
|
||||
|
||||
$hub->filter(sub { ... }, inherit => 1);
|
||||
|
||||
=head2 LISTENING FOR EVENTS
|
||||
|
||||
$hub->listen(sub {
|
||||
my ($hub, $event, $number) = @_;
|
||||
|
||||
... do whatever you want with the event ...
|
||||
|
||||
# return is ignored
|
||||
});
|
||||
|
||||
By default listeners are not inherited by child hubs. That means if you start a
|
||||
subtest, the subtest will not inherit the listener. You can change this behavior
|
||||
with the C<inherit> parameter:
|
||||
|
||||
$hub->listen(sub { ... }, inherit => 1);
|
||||
|
||||
|
||||
=head2 POST-TEST BEHAVIORS
|
||||
|
||||
$hub->follow_up(sub {
|
||||
my ($trace, $hub) = @_;
|
||||
|
||||
... do whatever you need to ...
|
||||
|
||||
# Return is ignored
|
||||
});
|
||||
|
||||
follow_up subs are called only once, either when done_testing is called, or in
|
||||
an END block.
|
||||
|
||||
=head2 SETTING THE FORMATTER
|
||||
|
||||
By default an instance of L<Test2::Formatter::TAP> is created and used.
|
||||
|
||||
my $old = $hub->format(My::Formatter->new);
|
||||
|
||||
Setting the formatter will REPLACE any existing formatter. You may set the
|
||||
formatter to undef to prevent output. The old formatter will be returned if one
|
||||
was already set. Only one formatter is allowed at a time.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $hub->send($event)
|
||||
|
||||
This is where all events enter the hub for processing.
|
||||
|
||||
=item $hub->process($event)
|
||||
|
||||
This is called by send after it does any IPC handling. You can use this to
|
||||
bypass the IPC process, but in general you should avoid using this.
|
||||
|
||||
=item $old = $hub->format($formatter)
|
||||
|
||||
Replace the existing formatter instance with a new one. Formatters must be
|
||||
objects that implement a C<< $formatter->write($event) >> method.
|
||||
|
||||
=item $sub = $hub->listen(sub { ... }, %optional_params)
|
||||
|
||||
You can use this to record all events AFTER they have been sent to the
|
||||
formatter. No changes made here will be meaningful, except possibly to other
|
||||
listeners.
|
||||
|
||||
$hub->listen(sub {
|
||||
my ($hub, $event, $number) = @_;
|
||||
|
||||
... do whatever you want with the event ...
|
||||
|
||||
# return is ignored
|
||||
});
|
||||
|
||||
Normally listeners are not inherited by child hubs such as subtests. You can
|
||||
add the C<< inherit => 1 >> parameter to allow a listener to be inherited.
|
||||
|
||||
=item $hub->unlisten($sub)
|
||||
|
||||
You can use this to remove a listen callback. You must pass in the coderef
|
||||
returned by the C<listen()> method.
|
||||
|
||||
=item $sub = $hub->filter(sub { ... }, %optional_params)
|
||||
|
||||
=item $sub = $hub->pre_filter(sub { ... }, %optional_params)
|
||||
|
||||
These can be used to add filters. Filters can modify, replace, or remove events
|
||||
before anything else can see them.
|
||||
|
||||
$hub->filter(
|
||||
sub {
|
||||
my ($hub, $event) = @_;
|
||||
|
||||
return $event; # No Changes
|
||||
return; # Remove the event
|
||||
|
||||
# Or you can modify an event before returning it.
|
||||
$event->modify;
|
||||
return $event;
|
||||
}
|
||||
);
|
||||
|
||||
If you are not using threads, forking, or IPC then the only difference between
|
||||
a C<filter> and a C<pre_filter> is that C<pre_filter> subs run first. When you
|
||||
are using threads, forking, or IPC, pre_filters happen to events before they
|
||||
are sent to their destination proc/thread, ordinary filters happen only in the
|
||||
destination hub/thread.
|
||||
|
||||
You cannot add a regular filter to a hub if the hub was created in another
|
||||
process or thread. You can always add a pre_filter.
|
||||
|
||||
=item $hub->unfilter($sub)
|
||||
|
||||
=item $hub->pre_unfilter($sub)
|
||||
|
||||
These can be used to remove filters and pre_filters. The C<$sub> argument is
|
||||
the reference returned by C<filter()> or C<pre_filter()>.
|
||||
|
||||
=item $hub->follow_op(sub { ... })
|
||||
|
||||
Use this to add behaviors that are called just before the hub is finalized. The
|
||||
only argument to your codeblock will be a L<Test2::EventFacet::Trace> instance.
|
||||
|
||||
$hub->follow_up(sub {
|
||||
my ($trace, $hub) = @_;
|
||||
|
||||
... do whatever you need to ...
|
||||
|
||||
# Return is ignored
|
||||
});
|
||||
|
||||
follow_up subs are called only once, ether when done_testing is called, or in
|
||||
an END block.
|
||||
|
||||
=item $sub = $hub->add_context_acquire(sub { ... });
|
||||
|
||||
Add a callback that will be called every time someone tries to acquire a
|
||||
context. It gets a single argument, a reference of the hash of parameters
|
||||
being used the construct the context. This is your chance to change the
|
||||
parameters by directly altering the hash.
|
||||
|
||||
test2_add_callback_context_acquire(sub {
|
||||
my $params = shift;
|
||||
$params->{level}++;
|
||||
});
|
||||
|
||||
This is a very scary API function. Please do not use this unless you need to.
|
||||
This is here for L<Test::Builder> and backwards compatibility. This has you
|
||||
directly manipulate the hash instead of returning a new one for performance
|
||||
reasons.
|
||||
|
||||
B<Note> Using this hook could have a huge performance impact.
|
||||
|
||||
The coderef you provide is returned and can be used to remove the hook later.
|
||||
|
||||
=item $hub->remove_context_acquire($sub);
|
||||
|
||||
This can be used to remove a context acquire hook.
|
||||
|
||||
=item $sub = $hub->add_context_init(sub { ... });
|
||||
|
||||
This allows you to add callbacks that will trigger every time a new context is
|
||||
created for the hub. The only argument to the sub will be the
|
||||
L<Test2::API::Context> instance that was created.
|
||||
|
||||
B<Note> Using this hook could have a huge performance impact.
|
||||
|
||||
The coderef you provide is returned and can be used to remove the hook later.
|
||||
|
||||
=item $hub->remove_context_init($sub);
|
||||
|
||||
This can be used to remove a context init hook.
|
||||
|
||||
=item $sub = $hub->add_context_release(sub { ... });
|
||||
|
||||
This allows you to add callbacks that will trigger every time a context for
|
||||
this hub is released. The only argument to the sub will be the
|
||||
L<Test2::API::Context> instance that was released. These will run in reverse
|
||||
order.
|
||||
|
||||
B<Note> Using this hook could have a huge performance impact.
|
||||
|
||||
The coderef you provide is returned and can be used to remove the hook later.
|
||||
|
||||
=item $hub->remove_context_release($sub);
|
||||
|
||||
This can be used to remove a context release hook.
|
||||
|
||||
=item $hub->cull()
|
||||
|
||||
Cull any IPC events (and process them).
|
||||
|
||||
=item $pid = $hub->pid()
|
||||
|
||||
Get the process id under which the hub was created.
|
||||
|
||||
=item $tid = $hub->tid()
|
||||
|
||||
Get the thread id under which the hub was created.
|
||||
|
||||
=item $hud = $hub->hid()
|
||||
|
||||
Get the identifier string of the hub.
|
||||
|
||||
=item $uuid = $hub->uuid()
|
||||
|
||||
If UUID tagging is enabled (see L<Test2::API>) then the hub will have a UUID.
|
||||
|
||||
=item $ipc = $hub->ipc()
|
||||
|
||||
Get the IPC object used by the hub.
|
||||
|
||||
=item $hub->set_no_ending($bool)
|
||||
|
||||
=item $bool = $hub->no_ending
|
||||
|
||||
This can be used to disable auto-ending behavior for a hub. The auto-ending
|
||||
behavior is triggered by an end block and is used to cull IPC events, and
|
||||
output the final plan if the plan was 'NO PLAN'.
|
||||
|
||||
=item $bool = $hub->active
|
||||
|
||||
=item $hub->set_active($bool)
|
||||
|
||||
These are used to get/set the 'active' attribute. When true this attribute will
|
||||
force C<< hub->finalize() >> to take action even if there is no plan, and no
|
||||
tests have been run. This flag is useful for plugins that add follow-up
|
||||
behaviors that need to run even if no events are seen.
|
||||
|
||||
=back
|
||||
|
||||
=head2 STATE METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $hub->reset_state()
|
||||
|
||||
Reset all state to the start. This sets the test count to 0, clears the plan,
|
||||
removes the failures, etc.
|
||||
|
||||
=item $num = $hub->count
|
||||
|
||||
Get the number of tests that have been run.
|
||||
|
||||
=item $num = $hub->failed
|
||||
|
||||
Get the number of failures (Not all failures come from a test fail, so this
|
||||
number can be larger than the count).
|
||||
|
||||
=item $bool = $hub->ended
|
||||
|
||||
True if the testing has ended. This MAY return the stack frame of the tool that
|
||||
ended the test, but that is not guaranteed.
|
||||
|
||||
=item $bool = $hub->is_passing
|
||||
|
||||
=item $hub->is_passing($bool)
|
||||
|
||||
Check if the overall test run is a failure. Can also be used to set the
|
||||
pass/fail status.
|
||||
|
||||
=item $hub->plan($plan)
|
||||
|
||||
=item $plan = $hub->plan
|
||||
|
||||
Get or set the plan. The plan must be an integer larger than 0, the string
|
||||
'NO PLAN', or the string 'SKIP'.
|
||||
|
||||
=item $bool = $hub->check_plan
|
||||
|
||||
Check if the plan and counts match, but only if the tests have ended. If tests
|
||||
have not ended this will return undef, otherwise it will be a true/false.
|
||||
|
||||
=back
|
||||
|
||||
=head1 THIRD PARTY META-DATA
|
||||
|
||||
This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
|
||||
way for you to attach meta-data to instances of this class. This is useful for
|
||||
tools, plugins, and other extensions.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
88
t/lib/Test2/Hub/Interceptor.pm
Normal file
88
t/lib/Test2/Hub/Interceptor.pm
Normal file
|
|
@ -0,0 +1,88 @@
|
|||
package Test2::Hub::Interceptor;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
use Test2::Hub::Interceptor::Terminator();
|
||||
|
||||
BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) }
|
||||
use Test2::Util::HashBase;
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
$self->SUPER::init();
|
||||
$self->{+NESTED} = 0;
|
||||
}
|
||||
|
||||
sub inherit {
|
||||
my $self = shift;
|
||||
my ($from, %params) = @_;
|
||||
|
||||
$self->{+NESTED} = 0;
|
||||
|
||||
if ($from->{+IPC} && !$self->{+IPC} && !exists($params{ipc})) {
|
||||
my $ipc = $from->{+IPC};
|
||||
$self->{+IPC} = $ipc;
|
||||
$ipc->add_hub($self->{+HID});
|
||||
}
|
||||
}
|
||||
|
||||
sub terminate {
|
||||
my $self = shift;
|
||||
my ($code) = @_;
|
||||
|
||||
eval {
|
||||
no warnings 'exiting';
|
||||
last T2_SUBTEST_WRAPPER;
|
||||
};
|
||||
my $err = $@;
|
||||
|
||||
# Fallback
|
||||
die bless(\$err, 'Test2::Hub::Interceptor::Terminator');
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Hub::Interceptor - Hub used by interceptor to grab results.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
51
t/lib/Test2/Hub/Interceptor/Terminator.pm
Normal file
51
t/lib/Test2/Hub/Interceptor/Terminator.pm
Normal file
|
|
@ -0,0 +1,51 @@
|
|||
package Test2::Hub::Interceptor::Terminator;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Hub::Interceptor::Terminator - Exception class used by
|
||||
Test2::Hub::Interceptor
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
136
t/lib/Test2/Hub/Subtest.pm
Normal file
136
t/lib/Test2/Hub/Subtest.pm
Normal file
|
|
@ -0,0 +1,136 @@
|
|||
package Test2::Hub::Subtest;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) }
|
||||
use Test2::Util::HashBase qw/nested exit_code manual_skip_all/;
|
||||
use Test2::Util qw/get_tid/;
|
||||
|
||||
sub is_subtest { 1 }
|
||||
|
||||
sub inherit {
|
||||
my $self = shift;
|
||||
my ($from) = @_;
|
||||
|
||||
$self->SUPER::inherit($from);
|
||||
|
||||
$self->{+NESTED} = $from->nested + 1;
|
||||
}
|
||||
|
||||
{
|
||||
# Legacy
|
||||
no warnings 'once';
|
||||
*ID = \&Test2::Hub::HID;
|
||||
*id = \&Test2::Hub::hid;
|
||||
*set_id = \&Test2::Hub::set_hid;
|
||||
}
|
||||
|
||||
sub send {
|
||||
my $self = shift;
|
||||
my ($e) = @_;
|
||||
|
||||
my $out = $self->SUPER::send($e);
|
||||
|
||||
return $out if $self->{+MANUAL_SKIP_ALL};
|
||||
|
||||
my $f = $e->facet_data;
|
||||
|
||||
my $plan = $f->{plan} or return $out;
|
||||
return $out unless $plan->{skip};
|
||||
|
||||
my $trace = $f->{trace} or die "Missing Trace!";
|
||||
return $out unless $trace->{pid} != $self->pid
|
||||
|| $trace->{tid} != $self->tid;
|
||||
|
||||
no warnings 'exiting';
|
||||
last T2_SUBTEST_WRAPPER;
|
||||
}
|
||||
|
||||
sub terminate {
|
||||
my $self = shift;
|
||||
my ($code, $e, $f) = @_;
|
||||
$self->set_exit_code($code);
|
||||
|
||||
return if $self->{+MANUAL_SKIP_ALL};
|
||||
|
||||
$f ||= $e->facet_data;
|
||||
|
||||
if(my $plan = $f->{plan}) {
|
||||
my $trace = $f->{trace} or die "Missing Trace!";
|
||||
return if $plan->{skip}
|
||||
&& ($trace->{pid} != $$ || $trace->{tid} != get_tid);
|
||||
}
|
||||
|
||||
no warnings 'exiting';
|
||||
last T2_SUBTEST_WRAPPER;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Hub::Subtest - Hub used by subtests
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Subtests make use of this hub to route events.
|
||||
|
||||
=head1 TOGGLES
|
||||
|
||||
=over 4
|
||||
|
||||
=item $bool = $hub->manual_skip_all
|
||||
|
||||
=item $hub->set_manual_skip_all($bool)
|
||||
|
||||
The default is false.
|
||||
|
||||
Normally a skip-all plan event will cause a subtest to stop executing. This is
|
||||
accomplished via C<last LABEL> to a label inside the subtest code. Most of the
|
||||
time this is perfectly fine. There are times however where this flow control
|
||||
causes bad things to happen.
|
||||
|
||||
This toggle lets you turn off the abort logic for the hub. When this is toggled
|
||||
to true B<you> are responsible for ensuring no additional events are generated.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
160
t/lib/Test2/IPC.pm
Normal file
160
t/lib/Test2/IPC.pm
Normal file
|
|
@ -0,0 +1,160 @@
|
|||
package Test2::IPC;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
use Test2::API::Instance;
|
||||
use Test2::Util qw/get_tid/;
|
||||
use Test2::API qw{
|
||||
test2_in_preload
|
||||
test2_init_done
|
||||
test2_ipc
|
||||
test2_has_ipc
|
||||
test2_ipc_enable_polling
|
||||
test2_pid
|
||||
test2_stack
|
||||
test2_tid
|
||||
context
|
||||
};
|
||||
|
||||
# Make sure stuff is finalized before anyone tried to fork or start a new thread.
|
||||
{
|
||||
# Avoid warnings if things are loaded at run-time
|
||||
no warnings 'void';
|
||||
INIT {
|
||||
use warnings 'void';
|
||||
context()->release() unless test2_in_preload();
|
||||
}
|
||||
}
|
||||
|
||||
use Carp qw/confess/;
|
||||
|
||||
our @EXPORT_OK = qw/cull/;
|
||||
BEGIN { require Exporter; our @ISA = qw(Exporter) }
|
||||
|
||||
sub unimport { Test2::API::test2_ipc_disable() }
|
||||
|
||||
sub import {
|
||||
goto &Exporter::import if test2_has_ipc || !test2_init_done();
|
||||
|
||||
confess "IPC is disabled" if Test2::API::test2_ipc_disabled();
|
||||
confess "Cannot add IPC in a child process (" . test2_pid() . " vs $$)" if test2_pid() != $$;
|
||||
confess "Cannot add IPC in a child thread (" . test2_tid() . " vs " . get_tid() . ")" if test2_tid() != get_tid();
|
||||
|
||||
Test2::API::_set_ipc(_make_ipc());
|
||||
apply_ipc(test2_stack());
|
||||
|
||||
goto &Exporter::import;
|
||||
}
|
||||
|
||||
sub _make_ipc {
|
||||
# Find a driver
|
||||
my ($driver) = Test2::API::test2_ipc_drivers();
|
||||
unless ($driver) {
|
||||
require Test2::IPC::Driver::Files;
|
||||
$driver = 'Test2::IPC::Driver::Files';
|
||||
}
|
||||
|
||||
return $driver->new();
|
||||
}
|
||||
|
||||
sub apply_ipc {
|
||||
my $stack = shift;
|
||||
|
||||
my ($root) = @$stack;
|
||||
|
||||
return unless $root;
|
||||
|
||||
confess "Cannot add IPC in a child process" if $root->pid != $$;
|
||||
confess "Cannot add IPC in a child thread" if $root->tid != get_tid();
|
||||
|
||||
my $ipc = $root->ipc || test2_ipc() || _make_ipc();
|
||||
|
||||
# Add the IPC to all hubs
|
||||
for my $hub (@$stack) {
|
||||
my $has = $hub->ipc;
|
||||
confess "IPC Mismatch!" if $has && $has != $ipc;
|
||||
next if $has;
|
||||
$hub->set_ipc($ipc);
|
||||
$ipc->add_hub($hub->hid);
|
||||
}
|
||||
|
||||
test2_ipc_enable_polling();
|
||||
|
||||
return $ipc;
|
||||
}
|
||||
|
||||
sub cull {
|
||||
my $ctx = context();
|
||||
$ctx->hub->cull;
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::IPC - Turn on IPC for threading or forking support.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
You should C<use Test2::IPC;> as early as possible in your test file. If you
|
||||
import this module after API initialization it will attempt to retrofit IPC
|
||||
onto the existing hubs.
|
||||
|
||||
=head2 DISABLING IT
|
||||
|
||||
You can use C<no Test2::IPC;> to disable IPC for good. You can also use the
|
||||
T2_NO_IPC env var.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All exports are optional.
|
||||
|
||||
=over 4
|
||||
|
||||
=item cull()
|
||||
|
||||
Cull allows you to collect results from other processes or threads on demand.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
287
t/lib/Test2/IPC/Driver.pm
Normal file
287
t/lib/Test2/IPC/Driver.pm
Normal file
|
|
@ -0,0 +1,287 @@
|
|||
package Test2::IPC::Driver;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
use Carp qw/confess/;
|
||||
use Test2::Util::HashBase qw{no_fatal no_bail};
|
||||
|
||||
use Test2::API qw/test2_ipc_add_driver/;
|
||||
|
||||
my %ADDED;
|
||||
sub import {
|
||||
my $class = shift;
|
||||
return if $class eq __PACKAGE__;
|
||||
return if $ADDED{$class}++;
|
||||
test2_ipc_add_driver($class);
|
||||
}
|
||||
|
||||
sub pending { -1 }
|
||||
sub set_pending { -1 }
|
||||
|
||||
for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) {
|
||||
no strict 'refs';
|
||||
*$meth = sub {
|
||||
my $thing = shift;
|
||||
confess "'$thing' did not define the required method '$meth'."
|
||||
};
|
||||
}
|
||||
|
||||
# Print the error and call exit. We are not using 'die' cause this is a
|
||||
# catastrophic error that should never be caught. If we get here it
|
||||
# means some serious shit has happened in a child process, the only way
|
||||
# to inform the parent may be to exit false.
|
||||
|
||||
sub abort {
|
||||
my $self = shift;
|
||||
chomp(my ($msg) = @_);
|
||||
|
||||
$self->driver_abort($msg) if $self->can('driver_abort');
|
||||
|
||||
print STDERR "IPC Fatal Error: $msg\n";
|
||||
print STDOUT "Bail out! IPC Fatal Error: $msg\n" unless $self->no_bail;
|
||||
|
||||
CORE::exit(255) unless $self->no_fatal;
|
||||
}
|
||||
|
||||
sub abort_trace {
|
||||
my $self = shift;
|
||||
my ($msg) = @_;
|
||||
# Older versions of Carp do not export longmess() function, so it needs to be called with package name
|
||||
$self->abort(Carp::longmess($msg));
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::IPC::Driver - Base class for Test2 IPC drivers.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package Test2::IPC::Driver::MyDriver;
|
||||
|
||||
use base 'Test2::IPC::Driver';
|
||||
|
||||
...
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $self->abort($msg)
|
||||
|
||||
If an IPC encounters a fatal error it should use this. This will print the
|
||||
message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will
|
||||
forcefully exit 255. IPC errors may occur in threads or processes other than
|
||||
the main one, this method provides the best chance of the harness noticing the
|
||||
error.
|
||||
|
||||
=item $self->abort_trace($msg)
|
||||
|
||||
This is the same as C<< $ipc->abort($msg) >> except that it uses
|
||||
C<Carp::longmess> to add a stack trace to the message.
|
||||
|
||||
=back
|
||||
|
||||
=head1 LOADING DRIVERS
|
||||
|
||||
Test2::IPC::Driver has an C<import()> method. All drivers inherit this import
|
||||
method. This import method registers the driver.
|
||||
|
||||
In most cases you just need to load the desired IPC driver to make it work. You
|
||||
should load this driver as early as possible. A warning will be issued if you
|
||||
load it too late for it to be effective.
|
||||
|
||||
use Test2::IPC::Driver::MyDriver;
|
||||
...
|
||||
|
||||
=head1 WRITING DRIVERS
|
||||
|
||||
package Test2::IPC::Driver::MyDriver;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::IPC::Driver';
|
||||
|
||||
sub is_viable {
|
||||
return 0 if $^O eq 'win32'; # Will not work on windows.
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub add_hub {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
... # Make it possible to contact the hub
|
||||
}
|
||||
|
||||
sub drop_hub {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
... # Nothing should try to reach the hub anymore.
|
||||
}
|
||||
|
||||
sub send {
|
||||
my $self = shift;
|
||||
my ($hid, $e, $global) = @_;
|
||||
|
||||
... # Send the event to the proper hub.
|
||||
|
||||
# This may notify other procs/threads that there is a pending event.
|
||||
Test2::API::test2_ipc_set_pending($uniq_val);
|
||||
}
|
||||
|
||||
sub cull {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
my @events = ...; # Here is where you get the events for the hub
|
||||
|
||||
return @events;
|
||||
}
|
||||
|
||||
sub waiting {
|
||||
my $self = shift;
|
||||
|
||||
... # Notify all listening procs and threads that the main
|
||||
... # process/thread is waiting for them to finish.
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head2 METHODS SUBCLASSES MUST IMPLEMENT
|
||||
|
||||
=over 4
|
||||
|
||||
=item $ipc->is_viable
|
||||
|
||||
This should return true if the driver works in the current environment. This
|
||||
should return false if it does not. This is a CLASS method.
|
||||
|
||||
=item $ipc->add_hub($hid)
|
||||
|
||||
This is used to alert the driver that a new hub is expecting events. The driver
|
||||
should keep track of the process and thread ids, the hub should only be dropped
|
||||
by the proc+thread that started it.
|
||||
|
||||
sub add_hub {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
... # Make it possible to contact the hub
|
||||
}
|
||||
|
||||
=item $ipc->drop_hub($hid)
|
||||
|
||||
This is used to alert the driver that a hub is no longer accepting events. The
|
||||
driver should keep track of the process and thread ids, the hub should only be
|
||||
dropped by the proc+thread that started it (This is the drivers responsibility
|
||||
to enforce).
|
||||
|
||||
sub drop_hub {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
... # Nothing should try to reach the hub anymore.
|
||||
}
|
||||
|
||||
=item $ipc->send($hid, $event);
|
||||
|
||||
=item $ipc->send($hid, $event, $global);
|
||||
|
||||
Used to send events from the current process/thread to the specified hub in its
|
||||
process+thread.
|
||||
|
||||
sub send {
|
||||
my $self = shift;
|
||||
my ($hid, $e) = @_;
|
||||
|
||||
... # Send the event to the proper hub.
|
||||
|
||||
# This may notify other procs/threads that there is a pending event.
|
||||
Test2::API::test2_ipc_set_pending($uniq_val);
|
||||
}
|
||||
|
||||
If C<$global> is true then the driver should send the event to all hubs in all
|
||||
processes and threads.
|
||||
|
||||
=item @events = $ipc->cull($hid)
|
||||
|
||||
Used to collect events that have been sent to the specified hub.
|
||||
|
||||
sub cull {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
my @events = ...; # Here is where you get the events for the hub
|
||||
|
||||
return @events;
|
||||
}
|
||||
|
||||
=item $ipc->waiting()
|
||||
|
||||
This is called in the parent process when it is complete and waiting for all
|
||||
child processes and threads to complete.
|
||||
|
||||
sub waiting {
|
||||
my $self = shift;
|
||||
|
||||
... # Notify all listening procs and threads that the main
|
||||
... # process/thread is waiting for them to finish.
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE
|
||||
|
||||
=over 4
|
||||
|
||||
=item $ipc->driver_abort($msg)
|
||||
|
||||
This is a hook called by C<< Test2::IPC::Driver->abort() >>. This is your
|
||||
chance to cleanup when an abort happens. You cannot prevent the abort, but you
|
||||
can gracefully except it.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
503
t/lib/Test2/IPC/Driver/Files.pm
Normal file
503
t/lib/Test2/IPC/Driver/Files.pm
Normal file
|
|
@ -0,0 +1,503 @@
|
|||
package Test2::IPC::Driver::Files;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) }
|
||||
|
||||
use Test2::Util::HashBase qw{tempdir event_ids read_ids timeouts tid pid globals};
|
||||
|
||||
use Scalar::Util qw/blessed/;
|
||||
use File::Temp();
|
||||
use Storable();
|
||||
use File::Spec();
|
||||
use POSIX();
|
||||
|
||||
use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator do_rename do_unlink try_sig_mask/;
|
||||
use Test2::API qw/test2_ipc_set_pending/;
|
||||
|
||||
sub is_viable { 1 }
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
my $tmpdir = File::Temp::tempdir(
|
||||
$ENV{T2_TEMPDIR_TEMPLATE} || "test2" . ipc_separator . $$ . ipc_separator . "XXXXXX",
|
||||
CLEANUP => 0,
|
||||
TMPDIR => 1,
|
||||
);
|
||||
|
||||
$self->abort_trace("Could not get a temp dir") unless $tmpdir;
|
||||
|
||||
$self->{+TEMPDIR} = File::Spec->canonpath($tmpdir);
|
||||
|
||||
print STDERR "\nIPC Temp Dir: $tmpdir\n\n"
|
||||
if $ENV{T2_KEEP_TEMPDIR};
|
||||
|
||||
$self->{+EVENT_IDS} = {};
|
||||
$self->{+READ_IDS} = {};
|
||||
$self->{+TIMEOUTS} = {};
|
||||
|
||||
$self->{+TID} = get_tid();
|
||||
$self->{+PID} = $$;
|
||||
|
||||
$self->{+GLOBALS} = {};
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub hub_file {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
my $tdir = $self->{+TEMPDIR};
|
||||
return File::Spec->catfile($tdir, "HUB" . ipc_separator . $hid);
|
||||
}
|
||||
|
||||
sub event_file {
|
||||
my $self = shift;
|
||||
my ($hid, $e) = @_;
|
||||
|
||||
my $tempdir = $self->{+TEMPDIR};
|
||||
my $type = blessed($e) or $self->abort("'$e' is not a blessed object!");
|
||||
|
||||
$self->abort("'$e' is not an event object!")
|
||||
unless $type->isa('Test2::Event');
|
||||
|
||||
my $tid = get_tid();
|
||||
my $eid = $self->{+EVENT_IDS}->{$hid}->{$$}->{$tid} += 1;
|
||||
|
||||
my @type = split '::', $type;
|
||||
my $name = join(ipc_separator, $hid, $$, $tid, $eid, @type);
|
||||
|
||||
return File::Spec->catfile($tempdir, $name);
|
||||
}
|
||||
|
||||
sub add_hub {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
my $hfile = $self->hub_file($hid);
|
||||
|
||||
$self->abort_trace("File for hub '$hid' already exists")
|
||||
if -e $hfile;
|
||||
|
||||
open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!");
|
||||
print $fh "$$\n" . get_tid() . "\n";
|
||||
close($fh);
|
||||
}
|
||||
|
||||
sub drop_hub {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
my $tdir = $self->{+TEMPDIR};
|
||||
my $hfile = $self->hub_file($hid);
|
||||
|
||||
$self->abort_trace("File for hub '$hid' does not exist")
|
||||
unless -e $hfile;
|
||||
|
||||
open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!");
|
||||
my ($pid, $tid) = <$fh>;
|
||||
close($fh);
|
||||
|
||||
$self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$")
|
||||
unless $pid == $$;
|
||||
|
||||
$self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid())
|
||||
unless get_tid() == $tid;
|
||||
|
||||
if ($ENV{T2_KEEP_TEMPDIR}) {
|
||||
my ($ok, $err) = do_rename($hfile, File::Spec->canonpath("$hfile.complete"));
|
||||
$self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete': $err") unless $ok
|
||||
}
|
||||
else {
|
||||
my ($ok, $err) = do_unlink($hfile);
|
||||
$self->abort_trace("Could not remove file for hub '$hid': $err") unless $ok
|
||||
}
|
||||
|
||||
opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!");
|
||||
|
||||
my %bad;
|
||||
for my $file (readdir($dh)) {
|
||||
next if $file =~ m{\.complete$};
|
||||
next unless $file =~ m{^$hid};
|
||||
|
||||
eval { $bad{$file} = $self->read_event_file(File::Spec->catfile($tdir, $file)); 1 } or $bad{$file} = $@ || "Unknown error reading file";
|
||||
}
|
||||
closedir($dh);
|
||||
|
||||
return unless keys %bad;
|
||||
|
||||
my $data;
|
||||
my $ok = eval {
|
||||
require JSON::PP;
|
||||
local *UNIVERSAL::TO_JSON = sub { +{ %{$_[0]} } };
|
||||
my $json = JSON::PP->new->ascii->pretty->canonical->allow_unknown->allow_blessed->convert_blessed;
|
||||
$data = $json->encode(\%bad);
|
||||
1;
|
||||
};
|
||||
$ok ||= eval {
|
||||
require Data::Dumper;
|
||||
local $Data::Dumper::Sortkeys = 1;
|
||||
$data = Data::Dumper::Dumper(\%bad);
|
||||
1;
|
||||
};
|
||||
|
||||
$data = "Could not dump data... sorry." unless defined $data;
|
||||
|
||||
$self->abort_trace("Not all files from hub '$hid' have been collected!\nHere is the leftover data:\n========================\n$data\n===================\n");
|
||||
}
|
||||
|
||||
sub send {
|
||||
my $self = shift;
|
||||
my ($hid, $e, $global) = @_;
|
||||
|
||||
my $tempdir = $self->{+TEMPDIR};
|
||||
my $hfile = $self->hub_file($hid);
|
||||
my $dest = $global ? 'GLOBAL' : $hid;
|
||||
|
||||
$self->abort(<<" EOT") unless $global || -f $hfile;
|
||||
hub '$hid' is not available, failed to send event!
|
||||
|
||||
There was an attempt to send an event to a hub in a parent process or thread,
|
||||
but that hub appears to be gone. This can happen if you fork, or start a new
|
||||
thread from inside subtest, and the parent finishes the subtest before the
|
||||
child returns.
|
||||
|
||||
This can also happen if the parent process is done testing before the child
|
||||
finishes. Test2 normally waits automatically in the root process, but will not
|
||||
do so if Test::Builder is loaded for legacy reasons.
|
||||
EOT
|
||||
|
||||
my $file = $self->event_file($dest, $e);
|
||||
my $ready = File::Spec->canonpath("$file.ready");
|
||||
|
||||
if ($global) {
|
||||
my $name = $ready;
|
||||
$name =~ s{^.*(GLOBAL)}{GLOBAL};
|
||||
$self->{+GLOBALS}->{$hid}->{$name}++;
|
||||
}
|
||||
|
||||
# Write and rename the file.
|
||||
my ($ren_ok, $ren_err);
|
||||
my ($ok, $err) = try_sig_mask {
|
||||
Storable::store($e, $file);
|
||||
($ren_ok, $ren_err) = do_rename("$file", $ready);
|
||||
};
|
||||
|
||||
if ($ok) {
|
||||
$self->abort("Could not rename file '$file' -> '$ready': $ren_err") unless $ren_ok;
|
||||
test2_ipc_set_pending($file);
|
||||
}
|
||||
else {
|
||||
my $src_file = __FILE__;
|
||||
$err =~ s{ at \Q$src_file\E.*$}{};
|
||||
chomp($err);
|
||||
my $tid = get_tid();
|
||||
my $trace = $e->trace->debug;
|
||||
my $type = blessed($e);
|
||||
|
||||
$self->abort(<<" EOT");
|
||||
|
||||
*******************************************************************************
|
||||
There was an error writing an event:
|
||||
Destination: $dest
|
||||
Origin PID: $$
|
||||
Origin TID: $tid
|
||||
Event Type: $type
|
||||
Event Trace: $trace
|
||||
File Name: $file
|
||||
Ready Name: $ready
|
||||
Error: $err
|
||||
*******************************************************************************
|
||||
|
||||
EOT
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub driver_abort {
|
||||
my $self = shift;
|
||||
my ($msg) = @_;
|
||||
|
||||
local ($@, $!, $?, $^E);
|
||||
eval {
|
||||
my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
|
||||
open(my $fh, '>>', $abort) or die "Could not open abort file: $!";
|
||||
print $fh $msg, "\n";
|
||||
close($fh) or die "Could not close abort file: $!";
|
||||
1;
|
||||
} or warn $@;
|
||||
}
|
||||
|
||||
sub cull {
|
||||
my $self = shift;
|
||||
my ($hid) = @_;
|
||||
|
||||
my $tempdir = $self->{+TEMPDIR};
|
||||
|
||||
opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!");
|
||||
|
||||
my $read = $self->{+READ_IDS};
|
||||
my $timeouts = $self->{+TIMEOUTS};
|
||||
|
||||
my @out;
|
||||
for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) {
|
||||
unless ($info->{global}) {
|
||||
my $next = $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} ||= 1;
|
||||
|
||||
$timeouts->{$info->{file}} ||= time;
|
||||
|
||||
if ($next != $info->{eid}) {
|
||||
# Wait up to N seconds for missing events
|
||||
next unless 5 < time - $timeouts->{$info->{file}};
|
||||
$self->abort("Missing event HID: $info->{hid}, PID: $info->{pid}, TID: $info->{tid}, EID: $info->{eid}.");
|
||||
}
|
||||
|
||||
$self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} = $info->{eid} + 1;
|
||||
}
|
||||
|
||||
my $full = $info->{full_path};
|
||||
my $obj = $self->read_event_file($full);
|
||||
push @out => $obj;
|
||||
|
||||
# Do not remove global events
|
||||
next if $info->{global};
|
||||
|
||||
if ($ENV{T2_KEEP_TEMPDIR}) {
|
||||
my $complete = File::Spec->canonpath("$full.complete");
|
||||
my ($ok, $err) = do_rename($full, $complete);
|
||||
$self->abort("Could not rename IPC file '$full', '$complete': $err") unless $ok;
|
||||
}
|
||||
else {
|
||||
my ($ok, $err) = do_unlink("$full");
|
||||
$self->abort("Could not unlink IPC file '$full': $err") unless $ok;
|
||||
}
|
||||
}
|
||||
|
||||
closedir($dh);
|
||||
return @out;
|
||||
}
|
||||
|
||||
sub parse_event_filename {
|
||||
my $self = shift;
|
||||
my ($file) = @_;
|
||||
|
||||
# The || is to force 0 in false
|
||||
my $complete = substr($file, -9, 9) eq '.complete' || 0 and substr($file, -9, 9, "");
|
||||
my $ready = substr($file, -6, 6) eq '.ready' || 0 and substr($file, -6, 6, "");
|
||||
|
||||
my @parts = split ipc_separator, $file;
|
||||
my ($global, $hid) = $parts[0] eq 'GLOBAL' ? (1, shift @parts) : (0, join ipc_separator, splice(@parts, 0, 4));
|
||||
my ($pid, $tid, $eid) = splice(@parts, 0, 3);
|
||||
my $type = join '::' => @parts;
|
||||
|
||||
return {
|
||||
file => $file,
|
||||
ready => $ready,
|
||||
complete => $complete,
|
||||
global => $global,
|
||||
type => $type,
|
||||
hid => $hid,
|
||||
pid => $pid,
|
||||
tid => $tid,
|
||||
eid => $eid,
|
||||
};
|
||||
}
|
||||
|
||||
sub should_read_event {
|
||||
my $self = shift;
|
||||
my ($hid, $file) = @_;
|
||||
|
||||
return if substr($file, 0, 1) eq '.';
|
||||
return if substr($file, 0, 3) eq 'HUB';
|
||||
CORE::exit(255) if $file eq 'ABORT';
|
||||
|
||||
my $parsed = $self->parse_event_filename($file);
|
||||
|
||||
return if $parsed->{complete};
|
||||
return unless $parsed->{ready};
|
||||
return unless $parsed->{global} || $parsed->{hid} eq $hid;
|
||||
|
||||
return if $parsed->{global} && $self->{+GLOBALS}->{$hid}->{$file}++;
|
||||
|
||||
# Untaint the path.
|
||||
my $full = File::Spec->catfile($self->{+TEMPDIR}, $file);
|
||||
($full) = ($full =~ m/^(.*)$/gs) if ${^TAINT};
|
||||
|
||||
$parsed->{full_path} = $full;
|
||||
|
||||
return $parsed;
|
||||
}
|
||||
|
||||
sub cmp_events {
|
||||
# Globals first
|
||||
return -1 if $a->{global} && !$b->{global};
|
||||
return 1 if $b->{global} && !$a->{global};
|
||||
|
||||
return $a->{pid} <=> $b->{pid}
|
||||
|| $a->{tid} <=> $b->{tid}
|
||||
|| $a->{eid} <=> $b->{eid};
|
||||
}
|
||||
|
||||
sub read_event_file {
|
||||
my $self = shift;
|
||||
my ($file) = @_;
|
||||
|
||||
my $obj = Storable::retrieve($file);
|
||||
$self->abort("Got an unblessed object: '$obj'")
|
||||
unless blessed($obj);
|
||||
|
||||
unless ($obj->isa('Test2::Event')) {
|
||||
my $pkg = blessed($obj);
|
||||
my $mod_file = pkg_to_file($pkg);
|
||||
my ($ok, $err) = try { require $mod_file };
|
||||
|
||||
$self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err")
|
||||
unless $ok;
|
||||
|
||||
$self->abort("'$obj' is not a 'Test2::Event' object")
|
||||
unless $obj->isa('Test2::Event');
|
||||
}
|
||||
|
||||
return $obj;
|
||||
}
|
||||
|
||||
sub waiting {
|
||||
my $self = shift;
|
||||
require Test2::Event::Waiting;
|
||||
$self->send(
|
||||
GLOBAL => Test2::Event::Waiting->new(
|
||||
trace => Test2::EventFacet::Trace->new(frame => [caller()]),
|
||||
),
|
||||
'GLOBAL'
|
||||
);
|
||||
return;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
|
||||
return unless defined $self->pid;
|
||||
return unless defined $self->tid;
|
||||
|
||||
return unless $$ == $self->pid;
|
||||
return unless get_tid() == $self->tid;
|
||||
|
||||
my $tempdir = $self->{+TEMPDIR};
|
||||
|
||||
my $aborted = 0;
|
||||
my $abort_file = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
|
||||
if (-e $abort_file) {
|
||||
$aborted = 1;
|
||||
my ($ok, $err) = do_unlink($abort_file);
|
||||
warn $err unless $ok;
|
||||
}
|
||||
|
||||
opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)");
|
||||
while(my $file = readdir($dh)) {
|
||||
next if $file =~ m/^\.+$/;
|
||||
next if $file =~ m/\.complete$/;
|
||||
my $full = File::Spec->catfile($tempdir, $file);
|
||||
|
||||
my $sep = ipc_separator;
|
||||
if ($aborted || $file =~ m/^(GLOBAL|HUB$sep)/) {
|
||||
$full =~ m/^(.*)$/;
|
||||
$full = $1; # Untaint it
|
||||
next if $ENV{T2_KEEP_TEMPDIR};
|
||||
my ($ok, $err) = do_unlink($full);
|
||||
$self->abort("Could not unlink IPC file '$full': $err") unless $ok;
|
||||
next;
|
||||
}
|
||||
|
||||
$self->abort("Leftover files in the directory ($full)!\n");
|
||||
}
|
||||
closedir($dh);
|
||||
|
||||
if ($ENV{T2_KEEP_TEMPDIR}) {
|
||||
print STDERR "# Not removing temp dir: $tempdir\n";
|
||||
return;
|
||||
}
|
||||
|
||||
my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
|
||||
unlink($abort) if -e $abort;
|
||||
rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::IPC::Driver::Files - Temp dir + Files concurrency model.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the default, and fallback concurrency model for L<Test2>. This
|
||||
sends events between processes and threads using serialized files in a
|
||||
temporary directory. This is not particularly fast, but it works everywhere.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::IPC::Driver::Files;
|
||||
|
||||
# IPC is now enabled
|
||||
|
||||
=head1 ENVIRONMENT VARIABLES
|
||||
|
||||
=over 4
|
||||
|
||||
=item T2_KEEP_TEMPDIR=0
|
||||
|
||||
When true, the tempdir used by the IPC driver will not be deleted when the test
|
||||
is done.
|
||||
|
||||
=item T2_TEMPDIR_TEMPLATE='test2-XXXXXX'
|
||||
|
||||
This can be used to set the template for the IPC temp dir. The template should
|
||||
follow template specifications from L<File::Temp>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See L<Test2::IPC::Driver> for methods.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
435
t/lib/Test2/Tools/Tiny.pm
Normal file
435
t/lib/Test2/Tools/Tiny.pm
Normal file
|
|
@ -0,0 +1,435 @@
|
|||
package Test2::Tools::Tiny;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
BEGIN {
|
||||
if ($] lt "5.008") {
|
||||
require Test::Builder::IO::Scalar;
|
||||
}
|
||||
}
|
||||
|
||||
use Scalar::Util qw/blessed/;
|
||||
|
||||
use Test2::Util qw/try/;
|
||||
use Test2::API qw/context run_subtest test2_stack/;
|
||||
|
||||
use Test2::Hub::Interceptor();
|
||||
use Test2::Hub::Interceptor::Terminator();
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
BEGIN { require Exporter; our @ISA = qw(Exporter) }
|
||||
our @EXPORT = qw{
|
||||
ok is isnt like unlike is_deeply diag note skip_all todo plan done_testing
|
||||
warnings exception tests capture
|
||||
};
|
||||
|
||||
sub ok($;$@) {
|
||||
my ($bool, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
return $ctx->pass_and_release($name) if $bool;
|
||||
return $ctx->fail_and_release($name, @diag);
|
||||
}
|
||||
|
||||
sub is($$;$@) {
|
||||
my ($got, $want, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
my $bool;
|
||||
if (defined($got) && defined($want)) {
|
||||
$bool = "$got" eq "$want";
|
||||
}
|
||||
elsif (defined($got) xor defined($want)) {
|
||||
$bool = 0;
|
||||
}
|
||||
else { # Both are undef
|
||||
$bool = 1;
|
||||
}
|
||||
|
||||
return $ctx->pass_and_release($name) if $bool;
|
||||
|
||||
$got = '*NOT DEFINED*' unless defined $got;
|
||||
$want = '*NOT DEFINED*' unless defined $want;
|
||||
unshift @diag => (
|
||||
"GOT: $got",
|
||||
"EXPECTED: $want",
|
||||
);
|
||||
|
||||
return $ctx->fail_and_release($name, @diag);
|
||||
}
|
||||
|
||||
sub isnt($$;$@) {
|
||||
my ($got, $want, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
my $bool;
|
||||
if (defined($got) && defined($want)) {
|
||||
$bool = "$got" ne "$want";
|
||||
}
|
||||
elsif (defined($got) xor defined($want)) {
|
||||
$bool = 1;
|
||||
}
|
||||
else { # Both are undef
|
||||
$bool = 0;
|
||||
}
|
||||
|
||||
return $ctx->pass_and_release($name) if $bool;
|
||||
|
||||
unshift @diag => "Strings are the same (they should not be)"
|
||||
unless $bool;
|
||||
|
||||
return $ctx->fail_and_release($name, @diag);
|
||||
}
|
||||
|
||||
sub like($$;$@) {
|
||||
my ($thing, $pattern, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
my $bool;
|
||||
if (defined($thing)) {
|
||||
$bool = "$thing" =~ $pattern;
|
||||
unshift @diag => (
|
||||
"Value: $thing",
|
||||
"Does not match: $pattern"
|
||||
) unless $bool;
|
||||
}
|
||||
else {
|
||||
$bool = 0;
|
||||
unshift @diag => "Got an undefined value.";
|
||||
}
|
||||
|
||||
return $ctx->pass_and_release($name) if $bool;
|
||||
return $ctx->fail_and_release($name, @diag);
|
||||
}
|
||||
|
||||
sub unlike($$;$@) {
|
||||
my ($thing, $pattern, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
my $bool;
|
||||
if (defined($thing)) {
|
||||
$bool = "$thing" !~ $pattern;
|
||||
unshift @diag => (
|
||||
"Unexpected pattern match (it should not match)",
|
||||
"Value: $thing",
|
||||
"Matches: $pattern"
|
||||
) unless $bool;
|
||||
}
|
||||
else {
|
||||
$bool = 0;
|
||||
unshift @diag => "Got an undefined value.";
|
||||
}
|
||||
|
||||
return $ctx->pass_and_release($name) if $bool;
|
||||
return $ctx->fail_and_release($name, @diag);
|
||||
}
|
||||
|
||||
sub is_deeply($$;$@) {
|
||||
my ($got, $want, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
no warnings 'once';
|
||||
require Data::Dumper;
|
||||
|
||||
# Otherwise numbers might be unquoted
|
||||
local $Data::Dumper::Useperl = 1;
|
||||
|
||||
local $Data::Dumper::Sortkeys = 1;
|
||||
local $Data::Dumper::Deparse = 1;
|
||||
local $Data::Dumper::Freezer = 'XXX';
|
||||
local *UNIVERSAL::XXX = sub {
|
||||
my ($thing) = @_;
|
||||
if (ref($thing)) {
|
||||
$thing = {%$thing} if "$thing" =~ m/=HASH/;
|
||||
$thing = [@$thing] if "$thing" =~ m/=ARRAY/;
|
||||
$thing = \"$$thing" if "$thing" =~ m/=SCALAR/;
|
||||
}
|
||||
$_[0] = $thing;
|
||||
};
|
||||
|
||||
my $g = Data::Dumper::Dumper($got);
|
||||
my $w = Data::Dumper::Dumper($want);
|
||||
|
||||
my $bool = $g eq $w;
|
||||
|
||||
return $ctx->pass_and_release($name) if $bool;
|
||||
return $ctx->fail_and_release($name, $g, $w, @diag);
|
||||
}
|
||||
|
||||
sub diag {
|
||||
my $ctx = context();
|
||||
$ctx->diag(join '', @_);
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
sub note {
|
||||
my $ctx = context();
|
||||
$ctx->note(join '', @_);
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
sub skip_all {
|
||||
my ($reason) = @_;
|
||||
my $ctx = context();
|
||||
$ctx->plan(0, SKIP => $reason);
|
||||
$ctx->release if $ctx;
|
||||
}
|
||||
|
||||
sub todo {
|
||||
my ($reason, $sub) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
# This code is mostly copied from Test2::Todo in the Test2-Suite
|
||||
# distribution.
|
||||
my $hub = test2_stack->top;
|
||||
my $filter = $hub->pre_filter(
|
||||
sub {
|
||||
my ($active_hub, $event) = @_;
|
||||
if ($active_hub == $hub) {
|
||||
$event->set_todo($reason) if $event->can('set_todo');
|
||||
$event->add_amnesty({tag => 'TODO', details => $reason});
|
||||
}
|
||||
else {
|
||||
$event->add_amnesty({tag => 'TODO', details => $reason, inherited => 1});
|
||||
}
|
||||
return $event;
|
||||
},
|
||||
inherit => 1,
|
||||
todo => $reason,
|
||||
);
|
||||
$sub->();
|
||||
$hub->pre_unfilter($filter);
|
||||
|
||||
$ctx->release if $ctx;
|
||||
}
|
||||
|
||||
sub plan {
|
||||
my ($max) = @_;
|
||||
my $ctx = context();
|
||||
$ctx->plan($max);
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
sub done_testing {
|
||||
my $ctx = context();
|
||||
$ctx->done_testing;
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
sub warnings(&) {
|
||||
my $code = shift;
|
||||
my @warnings;
|
||||
local $SIG{__WARN__} = sub { push @warnings => @_ };
|
||||
$code->();
|
||||
return \@warnings;
|
||||
}
|
||||
|
||||
sub exception(&) {
|
||||
my $code = shift;
|
||||
local ($@, $!, $SIG{__DIE__});
|
||||
my $ok = eval { $code->(); 1 };
|
||||
my $error = $@ || 'SQUASHED ERROR';
|
||||
return $ok ? undef : $error;
|
||||
}
|
||||
|
||||
sub tests {
|
||||
my ($name, $code) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
my $be = caller->can('before_each');
|
||||
|
||||
$be->($name) if $be;
|
||||
|
||||
my $bool = run_subtest($name, $code, 1);
|
||||
|
||||
$ctx->release;
|
||||
|
||||
return $bool;
|
||||
}
|
||||
|
||||
sub capture(&) {
|
||||
my $code = shift;
|
||||
|
||||
my ($err, $out) = ("", "");
|
||||
|
||||
my $handles = test2_stack->top->format->handles;
|
||||
my ($ok, $e);
|
||||
{
|
||||
my ($out_fh, $err_fh);
|
||||
|
||||
($ok, $e) = try {
|
||||
# Scalar refs as filehandles were added in 5.8.
|
||||
if ($] ge "5.008") {
|
||||
open($out_fh, '>', \$out) or die "Failed to open a temporary STDOUT: $!";
|
||||
open($err_fh, '>', \$err) or die "Failed to open a temporary STDERR: $!";
|
||||
}
|
||||
# Emulate scalar ref filehandles with a tie.
|
||||
else {
|
||||
$out_fh = Test::Builder::IO::Scalar->new(\$out) or die "Failed to open a temporary STDOUT";
|
||||
$err_fh = Test::Builder::IO::Scalar->new(\$err) or die "Failed to open a temporary STDERR";
|
||||
}
|
||||
|
||||
test2_stack->top->format->set_handles([$out_fh, $err_fh, $out_fh]);
|
||||
|
||||
$code->();
|
||||
};
|
||||
}
|
||||
test2_stack->top->format->set_handles($handles);
|
||||
|
||||
die $e unless $ok;
|
||||
|
||||
$err =~ s/ $/_/mg;
|
||||
$out =~ s/ $/_/mg;
|
||||
|
||||
return {
|
||||
STDOUT => $out,
|
||||
STDERR => $err,
|
||||
};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Tiny - Tiny set of tools for unfortunate souls who cannot use
|
||||
L<Test2::Suite>.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
You should really look at L<Test2::Suite>. This package is some very basic
|
||||
essential tools implemented using L<Test2>. This exists only so that L<Test2>
|
||||
and other tools required by L<Test2::Suite> can be tested. This is the package
|
||||
L<Test2> uses to test itself.
|
||||
|
||||
=head1 USE Test2::Suite INSTEAD
|
||||
|
||||
Use L<Test2::Suite> if at all possible.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
=over 4
|
||||
|
||||
=item ok($bool, $name)
|
||||
|
||||
=item ok($bool, $name, @diag)
|
||||
|
||||
Run a simple assertion.
|
||||
|
||||
=item is($got, $want, $name)
|
||||
|
||||
=item is($got, $want, $name, @diag)
|
||||
|
||||
Assert that 2 strings are the same.
|
||||
|
||||
=item isnt($got, $do_not_want, $name)
|
||||
|
||||
=item isnt($got, $do_not_want, $name, @diag)
|
||||
|
||||
Assert that 2 strings are not the same.
|
||||
|
||||
=item like($got, $regex, $name)
|
||||
|
||||
=item like($got, $regex, $name, @diag)
|
||||
|
||||
Check that the input string matches the regex.
|
||||
|
||||
=item unlike($got, $regex, $name)
|
||||
|
||||
=item unlike($got, $regex, $name, @diag)
|
||||
|
||||
Check that the input string does not match the regex.
|
||||
|
||||
=item is_deeply($got, $want, $name)
|
||||
|
||||
=item is_deeply($got, $want, $name, @diag)
|
||||
|
||||
Check 2 data structures. Please note that this is a I<DUMB> implementation that
|
||||
compares the output of L<Data::Dumper> against both structures.
|
||||
|
||||
=item diag($msg)
|
||||
|
||||
Issue a diagnostics message to STDERR.
|
||||
|
||||
=item note($msg)
|
||||
|
||||
Issue a diagnostics message to STDOUT.
|
||||
|
||||
=item skip_all($reason)
|
||||
|
||||
Skip all tests.
|
||||
|
||||
=item todo $reason => sub { ... }
|
||||
|
||||
Run a block in TODO mode.
|
||||
|
||||
=item plan($count)
|
||||
|
||||
Set the plan.
|
||||
|
||||
=item done_testing()
|
||||
|
||||
Set the plan to the current test count.
|
||||
|
||||
=item $warnings = warnings { ... }
|
||||
|
||||
Capture an arrayref of warnings from the block.
|
||||
|
||||
=item $exception = exception { ... }
|
||||
|
||||
Capture an exception.
|
||||
|
||||
=item tests $name => sub { ... }
|
||||
|
||||
Run a subtest.
|
||||
|
||||
=item $output = capture { ... }
|
||||
|
||||
Capture STDOUT and STDERR output.
|
||||
|
||||
Result looks like this:
|
||||
|
||||
{
|
||||
STDOUT => "...",
|
||||
STDERR => "...",
|
||||
}
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
448
t/lib/Test2/Util.pm
Normal file
448
t/lib/Test2/Util.pm
Normal file
|
|
@ -0,0 +1,448 @@
|
|||
package Test2::Util;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
use POSIX();
|
||||
use Config qw/%Config/;
|
||||
use Carp qw/croak/;
|
||||
|
||||
BEGIN {
|
||||
local ($@, $!, $SIG{__DIE__});
|
||||
*HAVE_PERLIO = eval { require PerlIO; PerlIO->VERSION(1.02); } ? sub() { 1 } : sub() { 0 };
|
||||
}
|
||||
|
||||
our @EXPORT_OK = qw{
|
||||
try
|
||||
|
||||
pkg_to_file
|
||||
|
||||
get_tid USE_THREADS
|
||||
CAN_THREAD
|
||||
CAN_REALLY_FORK
|
||||
CAN_FORK
|
||||
|
||||
CAN_SIGSYS
|
||||
|
||||
IS_WIN32
|
||||
|
||||
ipc_separator
|
||||
|
||||
gen_uid
|
||||
|
||||
do_rename do_unlink
|
||||
|
||||
try_sig_mask
|
||||
|
||||
clone_io
|
||||
};
|
||||
BEGIN { require Exporter; our @ISA = qw(Exporter) }
|
||||
|
||||
BEGIN {
|
||||
*IS_WIN32 = ($^O eq 'MSWin32') ? sub() { 1 } : sub() { 0 };
|
||||
}
|
||||
|
||||
sub _can_thread {
|
||||
return 0 unless $] >= 5.008001;
|
||||
return 0 unless $Config{'useithreads'};
|
||||
|
||||
# Threads are broken on perl 5.10.0 built with gcc 4.8+
|
||||
if ($] == 5.010000 && $Config{'ccname'} eq 'gcc' && $Config{'gccversion'}) {
|
||||
my @parts = split /\./, $Config{'gccversion'};
|
||||
return 0 if $parts[0] > 4 || ($parts[0] == 4 && $parts[1] >= 8);
|
||||
}
|
||||
|
||||
# Change to a version check if this ever changes
|
||||
return 0 if $INC{'Devel/Cover.pm'};
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub _can_fork {
|
||||
return 1 if $Config{d_fork};
|
||||
return 0 unless IS_WIN32 || $^O eq 'NetWare';
|
||||
return 0 unless $Config{useithreads};
|
||||
return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/;
|
||||
|
||||
return _can_thread();
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
no warnings 'once';
|
||||
*CAN_THREAD = _can_thread() ? sub() { 1 } : sub() { 0 };
|
||||
}
|
||||
my $can_fork;
|
||||
sub CAN_FORK () {
|
||||
return $can_fork
|
||||
if defined $can_fork;
|
||||
$can_fork = !!_can_fork();
|
||||
no warnings 'redefine';
|
||||
*CAN_FORK = $can_fork ? sub() { 1 } : sub() { 0 };
|
||||
$can_fork;
|
||||
}
|
||||
my $can_really_fork;
|
||||
sub CAN_REALLY_FORK () {
|
||||
return $can_really_fork
|
||||
if defined $can_really_fork;
|
||||
$can_really_fork = !!$Config{d_fork};
|
||||
no warnings 'redefine';
|
||||
*CAN_REALLY_FORK = $can_really_fork ? sub() { 1 } : sub() { 0 };
|
||||
$can_really_fork;
|
||||
}
|
||||
|
||||
sub _manual_try(&;@) {
|
||||
my $code = shift;
|
||||
my $args = \@_;
|
||||
my $err;
|
||||
|
||||
my $die = delete $SIG{__DIE__};
|
||||
|
||||
eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n";
|
||||
|
||||
$die ? $SIG{__DIE__} = $die : delete $SIG{__DIE__};
|
||||
|
||||
return (!defined($err), $err);
|
||||
}
|
||||
|
||||
sub _local_try(&;@) {
|
||||
my $code = shift;
|
||||
my $args = \@_;
|
||||
my $err;
|
||||
|
||||
no warnings;
|
||||
local $SIG{__DIE__};
|
||||
eval { $code->(@$args); 1 } or $err = $@ || "Error was squashed!\n";
|
||||
|
||||
return (!defined($err), $err);
|
||||
}
|
||||
|
||||
# Older versions of perl have a nasty bug on win32 when localizing a variable
|
||||
# before forking or starting a new thread. So for those systems we use the
|
||||
# non-local form. When possible though we use the faster 'local' form.
|
||||
BEGIN {
|
||||
if (IS_WIN32 && $] < 5.020002) {
|
||||
*try = \&_manual_try;
|
||||
}
|
||||
else {
|
||||
*try = \&_local_try;
|
||||
}
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
if (CAN_THREAD) {
|
||||
if ($INC{'threads.pm'}) {
|
||||
# Threads are already loaded, so we do not need to check if they
|
||||
# are loaded each time
|
||||
*USE_THREADS = sub() { 1 };
|
||||
*get_tid = sub() { threads->tid() };
|
||||
}
|
||||
else {
|
||||
# :-( Need to check each time to see if they have been loaded.
|
||||
*USE_THREADS = sub() { $INC{'threads.pm'} ? 1 : 0 };
|
||||
*get_tid = sub() { $INC{'threads.pm'} ? threads->tid() : 0 };
|
||||
}
|
||||
}
|
||||
else {
|
||||
# No threads, not now, not ever!
|
||||
*USE_THREADS = sub() { 0 };
|
||||
*get_tid = sub() { 0 };
|
||||
}
|
||||
}
|
||||
|
||||
sub pkg_to_file {
|
||||
my $pkg = shift;
|
||||
my $file = $pkg;
|
||||
$file =~ s{(::|')}{/}g;
|
||||
$file .= '.pm';
|
||||
return $file;
|
||||
}
|
||||
|
||||
sub ipc_separator() { "~" }
|
||||
|
||||
my $UID = 1;
|
||||
sub gen_uid() { join ipc_separator() => ($$, get_tid(), time, $UID++) }
|
||||
|
||||
sub _check_for_sig_sys {
|
||||
my $sig_list = shift;
|
||||
return $sig_list =~ m/\bSYS\b/;
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
if (_check_for_sig_sys($Config{sig_name})) {
|
||||
*CAN_SIGSYS = sub() { 1 };
|
||||
}
|
||||
else {
|
||||
*CAN_SIGSYS = sub() { 0 };
|
||||
}
|
||||
}
|
||||
|
||||
my %PERLIO_SKIP = (
|
||||
unix => 1,
|
||||
via => 1,
|
||||
);
|
||||
|
||||
sub clone_io {
|
||||
my ($fh) = @_;
|
||||
my $fileno = eval { fileno($fh) };
|
||||
|
||||
return $fh if !defined($fileno) || !length($fileno) || $fileno < 0;
|
||||
|
||||
open(my $out, '>&' . $fileno) or die "Can't dup fileno $fileno: $!";
|
||||
|
||||
my %seen;
|
||||
my @layers = HAVE_PERLIO ? grep { !$PERLIO_SKIP{$_} and !$seen{$_}++ } PerlIO::get_layers($fh) : ();
|
||||
binmode($out, join(":", "", "raw", @layers));
|
||||
|
||||
my $old = select $fh;
|
||||
my $af = $|;
|
||||
select $out;
|
||||
$| = $af;
|
||||
select $old;
|
||||
|
||||
return $out;
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
if (IS_WIN32) {
|
||||
my $max_tries = 5;
|
||||
|
||||
*do_rename = sub {
|
||||
my ($from, $to) = @_;
|
||||
|
||||
my $err;
|
||||
for (1 .. $max_tries) {
|
||||
return (1) if rename($from, $to);
|
||||
$err = "$!";
|
||||
last if $_ == $max_tries;
|
||||
sleep 1;
|
||||
}
|
||||
|
||||
return (0, $err);
|
||||
};
|
||||
*do_unlink = sub {
|
||||
my ($file) = @_;
|
||||
|
||||
my $err;
|
||||
for (1 .. $max_tries) {
|
||||
return (1) if unlink($file);
|
||||
$err = "$!";
|
||||
last if $_ == $max_tries;
|
||||
sleep 1;
|
||||
}
|
||||
|
||||
return (0, "$!");
|
||||
};
|
||||
}
|
||||
else {
|
||||
*do_rename = sub {
|
||||
my ($from, $to) = @_;
|
||||
return (1) if rename($from, $to);
|
||||
return (0, "$!");
|
||||
};
|
||||
*do_unlink = sub {
|
||||
my ($file) = @_;
|
||||
return (1) if unlink($file);
|
||||
return (0, "$!");
|
||||
};
|
||||
}
|
||||
}
|
||||
|
||||
sub try_sig_mask(&) {
|
||||
my $code = shift;
|
||||
|
||||
my ($old, $blocked);
|
||||
unless(IS_WIN32) {
|
||||
my $to_block = POSIX::SigSet->new(
|
||||
POSIX::SIGINT(),
|
||||
POSIX::SIGALRM(),
|
||||
POSIX::SIGHUP(),
|
||||
POSIX::SIGTERM(),
|
||||
POSIX::SIGUSR1(),
|
||||
POSIX::SIGUSR2(),
|
||||
);
|
||||
$old = POSIX::SigSet->new;
|
||||
$blocked = POSIX::sigprocmask(POSIX::SIG_BLOCK(), $to_block, $old);
|
||||
# Silently go on if we failed to log signals, not much we can do.
|
||||
}
|
||||
|
||||
my ($ok, $err) = &try($code);
|
||||
|
||||
# If our block was successful we want to restore the old mask.
|
||||
POSIX::sigprocmask(POSIX::SIG_SETMASK(), $old, POSIX::SigSet->new()) if defined $blocked;
|
||||
|
||||
return ($ok, $err);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util - Tools used by Test2 and friends.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Collection of tools used by L<Test2> and friends.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All exports are optional. You must specify subs to import.
|
||||
|
||||
=over 4
|
||||
|
||||
=item ($success, $error) = try { ... }
|
||||
|
||||
Eval the codeblock, return success or failure, and the error message. This code
|
||||
protects $@ and $!, they will be restored by the end of the run. This code also
|
||||
temporarily blocks $SIG{DIE} handlers.
|
||||
|
||||
=item protect { ... }
|
||||
|
||||
Similar to try, except that it does not catch exceptions. The idea here is to
|
||||
protect $@ and $! from changes. $@ and $! will be restored to whatever they
|
||||
were before the run so long as it is successful. If the run fails $! will still
|
||||
be restored, but $@ will contain the exception being thrown.
|
||||
|
||||
=item CAN_FORK
|
||||
|
||||
True if this system is capable of true or pseudo-fork.
|
||||
|
||||
=item CAN_REALLY_FORK
|
||||
|
||||
True if the system can really fork. This will be false for systems where fork
|
||||
is emulated.
|
||||
|
||||
=item CAN_THREAD
|
||||
|
||||
True if this system is capable of using threads.
|
||||
|
||||
=item USE_THREADS
|
||||
|
||||
Returns true if threads are enabled, false if they are not.
|
||||
|
||||
=item get_tid
|
||||
|
||||
This will return the id of the current thread when threads are enabled,
|
||||
otherwise it returns 0.
|
||||
|
||||
=item my $file = pkg_to_file($package)
|
||||
|
||||
Convert a package name to a filename.
|
||||
|
||||
=item $string = ipc_separator()
|
||||
|
||||
Get the IPC separator. Currently this is always the string C<'~'>.
|
||||
|
||||
=item $string = gen_uid()
|
||||
|
||||
Generate a unique id (NOT A UUID). This will typically be the process id, the
|
||||
thread id, the time, and an incrementing integer all joined with the
|
||||
C<ipc_separator()>.
|
||||
|
||||
These ID's are unique enough for most purposes. For identical ids to be
|
||||
generated you must have 2 processes with the same PID generate IDs at the same
|
||||
time with the same current state of the incrementing integer. This is a
|
||||
perfectly reasonable thing to expect to happen across multiple machines, but is
|
||||
quite unlikely to happen on one machine.
|
||||
|
||||
This can fail to be unique if a process generates an id, calls exec, and does
|
||||
it again after the exec and it all happens in less than a second. It can also
|
||||
happen if the systems process id's cycle in less than a second allowing 2
|
||||
different programs that use this generator to run with the same PID in less
|
||||
than a second. Both these cases are sufficiently unlikely. If you need
|
||||
universally unique ids, or ids that are unique in these conditions, look at
|
||||
L<Data::UUID>.
|
||||
|
||||
=item ($ok, $err) = do_rename($old_name, $new_name)
|
||||
|
||||
Rename a file, this wraps C<rename()> in a way that makes it more reliable
|
||||
cross-platform when trying to rename files you recently altered.
|
||||
|
||||
=item ($ok, $err) = do_unlink($filename)
|
||||
|
||||
Unlink a file, this wraps C<unlink()> in a way that makes it more reliable
|
||||
cross-platform when trying to unlink files you recently altered.
|
||||
|
||||
=item ($ok, $err) = try_sig_mask { ... }
|
||||
|
||||
Complete an action with several signals masked, they will be unmasked at the
|
||||
end allowing any signals that were intercepted to get handled.
|
||||
|
||||
This is primarily used when you need to make several actions atomic (against
|
||||
some signals anyway).
|
||||
|
||||
Signals that are intercepted:
|
||||
|
||||
=over 4
|
||||
|
||||
=item SIGINT
|
||||
|
||||
=item SIGALRM
|
||||
|
||||
=item SIGHUP
|
||||
|
||||
=item SIGTERM
|
||||
|
||||
=item SIGUSR1
|
||||
|
||||
=item SIGUSR2
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=head1 NOTES && CAVEATS
|
||||
|
||||
=over 4
|
||||
|
||||
=item 5.10.0
|
||||
|
||||
Perl 5.10.0 has a bug when compiled with newer gcc versions. This bug causes a
|
||||
segfault whenever a new thread is launched. Test2 will attempt to detect
|
||||
this, and note that the system is not capable of forking when it is detected.
|
||||
|
||||
=item Devel::Cover
|
||||
|
||||
Devel::Cover does not support threads. CAN_THREAD will return false if
|
||||
Devel::Cover is loaded before the check is first run.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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>
|
||||
|
||||
=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
|
||||
|
||||
=back
|
||||
|
||||
=head1 COPYRIGHT
|
||||
|
||||
Copyright 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
182
t/lib/Test2/Util/ExternalMeta.pm
Normal file
182
t/lib/Test2/Util/ExternalMeta.pm
Normal file
|
|
@ -0,0 +1,182 @@
|
|||
package Test2::Util::ExternalMeta;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
|
||||
use Carp qw/croak/;
|
||||
|
||||
sub META_KEY() { '_meta' }
|
||||
|
||||
our @EXPORT = qw/meta set_meta get_meta delete_meta/;
|
||||
BEGIN { require Exporter; our @ISA = qw(Exporter) }
|
||||
|
||||
sub set_meta {
|
||||
my $self = shift;
|
||||
my ($key, $value) = @_;
|
||||
|
||||
validate_key($key);
|
||||
|
||||
$self->{+META_KEY} ||= {};
|
||||
$self->{+META_KEY}->{$key} = $value;
|
||||
}
|
||||
|
||||
sub get_meta {
|
||||
my $self = shift;
|
||||
my ($key) = @_;
|
||||
|
||||
validate_key($key);
|
||||
|
||||
my $meta = $self->{+META_KEY} or return undef;
|
||||
return $meta->{$key};
|
||||
}
|
||||
|
||||
sub delete_meta {
|
||||
my $self = shift;
|
||||
my ($key) = @_;
|
||||
|
||||
validate_key($key);
|
||||
|
||||
my $meta = $self->{+META_KEY} or return undef;
|
||||
delete $meta->{$key};
|
||||
}
|
||||
|
||||
sub meta {
|
||||
my $self = shift;
|
||||
my ($key, $default) = @_;
|
||||
|
||||
validate_key($key);
|
||||
|
||||
my $meta = $self->{+META_KEY};
|
||||
return undef unless $meta || defined($default);
|
||||
|
||||
unless($meta) {
|
||||
$meta = {};
|
||||
$self->{+META_KEY} = $meta;
|
||||
}
|
||||
|
||||
$meta->{$key} = $default
|
||||
if defined($default) && !defined($meta->{$key});
|
||||
|
||||
return $meta->{$key};
|
||||
}
|
||||
|
||||
sub validate_key {
|
||||
my $key = shift;
|
||||
|
||||
return if $key && !ref($key);
|
||||
|
||||
my $render_key = defined($key) ? "'$key'" : 'undef';
|
||||
croak "Invalid META key: $render_key, keys must be true, and may not be references";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::ExternalMeta - Allow third party tools to safely attach meta-data
|
||||
to your instances.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package lets you define a clear, and consistent way to allow third party
|
||||
tools to attach meta-data to your instances. If your object consumes this
|
||||
package, and imports its methods, then third party meta-data has a safe place
|
||||
to live.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
package My::Object;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
|
||||
|
||||
...
|
||||
|
||||
Now to use it:
|
||||
|
||||
my $inst = My::Object->new;
|
||||
|
||||
$inst->set_meta(foo => 'bar');
|
||||
my $val = $inst->get_meta('foo');
|
||||
|
||||
=head1 WHERE IS THE DATA STORED?
|
||||
|
||||
This package assumes your instances are blessed hashrefs, it will not work if
|
||||
that is not true. It will store all meta-data in the C<_meta> key on your
|
||||
objects hash. If your object makes use of the C<_meta> key in its underlying
|
||||
hash, then there is a conflict and you cannot use this package.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $val = $obj->meta($key)
|
||||
|
||||
=item $val = $obj->meta($key, $default)
|
||||
|
||||
This will get the value for a specified meta C<$key>. Normally this will return
|
||||
C<undef> when there is no value for the C<$key>, however you can specify a
|
||||
C<$default> value to set when no value is already set.
|
||||
|
||||
=item $val = $obj->get_meta($key)
|
||||
|
||||
This will get the value for a specified meta C<$key>. This does not have the
|
||||
C<$default> overhead that C<meta()> does.
|
||||
|
||||
=item $val = $obj->delete_meta($key)
|
||||
|
||||
This will remove the value of a specified meta C<$key>. The old C<$val> will be
|
||||
returned.
|
||||
|
||||
=item $obj->set_meta($key, $val)
|
||||
|
||||
Set the value of a specified meta C<$key>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 META-KEY RESTRICTIONS
|
||||
|
||||
Meta keys must be defined, and must be true when used as a boolean. Keys may
|
||||
not be references. You are free to stringify a reference C<"$ref"> for use as a
|
||||
key, but this package will not stringify it for you.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
299
t/lib/Test2/Util/Facets2Legacy.pm
Normal file
299
t/lib/Test2/Util/Facets2Legacy.pm
Normal file
|
|
@ -0,0 +1,299 @@
|
|||
package Test2::Util::Facets2Legacy;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
use Carp qw/croak confess/;
|
||||
use Scalar::Util qw/blessed/;
|
||||
|
||||
use base 'Exporter';
|
||||
our @EXPORT_OK = qw{
|
||||
causes_fail
|
||||
diagnostics
|
||||
global
|
||||
increments_count
|
||||
no_display
|
||||
sets_plan
|
||||
subtest_id
|
||||
summary
|
||||
terminate
|
||||
uuid
|
||||
};
|
||||
our %EXPORT_TAGS = ( ALL => \@EXPORT_OK );
|
||||
|
||||
our $CYCLE_DETECT = 0;
|
||||
sub _get_facet_data {
|
||||
my $in = shift;
|
||||
|
||||
if (blessed($in) && $in->isa('Test2::Event')) {
|
||||
confess "Cycle between Facets2Legacy and $in\->facet_data() (Did you forget to override the facet_data() method?)"
|
||||
if $CYCLE_DETECT;
|
||||
|
||||
local $CYCLE_DETECT = 1;
|
||||
return $in->facet_data;
|
||||
}
|
||||
|
||||
return $in if ref($in) eq 'HASH';
|
||||
|
||||
croak "'$in' Does not appear to be either a Test::Event or an EventFacet hashref";
|
||||
}
|
||||
|
||||
sub causes_fail {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
|
||||
return 1 if $facet_data->{errors} && grep { $_->{fail} } @{$facet_data->{errors}};
|
||||
|
||||
if (my $control = $facet_data->{control}) {
|
||||
return 1 if $control->{halt};
|
||||
return 1 if $control->{terminate};
|
||||
}
|
||||
|
||||
return 0 if $facet_data->{amnesty} && @{$facet_data->{amnesty}};
|
||||
return 1 if $facet_data->{assert} && !$facet_data->{assert}->{pass};
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub diagnostics {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return 1 if $facet_data->{errors} && @{$facet_data->{errors}};
|
||||
return 0 unless $facet_data->{info} && @{$facet_data->{info}};
|
||||
return (grep { $_->{debug} } @{$facet_data->{info}}) ? 1 : 0;
|
||||
}
|
||||
|
||||
sub global {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return 0 unless $facet_data->{control};
|
||||
return $facet_data->{control}->{global};
|
||||
}
|
||||
|
||||
sub increments_count {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return $facet_data->{assert} ? 1 : 0;
|
||||
}
|
||||
|
||||
sub no_display {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return 0 unless $facet_data->{about};
|
||||
return $facet_data->{about}->{no_display};
|
||||
}
|
||||
|
||||
sub sets_plan {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
my $plan = $facet_data->{plan} or return;
|
||||
my @out = ($plan->{count} || 0);
|
||||
|
||||
if ($plan->{skip}) {
|
||||
push @out => 'SKIP';
|
||||
push @out => $plan->{details} if defined $plan->{details};
|
||||
}
|
||||
elsif ($plan->{none}) {
|
||||
push @out => 'NO PLAN'
|
||||
}
|
||||
|
||||
return @out;
|
||||
}
|
||||
|
||||
sub subtest_id {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return undef unless $facet_data->{parent};
|
||||
return $facet_data->{parent}->{hid};
|
||||
}
|
||||
|
||||
sub summary {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return '' unless $facet_data->{about} && $facet_data->{about}->{details};
|
||||
return $facet_data->{about}->{details};
|
||||
}
|
||||
|
||||
sub terminate {
|
||||
my $facet_data = _get_facet_data(shift @_);
|
||||
return undef unless $facet_data->{control};
|
||||
return $facet_data->{control}->{terminate};
|
||||
}
|
||||
|
||||
sub uuid {
|
||||
my $in = shift;
|
||||
|
||||
if ($CYCLE_DETECT) {
|
||||
if (blessed($in) && $in->isa('Test2::Event')) {
|
||||
my $meth = $in->can('uuid');
|
||||
$meth = $in->can('SUPER::uuid') if $meth == \&uuid;
|
||||
my $uuid = $in->$meth if $meth && $meth != \&uuid;
|
||||
return $uuid if $uuid;
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
my $facet_data = _get_facet_data($in);
|
||||
return $facet_data->{about}->{uuid} if $facet_data->{about} && $facet_data->{about}->{uuid};
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::Facets2Legacy - Convert facet data to the legacy event API.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module exports several subroutines from the older event API (see
|
||||
L<Test2::Event>). These subroutines can be used as methods on any object that
|
||||
provides a custom C<facet_data()> method. These subroutines can also be used as
|
||||
functions that take a facet data hashref as arguments.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
=head2 AS METHODS
|
||||
|
||||
package My::Event;
|
||||
|
||||
use Test2::Util::Facets2Legacy ':ALL';
|
||||
|
||||
sub facet_data { return { ... } }
|
||||
|
||||
Then to use it:
|
||||
|
||||
my $e = My::Event->new(...);
|
||||
|
||||
my $causes_fail = $e->causes_fail;
|
||||
my $summary = $e->summary;
|
||||
....
|
||||
|
||||
=head2 AS FUNCTIONS
|
||||
|
||||
use Test2::Util::Facets2Legacy ':ALL';
|
||||
|
||||
my $f = {
|
||||
assert => { ... },
|
||||
info => [{...}, ...],
|
||||
control => {...},
|
||||
...
|
||||
};
|
||||
|
||||
my $causes_fail = causes_fail($f);
|
||||
my $summary = summary($f);
|
||||
|
||||
=head1 NOTE ON CYCLES
|
||||
|
||||
When used as methods, all these subroutines call C<< $e->facet_data() >>. The
|
||||
default C<facet_data()> method in L<Test2::Event> relies on the legacy methods
|
||||
this module emulates in order to work. As a result of this it is very easy to
|
||||
create infinite recursion bugs.
|
||||
|
||||
These methods have cycle detection and will throw an exception early if a cycle
|
||||
is detected. C<uuid()> is currently the only subroutine in this library that
|
||||
has a fallback behavior when cycles are detected.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
Nothing is exported by default. You must specify which methods to import, or
|
||||
use the ':ALL' tag.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $bool = $e->causes_fail()
|
||||
|
||||
=item $bool = causes_fail($f)
|
||||
|
||||
Check if the event or facets result in a failing state.
|
||||
|
||||
=item $bool = $e->diagnostics()
|
||||
|
||||
=item $bool = diagnostics($f)
|
||||
|
||||
Check if the event or facets contain any diagnostics information.
|
||||
|
||||
=item $bool = $e->global()
|
||||
|
||||
=item $bool = global($f)
|
||||
|
||||
Check if the event or facets need to be globally processed.
|
||||
|
||||
=item $bool = $e->increments_count()
|
||||
|
||||
=item $bool = increments_count($f)
|
||||
|
||||
Check if the event or facets make an assertion.
|
||||
|
||||
=item $bool = $e->no_display()
|
||||
|
||||
=item $bool = no_display($f)
|
||||
|
||||
Check if the event or facets should be rendered or hidden.
|
||||
|
||||
=item ($max, $directive, $reason) = $e->sets_plan()
|
||||
|
||||
=item ($max, $directive, $reason) = sets_plan($f)
|
||||
|
||||
Check if the event or facets set a plan, and return the plan details.
|
||||
|
||||
=item $id = $e->subtest_id()
|
||||
|
||||
=item $id = subtest_id($f)
|
||||
|
||||
Get the subtest id, if any.
|
||||
|
||||
=item $string = $e->summary()
|
||||
|
||||
=item $string = summary($f)
|
||||
|
||||
Get the summary of the event or facets hash, if any.
|
||||
|
||||
=item $undef_or_int = $e->terminate()
|
||||
|
||||
=item $undef_or_int = terminate($f)
|
||||
|
||||
Check if the event or facets should result in process termination, if so the
|
||||
exit code is returned (which could be 0). undef is returned if no termination
|
||||
is requested.
|
||||
|
||||
=item $uuid = $e->uuid()
|
||||
|
||||
=item $uuid = uuid($f)
|
||||
|
||||
Get the UUID of the facets or event.
|
||||
|
||||
B<Note:> This will fall back to C<< $e->SUPER::uuid() >> if a cycle is
|
||||
detected and an event is used as the argument.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
473
t/lib/Test2/Util/HashBase.pm
Normal file
473
t/lib/Test2/Util/HashBase.pm
Normal file
|
|
@ -0,0 +1,473 @@
|
|||
package Test2::Util::HashBase;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
#################################################################
|
||||
# #
|
||||
# This is a generated file! Do not modify this file directly! #
|
||||
# Use hashbase_inc.pl script to regenerate this file. #
|
||||
# The script is part of the Object::HashBase distribution. #
|
||||
# Note: You can modify the version number above this comment #
|
||||
# if needed, that is fine. #
|
||||
# #
|
||||
#################################################################
|
||||
|
||||
{
|
||||
no warnings 'once';
|
||||
$Test2::Util::HashBase::HB_VERSION = '0.009';
|
||||
*Test2::Util::HashBase::ATTR_SUBS = \%Object::HashBase::ATTR_SUBS;
|
||||
*Test2::Util::HashBase::ATTR_LIST = \%Object::HashBase::ATTR_LIST;
|
||||
*Test2::Util::HashBase::VERSION = \%Object::HashBase::VERSION;
|
||||
*Test2::Util::HashBase::CAN_CACHE = \%Object::HashBase::CAN_CACHE;
|
||||
}
|
||||
|
||||
|
||||
require Carp;
|
||||
{
|
||||
no warnings 'once';
|
||||
$Carp::Internal{+__PACKAGE__} = 1;
|
||||
}
|
||||
|
||||
BEGIN {
|
||||
# these are not strictly equivalent, but for out use we don't care
|
||||
# about order
|
||||
*_isa = ($] >= 5.010 && require mro) ? \&mro::get_linear_isa : sub {
|
||||
no strict 'refs';
|
||||
my @packages = ($_[0]);
|
||||
my %seen;
|
||||
for my $package (@packages) {
|
||||
push @packages, grep !$seen{$_}++, @{"$package\::ISA"};
|
||||
}
|
||||
return \@packages;
|
||||
}
|
||||
}
|
||||
|
||||
my %SPEC = (
|
||||
'^' => {reader => 1, writer => 0, dep_writer => 1, read_only => 0, strip => 1},
|
||||
'-' => {reader => 1, writer => 0, dep_writer => 0, read_only => 1, strip => 1},
|
||||
'>' => {reader => 0, writer => 1, dep_writer => 0, read_only => 0, strip => 1},
|
||||
'<' => {reader => 1, writer => 0, dep_writer => 0, read_only => 0, strip => 1},
|
||||
'+' => {reader => 0, writer => 0, dep_writer => 0, read_only => 0, strip => 1},
|
||||
);
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
my $into = caller;
|
||||
|
||||
# Make sure we list the OLDEST version used to create this class.
|
||||
my $ver = $Test2::Util::HashBase::HB_VERSION || $Test2::Util::HashBase::VERSION;
|
||||
$Test2::Util::HashBase::VERSION{$into} = $ver if !$Test2::Util::HashBase::VERSION{$into} || $Test2::Util::HashBase::VERSION{$into} > $ver;
|
||||
|
||||
my $isa = _isa($into);
|
||||
my $attr_list = $Test2::Util::HashBase::ATTR_LIST{$into} ||= [];
|
||||
my $attr_subs = $Test2::Util::HashBase::ATTR_SUBS{$into} ||= {};
|
||||
|
||||
my %subs = (
|
||||
($into->can('new') ? () : (new => \&_new)),
|
||||
(map %{$Test2::Util::HashBase::ATTR_SUBS{$_} || {}}, @{$isa}[1 .. $#$isa]),
|
||||
(
|
||||
map {
|
||||
my $p = substr($_, 0, 1);
|
||||
my $x = $_;
|
||||
|
||||
my $spec = $SPEC{$p} || {reader => 1, writer => 1};
|
||||
|
||||
substr($x, 0, 1) = '' if $spec->{strip};
|
||||
push @$attr_list => $x;
|
||||
my ($sub, $attr) = (uc $x, $x);
|
||||
|
||||
$attr_subs->{$sub} = sub() { $attr };
|
||||
my %out = ($sub => $attr_subs->{$sub});
|
||||
|
||||
$out{$attr} = sub { $_[0]->{$attr} } if $spec->{reader};
|
||||
$out{"set_$attr"} = sub { $_[0]->{$attr} = $_[1] } if $spec->{writer};
|
||||
$out{"set_$attr"} = sub { Carp::croak("'$attr' is read-only") } if $spec->{read_only};
|
||||
$out{"set_$attr"} = sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] } if $spec->{dep_writer};
|
||||
|
||||
%out;
|
||||
} @_
|
||||
),
|
||||
);
|
||||
|
||||
no strict 'refs';
|
||||
*{"$into\::$_"} = $subs{$_} for keys %subs;
|
||||
}
|
||||
|
||||
sub attr_list {
|
||||
my $class = shift;
|
||||
|
||||
my $isa = _isa($class);
|
||||
|
||||
my %seen;
|
||||
my @list = grep { !$seen{$_}++ } map {
|
||||
my @out;
|
||||
|
||||
if (0.004 > ($Test2::Util::HashBase::VERSION{$_} || 0)) {
|
||||
Carp::carp("$_ uses an inlined version of Test2::Util::HashBase too old to support attr_list()");
|
||||
}
|
||||
else {
|
||||
my $list = $Test2::Util::HashBase::ATTR_LIST{$_};
|
||||
@out = $list ? @$list : ()
|
||||
}
|
||||
|
||||
@out;
|
||||
} reverse @$isa;
|
||||
|
||||
return @list;
|
||||
}
|
||||
|
||||
sub _new {
|
||||
my $class = shift;
|
||||
|
||||
my $self;
|
||||
|
||||
if (@_ == 1) {
|
||||
my $arg = shift;
|
||||
my $type = ref($arg);
|
||||
|
||||
if ($type eq 'HASH') {
|
||||
$self = bless({%$arg}, $class)
|
||||
}
|
||||
else {
|
||||
Carp::croak("Not sure what to do with '$type' in $class constructor")
|
||||
unless $type eq 'ARRAY';
|
||||
|
||||
my %proto;
|
||||
my @attributes = attr_list($class);
|
||||
while (@$arg) {
|
||||
my $val = shift @$arg;
|
||||
my $key = shift @attributes or Carp::croak("Too many arguments for $class constructor");
|
||||
$proto{$key} = $val;
|
||||
}
|
||||
|
||||
$self = bless(\%proto, $class);
|
||||
}
|
||||
}
|
||||
else {
|
||||
$self = bless({@_}, $class);
|
||||
}
|
||||
|
||||
$Test2::Util::HashBase::CAN_CACHE{$class} = $self->can('init')
|
||||
unless exists $Test2::Util::HashBase::CAN_CACHE{$class};
|
||||
|
||||
$self->init if $Test2::Util::HashBase::CAN_CACHE{$class};
|
||||
|
||||
$self;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::HashBase - Build hash based classes.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
A class:
|
||||
|
||||
package My::Class;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Generate 3 accessors
|
||||
use Test2::Util::HashBase qw/foo -bar ^baz <bat >ban +boo/;
|
||||
|
||||
# Chance to initialize defaults
|
||||
sub init {
|
||||
my $self = shift; # No other args
|
||||
$self->{+FOO} ||= "foo";
|
||||
$self->{+BAR} ||= "bar";
|
||||
$self->{+BAZ} ||= "baz";
|
||||
$self->{+BAT} ||= "bat";
|
||||
$self->{+BAN} ||= "ban";
|
||||
$self->{+BOO} ||= "boo";
|
||||
}
|
||||
|
||||
sub print {
|
||||
print join ", " => map { $self->{$_} } FOO, BAR, BAZ, BAT, BAN, BOO;
|
||||
}
|
||||
|
||||
Subclass it
|
||||
|
||||
package My::Subclass;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# Note, you should subclass before loading HashBase.
|
||||
use base 'My::Class';
|
||||
use Test2::Util::HashBase qw/bub/;
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
# We get the constants from the base class for free.
|
||||
$self->{+FOO} ||= 'SubFoo';
|
||||
$self->{+BUB} ||= 'bub';
|
||||
|
||||
$self->SUPER::init();
|
||||
}
|
||||
|
||||
use it:
|
||||
|
||||
package main;
|
||||
use strict;
|
||||
use warnings;
|
||||
use My::Class;
|
||||
|
||||
# These are all functionally identical
|
||||
my $one = My::Class->new(foo => 'MyFoo', bar => 'MyBar');
|
||||
my $two = My::Class->new({foo => 'MyFoo', bar => 'MyBar'});
|
||||
my $three = My::Class->new(['MyFoo', 'MyBar']);
|
||||
|
||||
# Readers!
|
||||
my $foo = $one->foo; # 'MyFoo'
|
||||
my $bar = $one->bar; # 'MyBar'
|
||||
my $baz = $one->baz; # Defaulted to: 'baz'
|
||||
my $bat = $one->bat; # Defaulted to: 'bat'
|
||||
# '>ban' means setter only, no reader
|
||||
# '+boo' means no setter or reader, just the BOO constant
|
||||
|
||||
# Setters!
|
||||
$one->set_foo('A Foo');
|
||||
|
||||
#'-bar' means read-only, so the setter will throw an exception (but is defined).
|
||||
$one->set_bar('A bar');
|
||||
|
||||
# '^baz' means deprecated setter, this will warn about the setter being
|
||||
# deprecated.
|
||||
$one->set_baz('A Baz');
|
||||
|
||||
# '<bat' means no setter defined at all
|
||||
# '+boo' means no setter or reader, just the BOO constant
|
||||
|
||||
$one->{+FOO} = 'xxx';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package is used to generate classes based on hashrefs. Using this class
|
||||
will give you a C<new()> method, as well as generating accessors you request.
|
||||
Generated accessors will be getters, C<set_ACCESSOR> setters will also be
|
||||
generated for you. You also get constants for each accessor (all caps) which
|
||||
return the key into the hash for that accessor. Single inheritance is also
|
||||
supported.
|
||||
|
||||
=head1 THIS IS A BUNDLED COPY OF HASHBASE
|
||||
|
||||
This is a bundled copy of L<Object::HashBase>. This file was generated using
|
||||
the
|
||||
C</home/exodist/perl5/perlbrew/perls/main/bin/hashbase_inc.pl>
|
||||
script.
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=head2 PROVIDED BY HASH BASE
|
||||
|
||||
=over 4
|
||||
|
||||
=item $it = $class->new(%PAIRS)
|
||||
|
||||
=item $it = $class->new(\%PAIRS)
|
||||
|
||||
=item $it = $class->new(\@ORDERED_VALUES)
|
||||
|
||||
Create a new instance.
|
||||
|
||||
HashBase will not export C<new()> if there is already a C<new()> method in your
|
||||
packages inheritance chain.
|
||||
|
||||
B<If you do not want this method you can define your own> you just have to
|
||||
declare it before loading L<Test2::Util::HashBase>.
|
||||
|
||||
package My::Package;
|
||||
|
||||
# predeclare new() so that HashBase does not give us one.
|
||||
sub new;
|
||||
|
||||
use Test2::Util::HashBase qw/foo bar baz/;
|
||||
|
||||
# Now we define our own new method.
|
||||
sub new { ... }
|
||||
|
||||
This makes it so that HashBase sees that you have your own C<new()> method.
|
||||
Alternatively you can define the method before loading HashBase instead of just
|
||||
declaring it, but that scatters your use statements.
|
||||
|
||||
The most common way to create an object is to pass in key/value pairs where
|
||||
each key is an attribute and each value is what you want assigned to that
|
||||
attribute. No checking is done to verify the attributes or values are valid,
|
||||
you may do that in C<init()> if desired.
|
||||
|
||||
If you would like, you can pass in a hashref instead of pairs. When you do so
|
||||
the hashref will be copied, and the copy will be returned blessed as an object.
|
||||
There is no way to ask HashBase to bless a specific hashref.
|
||||
|
||||
In some cases an object may only have 1 or 2 attributes, in which case a
|
||||
hashref may be too verbose for your liking. In these cases you can pass in an
|
||||
arrayref with only values. The values will be assigned to attributes in the
|
||||
order the attributes were listed. When there is inheritance involved the
|
||||
attributes from parent classes will come before subclasses.
|
||||
|
||||
=back
|
||||
|
||||
=head2 HOOKS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $self->init()
|
||||
|
||||
This gives you the chance to set some default values to your fields. The only
|
||||
argument is C<$self> with its indexes already set from the constructor.
|
||||
|
||||
B<Note:> Test2::Util::HashBase checks for an init using C<< $class->can('init') >>
|
||||
during construction. It DOES NOT call C<can()> on the created object. Also note
|
||||
that the result of the check is cached, it is only ever checked once, the first
|
||||
time an instance of your class is created. This means that adding an C<init()>
|
||||
method AFTER the first construction will result in it being ignored.
|
||||
|
||||
=back
|
||||
|
||||
=head1 ACCESSORS
|
||||
|
||||
=head2 READ/WRITE
|
||||
|
||||
To generate accessors you list them when using the module:
|
||||
|
||||
use Test2::Util::HashBase qw/foo/;
|
||||
|
||||
This will generate the following subs in your namespace:
|
||||
|
||||
=over 4
|
||||
|
||||
=item foo()
|
||||
|
||||
Getter, used to get the value of the C<foo> field.
|
||||
|
||||
=item set_foo()
|
||||
|
||||
Setter, used to set the value of the C<foo> field.
|
||||
|
||||
=item FOO()
|
||||
|
||||
Constant, returns the field C<foo>'s key into the class hashref. Subclasses will
|
||||
also get this function as a constant, not simply a method, that means it is
|
||||
copied into the subclass namespace.
|
||||
|
||||
The main reason for using these constants is to help avoid spelling mistakes
|
||||
and similar typos. It will not help you if you forget to prefix the '+' though.
|
||||
|
||||
=back
|
||||
|
||||
=head2 READ ONLY
|
||||
|
||||
use Test2::Util::HashBase qw/-foo/;
|
||||
|
||||
=over 4
|
||||
|
||||
=item set_foo()
|
||||
|
||||
Throws an exception telling you the attribute is read-only. This is exported to
|
||||
override any active setters for the attribute in a parent class.
|
||||
|
||||
=back
|
||||
|
||||
=head2 DEPRECATED SETTER
|
||||
|
||||
use Test2::Util::HashBase qw/^foo/;
|
||||
|
||||
=over 4
|
||||
|
||||
=item set_foo()
|
||||
|
||||
This will set the value, but it will also warn you that the method is
|
||||
deprecated.
|
||||
|
||||
=back
|
||||
|
||||
=head2 NO SETTER
|
||||
|
||||
use Test2::Util::HashBase qw/<foo/;
|
||||
|
||||
Only gives you a reader, no C<set_foo> method is defined at all.
|
||||
|
||||
=head2 NO READER
|
||||
|
||||
use Test2::Util::HashBase qw/>foo/;
|
||||
|
||||
Only gives you a write (C<set_foo>), no C<foo> method is defined at all.
|
||||
|
||||
=head2 CONSTANT ONLY
|
||||
|
||||
use Test2::Util::HashBase qw/+foo/;
|
||||
|
||||
This does not create any methods for you, it just adds the C<FOO> constant.
|
||||
|
||||
=head1 SUBCLASSING
|
||||
|
||||
You can subclass an existing HashBase class.
|
||||
|
||||
use base 'Another::HashBase::Class';
|
||||
use Test2::Util::HashBase qw/foo bar baz/;
|
||||
|
||||
The base class is added to C<@ISA> for you, and all constants from base classes
|
||||
are added to subclasses automatically.
|
||||
|
||||
=head1 GETTING A LIST OF ATTRIBUTES FOR A CLASS
|
||||
|
||||
Test2::Util::HashBase provides a function for retrieving a list of attributes for an
|
||||
Test2::Util::HashBase class.
|
||||
|
||||
=over 4
|
||||
|
||||
=item @list = Test2::Util::HashBase::attr_list($class)
|
||||
|
||||
=item @list = $class->Test2::Util::HashBase::attr_list()
|
||||
|
||||
Either form above will work. This will return a list of attributes defined on
|
||||
the object. This list is returned in the attribute definition order, parent
|
||||
class attributes are listed before subclass attributes. Duplicate attributes
|
||||
will be removed before the list is returned.
|
||||
|
||||
B<Note:> This list is used in the C<< $class->new(\@ARRAY) >> constructor to
|
||||
determine the attribute to which each value will be paired.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for HashBase can be found at
|
||||
F<http://github.com/Test-More/HashBase/>.
|
||||
|
||||
=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 2017 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
54
t/lib/Test2/Util/Trace.pm
Normal file
54
t/lib/Test2/Util/Trace.pm
Normal file
|
|
@ -0,0 +1,54 @@
|
|||
package Test2::Util::Trace;
|
||||
require Test2::EventFacet::Trace;
|
||||
@ISA = ('Test2::EventFacet::Trace');
|
||||
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Util::Trace - Legacy wrapper fro L<Test2::EventFacet::Trace>.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
All the functionality for this class has been moved to
|
||||
L<Test2::EventFacet::Trace>.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 can be found at
|
||||
F<http://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 2019 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 F<http://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
49
t/lib/ok.pm
Normal file
49
t/lib/ok.pm
Normal file
|
|
@ -0,0 +1,49 @@
|
|||
package ok;
|
||||
our $VERSION = '1.302175';
|
||||
|
||||
use strict;
|
||||
use Test::More ();
|
||||
|
||||
sub import {
|
||||
shift;
|
||||
|
||||
if (@_) {
|
||||
goto &Test::More::pass if $_[0] eq 'ok';
|
||||
goto &Test::More::use_ok;
|
||||
}
|
||||
|
||||
# No argument list - croak as if we are prototyped like use_ok()
|
||||
my (undef, $file, $line) = caller();
|
||||
($file =~ /^\(eval/) or die "Not enough arguments for 'use ok' at $file line $line\n";
|
||||
}
|
||||
|
||||
|
||||
__END__
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
ok - Alternative to Test::More::use_ok
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use ok 'Some::Module';
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
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.
|
||||
|
||||
Please see L<Test::use::ok> for the full description.
|
||||
|
||||
=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<http://creativecommons.org/publicdomain/zero/1.0>
|
||||
|
||||
=cut
|
||||
Loading…
Reference in a new issue