Initial Commit

This commit is contained in:
Riley Schneider
2025-12-03 16:38:10 +01:00
parent c5e26bf594
commit b732d8d4b5
17680 changed files with 5977495 additions and 2 deletions

View File

@@ -0,0 +1,109 @@
package Test2::Event::Bail;
use strict;
use warnings;
our $VERSION = '1.302183';
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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

View File

@@ -0,0 +1,99 @@
package Test2::Event::Diag;
use strict;
use warnings;
our $VERSION = '1.302183';
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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

View File

@@ -0,0 +1,97 @@
package Test2::Event::Encoding;
use strict;
use warnings;
our $VERSION = '1.302183';
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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

View File

@@ -0,0 +1,113 @@
package Test2::Event::Exception;
use strict;
use warnings;
our $VERSION = '1.302183';
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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

View File

@@ -0,0 +1,118 @@
package Test2::Event::Fail;
use strict;
use warnings;
our $VERSION = '1.302183';
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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

View 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.302183';
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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

View File

@@ -0,0 +1,97 @@
package Test2::Event::Note;
use strict;
use warnings;
our $VERSION = '1.302183';
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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

View File

@@ -0,0 +1,169 @@
package Test2::Event::Ok;
use strict;
use warnings;
our $VERSION = '1.302183';
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) {
my %seen;
# It is possible the extra amnesty can be a duplicate, so filter it.
$out->{amnesty} = [
grep { !$seen{defined($_->{tag}) ? $_->{tag} : ''}->{defined($_->{details}) ? $_->{details} : ''}++ }
@exra_amnesty,
@{$out->{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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

View File

@@ -0,0 +1,114 @@
package Test2::Event::Pass;
use strict;
use warnings;
our $VERSION = '1.302183';
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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

View File

@@ -0,0 +1,169 @@
package Test2::Event::Plan;
use strict;
use warnings;
our $VERSION = '1.302183';
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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

View File

@@ -0,0 +1,127 @@
package Test2::Event::Skip;
use strict;
use warnings;
our $VERSION = '1.302183';
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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://www.perl.com/perl/misc/Artistic.html>
=cut

View File

@@ -0,0 +1,160 @@
package Test2::Event::Subtest;
use strict;
use warnings;
our $VERSION = '1.302183';
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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

View File

@@ -0,0 +1,101 @@
package Test2::Event::TAP::Version;
use strict;
use warnings;
our $VERSION = '1.302183';
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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

View File

@@ -0,0 +1,239 @@
package Test2::Event::V2;
use strict;
use warnings;
our $VERSION = '1.302183';
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 ($self->{+ABOUT} && $self->{+ABOUT}->{uuid}) {
$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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

View File

@@ -0,0 +1,76 @@
package Test2::Event::Waiting;
use strict;
use warnings;
our $VERSION = '1.302183';
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 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut