| Current File : /home/mmdealscpanel/yummmdeals.com/Test2.zip |
PK V�[�%�=� �
EventFacet.pmnu �[��� package Test2::EventFacet;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[��L�( �( Util.pmnu �[��� package Test2::Util;
use strict;
use warnings;
our $VERSION = '1.302135';
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 = 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 2018 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
PK V�[ �\s} } Event/Subtest.pmnu �[��� package Test2::Event::Subtest;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[.y�� Event/Generic.pmnu �[��� package Test2::Event::Generic;
use strict;
use warnings;
use Carp qw/croak/;
use Scalar::Util qw/reftype/;
our $VERSION = '1.302135';
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 2018 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
PK V�[K�� �
Event/Pass.pmnu �[��� package Test2::Event::Pass;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[ RB6� � Event/V2.pmnu �[��� package Test2::Event::V2;
use strict;
use warnings;
our $VERSION = '1.302135';
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};
my $is_list = reftype($data) eq 'ARRAY';
$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 2018 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
PK V�[&�7� �
Event/Bail.pmnu �[��� package Test2::Event::Bail;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[� L�� � Event/Encoding.pmnu �[��� package Test2::Event::Encoding;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[d��<
<
Event/Plan.pmnu �[��� package Test2::Event::Plan;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[�Q��S S Event/Ok.pmnu �[��� package Test2::Event::Ok;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[�v� � Event/Exception.pmnu �[��� package Test2::Event::Exception;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[yx�� � Event/Waiting.pmnu �[��� package Test2::Event::Waiting;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[R�/� �
Event/Note.pmnu �[��� package Test2::Event::Note;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[.��R� �
Event/Fail.pmnu �[��� package Test2::Event::Fail;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[XA
�l l Event/TAP/Version.pmnu �[��� package Test2::Event::TAP::Version;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[G'L[� �
Event/Diag.pmnu �[��� package Test2::Event::Diag;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[>�i�� �
Event/Skip.pmnu �[��� package Test2::Event::Skip;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[h�)7P
P
Hub/Subtest.pmnu �[��� package Test2::Hub::Subtest;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[*���� � Hub/Interceptor/Terminator.pmnu �[��� package Test2::Hub::Interceptor::Terminator;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[�L�� � Hub/Interceptor.pmnu �[��� package Test2::Hub::Interceptor;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[���g_ _ API/Instance.pmnu �[��� package Test2::API::Instance;
use strict;
use warnings;
our $VERSION = '1.302135';
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_shm_size
ipc_shm_last
ipc_shm_id
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;
$self->ipc_enable_shm if $self->{+IPC}->use_shm;
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 $_[0]->{hub}->cull unless $self->{+IPC_SHM_ID};
my $val;
if(shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE})) {
return if $val eq $self->{+IPC_SHM_LAST};
$self->{+IPC_SHM_LAST} = $val;
}
else {
warn "SHM Read error: $!\n";
}
$_[0]->{hub}->cull;
}
) unless defined $self->ipc_polling;
$self->set_ipc_polling(1);
}
sub ipc_enable_shm {
my $self = shift;
return 1 if defined $self->{+IPC_SHM_ID};
$self->{+_PID} = $$ unless defined $self->{+_PID};
$self->{+_TID} = get_tid() unless defined $self->{+_TID};
my ($ok, $err) = try {
# SysV IPC can be available but not enabled.
#
# In some systems (*BSD) accessing the SysV IPC APIs without
# them being enabled can cause a SIGSYS. We suppress the SIGSYS
# and then get ENOSYS from the calls.
local $SIG{SYS} = 'IGNORE' if CAN_SIGSYS;
require IPC::SysV;
my $ipc_key = IPC::SysV::IPC_PRIVATE();
my $shm_size = $self->{+IPC}->can('shm_size') ? $self->{+IPC}->shm_size : 64;
my $shm_id = shmget($ipc_key, $shm_size, 0666) or die "Could not get shm: $!";
my $initial = 'a' x $shm_size;
shmwrite($shm_id, $initial, 0, $shm_size) or die "Could not write to shm: $!";
my $val;
shmread($shm_id, $val, 0, $shm_size) or die "Could not read from shm: $!";
die "Read SHM value does not match the initial value ('$val' vs '$initial')"
unless $val eq $initial;
$self->{+IPC_SHM_SIZE} = $shm_size;
$self->{+IPC_SHM_ID} = $shm_id;
$self->{+IPC_SHM_LAST} = $initial;
};
return $ok;
}
sub ipc_free_shm {
my $self = shift;
my $id = delete $self->{+IPC_SHM_ID};
return unless defined $id;
shmctl($id, IPC::SysV::IPC_RMID(), 0);
}
sub get_ipc_pending {
my $self = shift;
return -1 unless defined $self->{+IPC_SHM_ID};
my $val;
shmread($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE}) or return -1;
return 0 if $val eq $self->{+IPC_SHM_LAST};
$self->{+IPC_SHM_LAST} = $val;
return 1;
}
sub set_ipc_pending {
my $self = shift;
return undef unless defined $self->{+IPC_SHM_ID};
my ($val) = @_;
confess "value is required for set_ipc_pending"
unless $val;
shmwrite($self->{+IPC_SHM_ID}, $val, 0, $self->{+IPC_SHM_SIZE});
}
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 DESTROY {
my $self = shift;
return if $self->{+PRELOAD};
return unless defined($self->{+_PID}) && $self->{+_PID} == $$;
return unless defined($self->{+_TID}) && $self->{+_TID} == get_tid();
shmctl($self->{+IPC_SHM_ID}, IPC::SysV::IPC_RMID(), 0)
if defined $self->{+IPC_SHM_ID};
}
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->ipc_enable_shm()
Turn on SHM for IPC (if possible)
=item $shm_id = $obj->ipc_shm_id()
If SHM is enabled for IPC this will be the shm_id for it.
=item $shm_size = $obj->ipc_shm_size()
If SHM is enabled for IPC this will be the size of it.
=item $shm_last_val = $obj->ipc_shm_last()
If SHM is enabled for IPC this will return the last SHM value seen.
=item $obj->set_ipc_pending($val)
use the IPC SHM to 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. It does
not set C<ipc_shm_last()>, this is important because doing so could hide a
previous change.
=item $pending = $obj->get_ipc_pending()
This returns -1 if SHM is not enabled for IPC.
This returns 0 if the SHM value matches the last known value, which means there
are no pending events.
This returns 1 if the SHM value has changed, which means there are probably
pending events.
When 1 is returned this will set C<< $obj->ipc_shm_last() >>.
=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 2018 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
PK V�[�:JE� � API/Stack.pmnu �[��� package Test2::API::Stack;
use strict;
use warnings;
our $VERSION = '1.302135';
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 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 2018 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
PK V�[�x� � API/Breakage.pmnu �[��� package Test2::API::Breakage;
use strict;
use warnings;
our $VERSION = '1.302135';
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 };
push @warn => " * Module '$mod' is outdated, we recommed updating above $want.";
}
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 2018 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
PK V�[o
�,�g �g API/Context.pmnu �[��� package Test2::API::Context;
use strict;
use warnings;
our $VERSION = '1.302135';
use Carp qw/confess croak/;
use Scalar::Util qw/weaken blessed/;
use Test2::Util qw/get_tid try pkg_to_file get_tid/;
use Test2::EventFacet::Trace();
use Test2::API();
# Preload some key event types
my %LOADED = (
map {
my $pkg = "Test2::Event::$_";
my $file = "Test2/Event/$_.pm";
require $file unless $INC{$file};
( $pkg => $pkg, $_ => $pkg )
} qw/Ok Diag Note Plan Bail Exception Waiting Skip Subtest Pass Fail V2/
);
use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
use Test2::Util::HashBase qw{
stack hub trace _on_release _depth _is_canon _is_spawn _aborted
errno eval_error child_error thrown
};
# Private, not package vars
# It is safe to cache these.
my $ON_RELEASE = Test2::API::_context_release_callbacks_ref();
my $CONTEXTS = Test2::API::_contexts_ref();
sub init {
my $self = shift;
confess "The 'trace' attribute is required"
unless $self->{+TRACE};
confess "The 'hub' attribute is required"
unless $self->{+HUB};
$self->{+_DEPTH} = 0 unless defined $self->{+_DEPTH};
$self->{+ERRNO} = $! unless exists $self->{+ERRNO};
$self->{+EVAL_ERROR} = $@ unless exists $self->{+EVAL_ERROR};
$self->{+CHILD_ERROR} = $? unless exists $self->{+CHILD_ERROR};
}
sub snapshot { bless {%{$_[0]}, _is_canon => undef, _is_spawn => undef, _aborted => undef}, __PACKAGE__ }
sub restore_error_vars {
my $self = shift;
($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR};
}
sub DESTROY {
return unless $_[0]->{+_IS_CANON} || $_[0]->{+_IS_SPAWN};
return if $_[0]->{+_ABORTED} && ${$_[0]->{+_ABORTED}};
my ($self) = @_;
my $hub = $self->{+HUB};
my $hid = $hub->{hid};
# Do not show the warning if it looks like an exception has been thrown, or
# if the context is not local to this process or thread.
{
# Sometimes $@ is uninitialized, not a problem in this case so do not
# show the warning about using eq.
no warnings 'uninitialized';
if($self->{+EVAL_ERROR} eq $@ && $hub->is_local) {
my $frame = $self->{+_IS_SPAWN} || $self->{+TRACE}->frame;
warn <<" EOT";
A context appears to have been destroyed without first calling release().
Based on \$@ it does not look like an exception was thrown (this is not always
a reliable test)
This is a problem because the global error variables (\$!, \$@, and \$?) will
not be restored. In addition some release callbacks will not work properly from
inside a DESTROY method.
Here are the context creation details, just in case a tool forgot to call
release():
File: $frame->[1]
Line: $frame->[2]
Tool: $frame->[3]
Cleaning up the CONTEXT stack...
EOT
}
}
return if $self->{+_IS_SPAWN};
# Remove the key itself to avoid a slow memory leak
delete $CONTEXTS->{$hid};
$self->{+_IS_CANON} = undef;
if (my $cbk = $self->{+_ON_RELEASE}) {
$_->($self) for reverse @$cbk;
}
if (my $hcbk = $hub->{_context_release}) {
$_->($self) for reverse @$hcbk;
}
$_->($self) for reverse @$ON_RELEASE;
}
# release exists to implement behaviors like die-on-fail. In die-on-fail you
# want to die after a failure, but only after diagnostics have been reported.
# The ideal time for the die to happen is when the context is released.
# Unfortunately die does not work in a DESTROY block.
sub release {
my ($self) = @_;
($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return if $self->{+THROWN};
($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} and return $self->{+_IS_SPAWN} = undef
if $self->{+_IS_SPAWN};
croak "release() should not be called on context that is neither canon nor a child"
unless $self->{+_IS_CANON};
my $hub = $self->{+HUB};
my $hid = $hub->{hid};
croak "context thinks it is canon, but it is not"
unless $CONTEXTS->{$hid} && $CONTEXTS->{$hid} == $self;
# Remove the key itself to avoid a slow memory leak
$self->{+_IS_CANON} = undef;
delete $CONTEXTS->{$hid};
if (my $cbk = $self->{+_ON_RELEASE}) {
$_->($self) for reverse @$cbk;
}
if (my $hcbk = $hub->{_context_release}) {
$_->($self) for reverse @$hcbk;
}
$_->($self) for reverse @$ON_RELEASE;
# Do this last so that nothing else changes them.
# If one of the hooks dies then these do not get restored, this is
# intentional
($!, $@, $?) = @$self{+ERRNO, +EVAL_ERROR, +CHILD_ERROR};
return;
}
sub do_in_context {
my $self = shift;
my ($sub, @args) = @_;
# We need to update the pid/tid and error vars.
my $clone = $self->snapshot;
@$clone{+ERRNO, +EVAL_ERROR, +CHILD_ERROR} = ($!, $@, $?);
$clone->{+TRACE} = $clone->{+TRACE}->snapshot(pid => $$, tid => get_tid());
my $hub = $clone->{+HUB};
my $hid = $hub->hid;
my $old = $CONTEXTS->{$hid};
$clone->{+_IS_CANON} = 1;
$CONTEXTS->{$hid} = $clone;
weaken($CONTEXTS->{$hid});
my ($ok, $err) = &try($sub, @args);
my ($rok, $rerr) = try { $clone->release };
delete $clone->{+_IS_CANON};
if ($old) {
$CONTEXTS->{$hid} = $old;
weaken($CONTEXTS->{$hid});
}
else {
delete $CONTEXTS->{$hid};
}
die $err unless $ok;
die $rerr unless $rok;
}
sub done_testing {
my $self = shift;
$self->hub->finalize($self->trace, 1);
return;
}
sub throw {
my ($self, $msg) = @_;
$self->{+THROWN} = 1;
${$self->{+_ABORTED}}++ if $self->{+_ABORTED};
$self->release if $self->{+_IS_CANON} || $self->{+_IS_SPAWN};
$self->trace->throw($msg);
}
sub alert {
my ($self, $msg) = @_;
$self->trace->alert($msg);
}
sub send_ev2_and_release {
my $self = shift;
my $out = $self->send_ev2(@_);
$self->release;
return $out;
}
sub send_ev2 {
my $self = shift;
my $e;
{
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
$e = Test2::Event::V2->new(
trace => $self->{+TRACE}->snapshot,
@_,
);
}
if ($self->{+_ABORTED}) {
my $f = $e->facet_data;
${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate);
}
$self->{+HUB}->send($e);
}
sub build_ev2 {
my $self = shift;
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
Test2::Event::V2->new(
trace => $self->{+TRACE}->snapshot,
@_,
);
}
sub send_event_and_release {
my $self = shift;
my $out = $self->send_event(@_);
$self->release;
return $out;
}
sub send_event {
my $self = shift;
my $event = shift;
my %args = @_;
my $pkg = $LOADED{$event} || $self->_parse_event($event);
my $e;
{
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
$e = $pkg->new(
trace => $self->{+TRACE}->snapshot,
%args,
);
}
if ($self->{+_ABORTED}) {
my $f = $e->facet_data;
${$self->{+_ABORTED}}++ if $f->{control}->{halt} || defined($f->{control}->{terminate}) || defined($e->terminate);
}
$self->{+HUB}->send($e);
}
sub build_event {
my $self = shift;
my $event = shift;
my %args = @_;
my $pkg = $LOADED{$event} || $self->_parse_event($event);
local $Carp::CarpLevel = $Carp::CarpLevel + 1;
$pkg->new(
trace => $self->{+TRACE}->snapshot,
%args,
);
}
sub pass {
my $self = shift;
my ($name) = @_;
my $e = bless(
{
trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
name => $name,
},
"Test2::Event::Pass"
);
$self->{+HUB}->send($e);
return $e;
}
sub pass_and_release {
my $self = shift;
my ($name) = @_;
my $e = bless(
{
trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
name => $name,
},
"Test2::Event::Pass"
);
$self->{+HUB}->send($e);
$self->release;
return 1;
}
sub fail {
my $self = shift;
my ($name, @diag) = @_;
my $e = bless(
{
trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
name => $name,
},
"Test2::Event::Fail"
);
$e->add_info({tag => 'DIAG', debug => 1, details => $_}) for @diag;
$self->{+HUB}->send($e);
return $e;
}
sub fail_and_release {
my $self = shift;
my ($name, @diag) = @_;
my $e = bless(
{
trace => bless({%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
name => $name,
},
"Test2::Event::Fail"
);
$e->add_info({tag => 'DIAG', debug => 1, details => $_}) for @diag;
$self->{+HUB}->send($e);
$self->release;
return 0;
}
sub ok {
my $self = shift;
my ($pass, $name, $on_fail) = @_;
my $hub = $self->{+HUB};
my $e = bless {
trace => bless( {%{$self->{+TRACE}}}, 'Test2::EventFacet::Trace'),
pass => $pass,
name => $name,
}, 'Test2::Event::Ok';
$e->init;
$hub->send($e);
return $e if $pass;
$self->failure_diag($e);
if ($on_fail && @$on_fail) {
$self->diag($_) for @$on_fail;
}
return $e;
}
sub failure_diag {
my $self = shift;
my ($e) = @_;
# 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 = $e->name;
my $trace = $e->trace;
my $debug = $trace ? $trace->debug : "[No trace info available]";
# 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 '$name'\n$debug.\n]
: qq[Failed test $debug.\n];
$self->diag($msg);
}
sub skip {
my $self = shift;
my ($name, $reason, @extra) = @_;
$self->send_event(
'Skip',
name => $name,
reason => $reason,
pass => 1,
@extra,
);
}
sub note {
my $self = shift;
my ($message) = @_;
$self->send_event('Note', message => $message);
}
sub diag {
my $self = shift;
my ($message) = @_;
my $hub = $self->{+HUB};
$self->send_event(
'Diag',
message => $message,
);
}
sub plan {
my ($self, $max, $directive, $reason) = @_;
$self->send_event('Plan', max => $max, directive => $directive, reason => $reason);
}
sub bail {
my ($self, $reason) = @_;
$self->send_event('Bail', reason => $reason);
}
sub _parse_event {
my $self = shift;
my $event = shift;
my $pkg;
if ($event =~ m/^\+(.*)/) {
$pkg = $1;
}
else {
$pkg = "Test2::Event::$event";
}
unless ($LOADED{$pkg}) {
my $file = pkg_to_file($pkg);
my ($ok, $err) = try { require $file };
$self->throw("Could not load event module '$pkg': $err")
unless $ok;
$LOADED{$pkg} = $pkg;
}
confess "'$pkg' is not a subclass of 'Test2::Event'"
unless $pkg->isa('Test2::Event');
$LOADED{$event} = $pkg;
return $pkg;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::API::Context - Object to represent a testing context.
=head1 DESCRIPTION
The context object is the primary interface for authors of testing tools
written with L<Test2>. The context object represents the context in
which a test takes place (File and Line Number), and provides a quick way to
generate events from that context. The context object also takes care of
sending events to the correct L<Test2::Hub> instance.
=head1 SYNOPSIS
In general you will not be creating contexts directly. To obtain a context you
should always use C<context()> which is exported by the L<Test2::API> module.
use Test2::API qw/context/;
sub my_ok {
my ($bool, $name) = @_;
my $ctx = context();
$ctx->ok($bool, $name);
$ctx->release; # You MUST do this!
return $bool;
}
Context objects make it easy to wrap other tools that also use context. Once
you grab a context, any tool you call before releasing your context will
inherit it:
sub wrapper {
my ($bool, $name) = @_;
my $ctx = context();
$ctx->diag("wrapping my_ok");
my $out = my_ok($bool, $name);
$ctx->release; # You MUST do this!
return $out;
}
=head1 CRITICAL DETAILS
=over 4
=item you MUST always use the context() sub from Test2::API
Creating your own context via C<< Test2::API::Context->new() >> will almost never
produce a desirable result. Use C<context()> which is exported by L<Test2::API>.
There are a handful of cases where a tool author may want to create a new
context by hand, which is why the C<new> method exists. Unless you really know
what you are doing you should avoid this.
=item You MUST always release the context when done with it
Releasing the context tells the system you are done with it. This gives it a
chance to run any necessary callbacks or cleanup tasks. If you forget to
release the context it will try to detect the problem and warn you about it.
=item You MUST NOT pass context objects around
When you obtain a context object it is made specifically for your tool and any
tools nested within. If you pass a context around you run the risk of polluting
other tools with incorrect context information.
If you are certain that you want a different tool to use the same context you
may pass it a snapshot. C<< $ctx->snapshot >> will give you a shallow clone of
the context that is safe to pass around or store.
=item You MUST NOT store or cache a context for later
As long as a context exists for a given hub, all tools that try to get a
context will get the existing instance. If you try to store the context you
will pollute other tools with incorrect context information.
If you are certain that you want to save the context for later, you can use a
snapshot. C<< $ctx->snapshot >> will give you a shallow clone of the context
that is safe to pass around or store.
C<context()> has some mechanisms to protect you if you do cause a context to
persist beyond the scope in which it was obtained. In practice you should not
rely on these protections, and they are fairly noisy with warnings.
=item You SHOULD obtain your context as soon as possible in a given tool
You never know what tools you call from within your own tool will need a
context. Obtaining the context early ensures that nested tools can find the
context you want them to find.
=back
=head1 METHODS
=over 4
=item $ctx->done_testing;
Note that testing is finished. If no plan has been set this will generate a
Plan event.
=item $clone = $ctx->snapshot()
This will return a shallow clone of the context. The shallow clone is safe to
store for later.
=item $ctx->release()
This will release the context. This runs cleanup tasks, and several important
hooks. It will also restore C<$!>, C<$?>, and C<$@> to what they were when the
context was created.
B<Note:> If a context is acquired more than once an internal refcount is kept.
C<release()> decrements the ref count, none of the other actions of
C<release()> will occur unless the refcount hits 0. This means only the last
call to C<release()> will reset C<$?>, C<$!>, C<$@>,and run the cleanup tasks.
=item $ctx->throw($message)
This will throw an exception reporting to the file and line number of the
context. This will also release the context for you.
=item $ctx->alert($message)
This will issue a warning from the file and line number of the context.
=item $stack = $ctx->stack()
This will return the L<Test2::API::Stack> instance the context used to find
the current hub.
=item $hub = $ctx->hub()
This will return the L<Test2::Hub> instance the context recognizes as the
current one to which all events should be sent.
=item $dbg = $ctx->trace()
This will return the L<Test2::EventFacet::Trace> instance used by the context.
=item $ctx->do_in_context(\&code, @args);
Sometimes you have a context that is not current, and you want things to use it
as the current one. In these cases you can call
C<< $ctx->do_in_context(sub { ... }) >>. The codeblock will be run, and
anything inside of it that looks for a context will find the one on which the
method was called.
This B<DOES NOT> affect context on other hubs, only the hub used by the context
will be affected.
my $ctx = ...;
$ctx->do_in_context(sub {
my $ctx = context(); # returns the $ctx the sub is called on
});
B<Note:> The context will actually be cloned, the clone will be used instead of
the original. This allows the thread id, process id, and error variables to be correct without
modifying the original context.
=item $ctx->restore_error_vars()
This will set C<$!>, C<$?>, and C<$@> to what they were when the context was
created. There is no localization or anything done here, calling this method
will actually set these vars.
=item $! = $ctx->errno()
The (numeric) value of C<$!> when the context was created.
=item $? = $ctx->child_error()
The value of C<$?> when the context was created.
=item $@ = $ctx->eval_error()
The value of C<$@> when the context was created.
=back
=head2 EVENT PRODUCTION METHODS
B<Which one do I use?>
The C<pass*> and C<fail*> are optimal if they meet your situation, using one of
them will always be the most optimal. That said they are optimal by eliminating
many features.
Method such as C<ok>, and C<note> are shortcuts for generating common 1-task
events based on the old API, however they are forward compatible, and easy to
use. If these meet your needs then go ahead and use them, but please check back
often for alternatives that may be added.
If you want to generate new style events, events that do many things at once,
then you want the C<*ev2*> methods. These let you directly specify which facets
you wish to use.
=over 4
=item $event = $ctx->pass()
=item $event = $ctx->pass($name)
This will send and return an L<Test2::Event::Pass> event. You may optionally
provide a C<$name> for the assertion.
The L<Test2::Event::Pass> is a specially crafted and optimized event, using
this will help the performance of passing tests.
=item $true = $ctx->pass_and_release()
=item $true = $ctx->pass_and_release($name)
This is a combination of C<pass()> and C<release()>. You can use this if you do
not plan to do anything with the context after sending the event. This helps
write more clear and compact code.
sub shorthand {
my ($bool, $name) = @_;
my $ctx = context();
return $ctx->pass_and_release($name) if $bool;
... Handle a failure ...
}
sub longform {
my ($bool, $name) = @_;
my $ctx = context();
if ($bool) {
$ctx->pass($name);
$ctx->release;
return 1;
}
... Handle a failure ...
}
=item my $event = $ctx->fail()
=item my $event = $ctx->fail($name)
=item my $event = $ctx->fail($name, @diagnostics)
This lets you send an L<Test2::Event::Fail> event. You may optionally provide a
C<$name> and C<@diagnostics> messages.
=item my $false = $ctx->fail_and_release()
=item my $false = $ctx->fail_and_release($name)
=item my $false = $ctx->fail_and_release($name, @diagnostics)
This is a combination of C<fail()> and C<release()>. This can be used to write
clearer and shorter code.
sub shorthand {
my ($bool, $name) = @_;
my $ctx = context();
return $ctx->fail_and_release($name) unless $bool;
... Handle a success ...
}
sub longform {
my ($bool, $name) = @_;
my $ctx = context();
unless ($bool) {
$ctx->pass($name);
$ctx->release;
return 1;
}
... Handle a success ...
}
=item $event = $ctx->ok($bool, $name)
=item $event = $ctx->ok($bool, $name, \@on_fail)
B<NOTE:> Use of this method is discouraged in favor of C<pass()> and C<fail()>
which produce L<Test2::Event::Pass> and L<Test2::Event::Fail> events. These
newer event types are faster and less crufty.
This will create an L<Test2::Event::Ok> object for you. If C<$bool> is false
then an L<Test2::Event::Diag> event will be sent as well with details about the
failure. If you do not want automatic diagnostics you should use the
C<send_event()> method directly.
The third argument C<\@on_fail>) is an optional set of diagnostics to be sent in
the event of a test failure.
=item $event = $ctx->note($message)
Send an L<Test2::Event::Note>. This event prints a message to STDOUT.
=item $event = $ctx->diag($message)
Send an L<Test2::Event::Diag>. This event prints a message to STDERR.
=item $event = $ctx->plan($max)
=item $event = $ctx->plan(0, 'SKIP', $reason)
This can be used to send an L<Test2::Event::Plan> event. This event
usually takes either a number of tests you expect to run. Optionally you can
set the expected count to 0 and give the 'SKIP' directive with a reason to
cause all tests to be skipped.
=item $event = $ctx->skip($name, $reason);
Send an L<Test2::Event::Skip> event.
=item $event = $ctx->bail($reason)
This sends an L<Test2::Event::Bail> event. This event will completely
terminate all testing.
=item $event = $ctx->send_ev2(%facets)
This lets you build and send a V2 event directly from facets. The event is
returned after it is sent.
This example sends a single assertion, a note (comment for stdout in
Test::Builder talk) and sets the plan to 1.
my $event = $ctx->send_event(
plan => {count => 1},
assert => {pass => 1, details => "A passing assert"},
info => [{tag => 'NOTE', details => "This is a note"}],
);
=item $event = $ctx->build_e2(%facets)
This is the same as C<send_ev2()>, except it builds and returns the event
without sending it.
=item $event = $ctx->send_ev2_and_release($Type, %parameters)
This is a combination of C<send_ev2()> and C<release()>.
sub shorthand {
my $ctx = context();
return $ctx->send_ev2_and_release(assert => {pass => 1, details => 'foo'});
}
sub longform {
my $ctx = context();
my $event = $ctx->send_ev2(assert => {pass => 1, details => 'foo'});
$ctx->release;
return $event;
}
=item $event = $ctx->send_event($Type, %parameters)
B<It is better to use send_ev2() in new code.>
This lets you build and send an event of any type. The C<$Type> argument should
be the event package name with C<Test2::Event::> left off, or a fully
qualified package name prefixed with a '+'. The event is returned after it is
sent.
my $event = $ctx->send_event('Ok', ...);
or
my $event = $ctx->send_event('+Test2::Event::Ok', ...);
=item $event = $ctx->build_event($Type, %parameters)
B<It is better to use build_ev2() in new code.>
This is the same as C<send_event()>, except it builds and returns the event
without sending it.
=item $event = $ctx->send_event_and_release($Type, %parameters)
B<It is better to use send_ev2_and_release() in new code.>
This is a combination of C<send_event()> and C<release()>.
sub shorthand {
my $ctx = context();
return $ctx->send_event_and_release(Pass => { name => 'foo' });
}
sub longform {
my $ctx = context();
my $event = $ctx->send_event(Pass => { name => 'foo' });
$ctx->release;
return $event;
}
=back
=head1 HOOKS
There are 2 types of hooks, init hooks, and release hooks. As the names
suggest, these hooks are triggered when contexts are created or released.
=head2 INIT HOOKS
These are called whenever a context is initialized. That means when a new
instance is created. These hooks are B<NOT> called every time something
requests a context, just when a new one is created.
=head3 GLOBAL
This is how you add a global init callback. Global callbacks happen for every
context for any hub or stack.
Test2::API::test2_add_callback_context_init(sub {
my $ctx = shift;
...
});
=head3 PER HUB
This is how you add an init callback for all contexts created for a given hub.
These callbacks will not run for other hubs.
$hub->add_context_init(sub {
my $ctx = shift;
...
});
=head3 PER CONTEXT
This is how you specify an init hook that will only run if your call to
C<context()> generates a new context. The callback will be ignored if
C<context()> is returning an existing context.
my $ctx = context(on_init => sub {
my $ctx = shift;
...
});
=head2 RELEASE HOOKS
These are called whenever a context is released. That means when the last
reference to the instance is about to be destroyed. These hooks are B<NOT>
called every time C<< $ctx->release >> is called.
=head3 GLOBAL
This is how you add a global release callback. Global callbacks happen for every
context for any hub or stack.
Test2::API::test2_add_callback_context_release(sub {
my $ctx = shift;
...
});
=head3 PER HUB
This is how you add a release callback for all contexts created for a given
hub. These callbacks will not run for other hubs.
$hub->add_context_release(sub {
my $ctx = shift;
...
});
=head3 PER CONTEXT
This is how you add release callbacks directly to a context. The callback will
B<ALWAYS> be added to the context that gets returned, it does not matter if a
new one is generated, or if an existing one is returned.
my $ctx = context(on_release => sub {
my $ctx = shift;
...
});
=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>
=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2018 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
PK V�[Lv~qX qX Event.pmnu �[��� package Test2::Event;
use strict;
use warnings;
our $VERSION = '1.302135';
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 hashref's. 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 hashref's 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 2018 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
PK V�[Dǘ.N0 N0 Formatter/TAP.pmnu �[��� package Test2::Formatter::TAP;
use strict;
use warnings;
our $VERSION = '1.302135';
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) }
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}
&& !$ENV{HARNESS_IS_VERBOSE}
&& $hid == OUT_ERR
&& $self->{+_LAST_FH} != $io
&& $msg =~ m/^#\s*Failed 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;
my @order = grep { !$seen{$_}++ } sort 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 $IO = $_->{debug} && !($f->{amnesty} && @{$f->{amnesty}}) ? OUT_ERR : OUT_STD;
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->{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"];
}
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 2018 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
PK V�[L��.2 .2 IPC/Driver/Files.pmnu �[��� package Test2::IPC::Driver::Files;
use strict;
use warnings;
our $VERSION = '1.302135';
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 use_shm { 1 }
sub shm_size() { 64 }
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!");
for my $file (readdir($dh)) {
next if $file =~ m{\.complete$};
next unless $file =~ m{^$hid};
$self->abort_trace("Not all files from hub '$hid' have been collected!");
}
closedir($dh);
}
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(substr($file, -(shm_size)));
}
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 2018 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
PK V�[�i\} }
IPC/Driver.pmnu �[��� package Test2::IPC::Driver;
use strict;
use warnings;
our $VERSION = '1.302135';
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 use_shm { 0 }
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.
=item $false = $self->use_shm
The base class always returns false for this method. You may override it if you
wish to use the SHM made available in L<Test2::API>/L<Test2::API::Instance>.
=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.
# If you are using the SHM you should 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.
# If you are using the SHM you should 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.
=item $bool = $ipc->use_shm()
True if you want to make use of the L<Test2::API>/L<Test2::API::Instance> SHM.
=item $bites = $ipc->shm_size()
Use this to customize the size of the SHM space. There are no guarantees about
what the size will be if you do not implement this.
=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 2018 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
PK V�[e���X �X Hub.pmnu �[��� package Test2::Hub;
use strict;
use warnings;
our $VERSION = '1.302135';
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_all'.
=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 2018 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
PK V�[lU�� � Util/ExternalMeta.pmnu �[��� package Test2::Util::ExternalMeta;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[w���- �- Util/HashBase.pmnu �[��� package Test2::Util::HashBase;
use strict;
use warnings;
our $VERSION = '1.302135';
#################################################################
# #
# 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.006';
*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 %STRIP = (
'^' => 1,
'-' => 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 = $_;
substr($x, 0, 1) = '' if $STRIP{$p};
push @$attr_list => $x;
my ($sub, $attr) = (uc $x, $x);
$sub => ($attr_subs->{$sub} = sub() { $attr }),
$attr => sub { $_[0]->{$attr} },
$p eq '-' ? ("set_$attr" => sub { Carp::croak("'$attr' is read-only") })
: $p eq '^' ? ("set_$attr" => sub { Carp::carp("set_$attr() is deprecated"); $_[0]->{$attr} = $_[1] })
: ("set_$attr" => sub { $_[0]->{$attr} = $_[1] }),
} @_
),
);
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/;
# Chance to initialize defaults
sub init {
my $self = shift; # No other args
$self->{+FOO} ||= "foo";
$self->{+BAR} ||= "bar";
$self->{+BAZ} ||= "baz";
}
sub print {
print join ", " => map { $self->{$_} } FOO, BAR, BAZ;
}
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/bat/;
sub init {
my $self = shift;
# We get the constants from the base class for free.
$self->{+FOO} ||= 'SubFoo';
$self->{+BAT} ||= 'bat';
$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']);
# Accessors!
my $foo = $one->foo; # 'MyFoo'
my $bar = $one->bar; # 'MyBar'
my $baz = $one->baz; # Defaulted to: 'baz'
# 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');
$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
=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 2018 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
PK V�[0��� � Util/Facets2Legacy.pmnu �[��� package Test2::Util::Facets2Legacy;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[��
/S S
Util/Trace.pmnu �[��� package Test2::Util::Trace;
require Test2::EventFacet::Trace;
@ISA = ('Test2::EventFacet::Trace');
our $VERSION = '1.302135';
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 2018 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
PK V�[h��# �#
Tools/Tiny.pmnu �[��� 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.302135';
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 2018 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
PK V�[ 8�ea
a
Formatter.pmnu �[��� package Test2::Formatter;
use strict;
use warnings;
our $VERSION = '1.302135';
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 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 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<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.
=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
=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 2018 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
PK V�[��4 �4 Transition.podnu �[��� =pod
=head1 NAME
Test2::Transition - Transition notes when upgrading to Test2
=head1 DESCRIPTION
This is where gotchas and breakages related to the Test2 upgrade are
documented. The upgrade causes Test::Builder to defer to Test2 under the hood.
This transition is mostly transparent, but there are a few cases that can trip
you up.
=head1 THINGS THAT BREAK
This is the list of scenarios that break with the new internals.
=head2 Test::Builder1.5/2 conditionals
=head3 The Problem
a few years back there were two attempts to upgrade/replace Test::Builder.
Confusingly these were called Test::Builder2 and Test::Builder1.5, in that
order. Many people put conditionals in their code to check the Test::Builder
version number and adapt their code accordingly.
The Test::Builder2/1.5 projects both died out. Now the conditional code people
added has become a mine field. A vast majority of modules broken by Test2 fall
into this category.
=head3 The Fix
The fix is to remove all Test::Builder1.5/2 related code. Either use the
legacy Test::Builder API, or use Test2 directly.
=head2 Replacing the Test::Builder singleton
=head3 The Problem
Some test modules would replace the Test::Builder singleton instance with their
own instance or subclass. This was usually done to intercept or modify results
as they happened.
The Test::Builder singleton is now a simple compatibility wrapper around
Test2. The Test::Builder singleton is no longer the central place for
results. Many results bypass the Test::Builder singleton completely, which
breaks and behavior intended when replacing the singleton.
=head3 The Fix
If you simply want to intercept all results instead of letting them go to TAP,
you should look at the L<Test2::API> docs and read about pushing a new hub onto
the hub stack. Replacing the hub temporarily is now the correct way to
intercept results.
If your goal is purely monitoring of events use the C<< Test2::Hub->listen() >>
method exported by Test::More to watch events as they are fired. If you wish to
modify results before they go to TAP look at the C<< Test2::Hub->filter() >>
method.
=head2 Directly Accessing Hash Elements
=head3 The Problem
Some modules look directly at hash keys on the Test::Builder singleton. The
problem here is that the Test::Builder singleton no longer holds anything
important.
=head3 The Fix
The fix is to use the API specified in L<Test2::API> to look at or modify state
as needed.
=head2 Subtest indentation
=head3 The Problem
An early change, in fact the change that made Test2 an idea, was a change to
the indentation of the subtest note. IT was decided it would be more readable
to outdent the subtest note instead of having it inline with the subtest:
# subtest foo
ok 1 - blah
1..1
ok 1 - subtest foo
The old style indented the note:
# subtest foo
ok 1 - blah
1..1
ok 1 - subtest foo
This breaks tests that do string comparison of TAP output.
=head3 The Fix
my $indent = $INC{'Test2/API.pm'} ? '' : ' ';
is(
$subtest_output,
"${indent}# subtest foo",
"Got subtest note"
);
Check if C<$INC{'Test2/API.pm'}> is set, if it is then no indentation should be
expected. If it is not set than the old Test::Builder is in use, indentation
should be expected.
=head1 DISTRIBUTIONS THAT BREAK OR NEED TO BE UPGRADED
This is a list of cpan modules that have been known to have been broken by the
upgrade at one point.
=head2 WORKS BUT TESTS WILL FAIL
These modules still function correctly, but their test suites will not pass. If
you already have these modules installed then you can continue to use them. If
you are trying to install them after upgrading Test::Builder you will need to
force installation, or bypass the broken tests.
=over 4
=item Test::DBIx::Class::Schema
This module has a test that appears to work around a Test::Builder bug. The bug
appears to have been fixed by Test2, which means the workaround causes a
failure. This can be easily updated, but nobody has done so yet.
Known broken in versions: 1.0.9 and older
=item Test::Kit
This actually works fine, but will not install because L<Test::Aggregate> is in
the dependency chain.
See the L<Test::Aggregate> info below for additional information.
=item Device::Chip
Tests break due to subtest indentation.
Known broken in version 0.07. Apparently works fine in 0.06 though. Patch has
been submitted to fix the issue.
=back
=head2 UPGRADE SUGGESTED
These are modules that did not break, but had broken test suites that have
since been fixed.
=over 4
=item Test::Exception
Old versions work fine, but have a minor test name behavior that breaks with
Test2. Old versions will no longer install because of this. The latest version
on CPAN will install just fine. Upgrading is not required, but is recommended.
Fixed in version: 0.43
=item Data::Peek
Some tests depended on C<$!> and C<$?> being modified in subtle ways. A patch
was applied to correct things that changed.
The module itself works fine, there is no need to upgrade.
Fixed in version: 0.45
=item circular::require
Some tests were fragile and required base.pm to be loaded at a late stage.
Test2 was loading base.pm too early. The tests were updated to fix this.
The module itself never broke, you do not need to upgrade.
Fixed in version: 0.12
=item Test::Module::Used
A test worked around a now-fixed planning bug. There is no need to upgrade if
you have an old version installed. New versions install fine if you want them.
Fixed in version: 0.2.5
=item Test::Moose::More
Some tests were fragile, but have been fixed. The actual breakage was from the
subtest comment indentation change.
No need to upgrade, old versions work fine. Only new versions will install.
Fixed in version: 0.025
=item Test::FITesque
This was broken by a bugfix to how planning is done. The test was updated after
the bugfix.
Fixed in version: 0.04
=item autouse
A test broke because it depended on Scalar::Util not being loaded. Test2 loads
Scalar::Util. The test was updated to load Test2 after checking Scalar::Util's
load status.
There is no need to upgrade if you already have it installed.
Fixed in version: 1.11
=back
=head2 NEED TO UPGRADE
=over 4
=item Test::SharedFork
Old versions need to directly access Test::Builder singleton hash elements. The
latest version on CPAN will still do this on old Test::Builder, but will defer
to L<Test2::IPC> on Test2.
Fixed in version: 0.35
=item Test::Builder::Clutch
This works by doing overriding methods on the singleton, and directly accessing
hash values on the singleton. A new version has been released that uses the
Test2 API to accomplish the same result in a saner way.
Fixed in version: 0.07
=item Test::Dist::VersionSync
This had Test::Builder2 conditionals. This was fixed by removing the
conditionals.
Fixed in version: 1.1.4
=item Test::Modern
This relied on C<< Test::Builder->_try() >> which was a private method,
documented as something nobody should use. This was fixed by using a different
tool.
Fixed in version: 0.012
=item Test::UseAllModules
Version 0.14 relied on C<< Test::Builder->history >> which was available in
Test::Builder 1.5. Versions 0.12 and 0.13 relied on other Test::Builder
internals.
Fixed in version: 0.15
=item Test::More::Prefix
Worked by applying a role that wrapped C<< Test::Builder->_print_comment >>.
Fixed by adding an event filter that modifies the message instead when running
under Test2.
Fixed in version: 0.007
=back
=head2 STILL BROKEN
=over 4
=item Test::Aggregate
This distribution directly accesses the hash keys in the L<Test::Builder>
singleton. It also approaches the problem from the wrong angle, please consider
using L<Test2::Harness> or L<App::ForkProve> which both solve the same problem
at the harness level.
Still broken as of version: 0.373
=item Test::Wrapper
This module directly uses hash keys in the L<Test::Builder> singleton. This
module is also obsolete thanks to the benefits of L<Test2>. Use C<intercept()>
from L<Test2::API> to achieve a similar result.
Still broken as of version: 0.3.0
=item Test::ParallelSubtest
This module overrides C<Test::Builder::subtest()> and
C<Test::Builder::done_testing()>. It also directly accesses hash elements of
the singleton. It has not yet been fixed.
Alternatives: L<Test2::AsyncSubtest> and L<Test2::Workflow> (not stable).
Still broken as of version: 0.05
=item Test::Pretty
See https://github.com/tokuhirom/Test-Pretty/issues/25
The author admits the module is crazy, and he is awaiting a stable release of
something new (Test2) to completely rewrite it in a sane way.
Still broken as of version: 0.32
=item Net::BitTorrent
The tests for this module directly access L<Test::Builder> hash keys. Most, if
not all of these hash keys have public API methods that could be used instead
to avoid the problem.
Still broken in version: 0.052
=item Test::Group
It monkeypatches Test::Builder, and calls it "black magic" in the code.
Still broken as of version: 0.20
=item Test::Flatten
This modifies the Test::Builder internals in many ways. A better was to
accomplish the goal of this module is to write your own subtest function.
Still broken as of version: 0.11
=item Log::Dispatch::Config::TestLog
Modifies Test::Builder internals.
Still broken as of version: 0.02
=item Test::Able
Modifies Test::Builder internals.
Still broken as of version: 0.11
=back
=head1 MAKE ASSERTIONS -> SEND EVENTS
=head2 LEGACY
use Test::Builder;
# A majority of tools out there do this:
# my $TB = Test::Builder->new;
# This works, but has always been wrong, forcing Test::Builder to implement
# subtests as a horrific hack. It also causes problems for tools that try
# to replace the singleton (also discouraged).
sub my_ok($;$) {
my ($bool, $name) = @_;
my $TB = Test::Builder->new;
$TB->ok($bool, $name);
}
sub my_diag($) {
my ($msg) = @_;
my $TB = Test::Builder->new;
$TB->diag($msg);
}
=head2 TEST2
use Test2::API qw/context/;
sub my_ok($;$) {
my ($bool, $name) = @_;
my $ctx = context();
$ctx->ok($bool, $name);
$ctx->release;
}
sub my_diag($) {
my ($msg) = @_;
my $ctx = context();
$ctx->diag($msg);
$ctx->release;
}
The context object has API compatible implementations of the following methods:
=over 4
=item ok($bool, $name)
=item diag(@messages)
=item note(@messages)
=item subtest($name, $code)
=back
If you are looking for helpers with C<is>, C<like>, and others, see
L<Test2::Suite>.
=head1 WRAP EXISTING TOOLS
=head2 LEGACY
use Test::More;
sub exclusive_ok {
my ($bool1, $bool2, $name) = @_;
# Ensure errors are reported 1 level higher
local $Test::Builder::Level = $Test::Builder::Level + 1;
$ok = $bool1 || $bool2;
$ok &&= !($bool1 && $bool2);
ok($ok, $name);
return $bool;
}
Every single tool in the chain from this, to C<ok>, to anything C<ok> calls
needs to increment the C<$Level> variable. When an error occurs Test::Builder
will do a trace to the stack frame determined by C<$Level>, and report that
file+line as the one where the error occurred. If you or any other tool you use
forgets to set C<$Level> then errors will be reported to the wrong place.
=head2 TEST2
use Test::More;
sub exclusive_ok {
my ($bool1, $bool2, $name) = @_;
# Grab and store the context, even if you do not need to use it
# directly.
my $ctx = context();
$ok = $bool1 || $bool2;
$ok &&= !($bool1 && $bool2);
ok($ok, $name);
$ctx->release;
return $bool;
}
Instead of using C<$Level> to perform a backtrace, Test2 uses a context
object. In this sample you create a context object and store it. This locks the
context (errors report 1 level up from here) for all wrapped tools to find. You
do not need to use the context object, but you do need to store it in a
variable. Once the sub ends the C<$ctx> variable is destroyed which lets future
tools find their own.
=head1 USING UTF8
=head2 LEGACY
# Set the mode BEFORE anything loads Test::Builder
use open ':std', ':encoding(utf8)';
use Test::More;
Or
# Modify the filehandles
my $builder = Test::More->builder;
binmode $builder->output, ":encoding(utf8)";
binmode $builder->failure_output, ":encoding(utf8)";
binmode $builder->todo_output, ":encoding(utf8)";
=head2 TEST2
use Test2::API qw/test2_stack/;
test2_stack->top->format->encoding('utf8');
Though a much better way is to use the L<Test2::Plugin::UTF8> plugin, which is
part of L<Test2::Suite>.
=head1 AUTHORS, CONTRIBUTORS AND REVIEWERS
The following people have all contributed to this document in some way, even if
only for review.
=over 4
=item Chad Granum (EXODIST) E<lt>exodist@cpan.orgE<gt>
=back
=head1 SOURCE
The source code repository for Test2 can be found at
F<http://github.com/Test-More/test-more/>.
=head1 MAINTAINER
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2018 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
PK V�[�cҗ, , EventFacet/Control.pmnu �[��� package Test2::EventFacet::Control;
use strict;
use warnings;
our $VERSION = '1.302135';
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding };
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.
=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 2018 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
PK V�[P
�F F EventFacet/Meta.pmnu �[��� package Test2::EventFacet::Meta;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[h�� EventFacet/Error.pmnu �[��� package Test2::EventFacet::Error;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[{0^ ^ EventFacet/Plan.pmnu �[��� package Test2::EventFacet::Plan;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[!�U U EventFacet/Hub.pmnu �[��� package Test2::EventFacet::Hub;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[����� � EventFacet/Render.pmnu �[��� package Test2::EventFacet::Render;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[M �o o EventFacet/Info.pmnu �[��� package Test2::EventFacet::Info;
use strict;
use warnings;
our $VERSION = '1.302135';
sub is_list { 1 }
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{-tag -debug -important};
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.
=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 2018 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
PK V�[&P~�� � EventFacet/About.pmnu �[��� package Test2::EventFacet::About;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[h��� � EventFacet/Trace.pmnu �[��� package Test2::EventFacet::Trace;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[N�t�� � EventFacet/Parent.pmnu �[��� package Test2::EventFacet::Parent;
use strict;
use warnings;
our $VERSION = '1.302135';
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 - Base class for all event facets.
=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 2018 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
PK V�[��_� � EventFacet/Assert.pmnu �[��� package Test2::EventFacet::Assert;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[I�k k EventFacet/Amnesty.pmnu �[��� package Test2::EventFacet::Amnesty;
use strict;
use warnings;
our $VERSION = '1.302135';
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 2018 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
PK V�[��
�� � API.pmnu �[��� package Test2::API;
use strict;
use warnings;
use Test2::Util qw/USE_THREADS/;
BEGIN {
$ENV{TEST_ACTIVE} ||= 1;
$ENV{TEST2_ACTIVE} = 1;
}
our $VERSION = '1.302135';
my $INST;
my $ENDING = 0;
sub test2_set_is_end { ($ENDING) = @_ ? @_ : (1) }
sub test2_get_is_end { $ENDING }
use Test2::API::Instance(\$INST);
# Set the exit status
END {
test2_set_is_end(); # See gh #16
$INST->set_exit();
}
sub CLONE {
my $init = test2_init_done();
my $load = test2_load_done();
return if $init && $load;
require Carp;
Carp::croak "Test2 must be fully loaded before you start a new thread!\n";
}
# See gh #16
{
no warnings;
INIT { eval 'END { test2_set_is_end() }; 1' or die $@ }
}
BEGIN {
no warnings 'once';
if($] ge '5.014' || $ENV{T2_CHECK_DEPTH} || $Test2::API::DO_DEPTH_CHECK) {
*DO_DEPTH_CHECK = sub() { 1 };
}
else {
*DO_DEPTH_CHECK = sub() { 0 };
}
}
use Test2::EventFacet::Trace();
use Test2::Util::Trace(); # Legacy
use Test2::Hub::Subtest();
use Test2::Hub::Interceptor();
use Test2::Hub::Interceptor::Terminator();
use Test2::Event::Ok();
use Test2::Event::Diag();
use Test2::Event::Note();
use Test2::Event::Plan();
use Test2::Event::Bail();
use Test2::Event::Exception();
use Test2::Event::Waiting();
use Test2::Event::Skip();
use Test2::Event::Subtest();
use Carp qw/carp croak confess/;
use Scalar::Util qw/blessed weaken/;
use Test2::Util qw/get_tid clone_io pkg_to_file gen_uid/;
our @EXPORT_OK = qw{
context release
context_do
no_context
intercept intercept_deep
run_subtest
test2_init_done
test2_load_done
test2_load
test2_start_preload
test2_stop_preload
test2_in_preload
test2_set_is_end
test2_get_is_end
test2_pid
test2_tid
test2_stack
test2_no_wait
test2_ipc_wait_enable
test2_ipc_wait_disable
test2_ipc_wait_enabled
test2_add_uuid_via
test2_add_callback_context_aquire
test2_add_callback_context_acquire
test2_add_callback_context_init
test2_add_callback_context_release
test2_add_callback_exit
test2_add_callback_post_load
test2_add_callback_pre_subtest
test2_list_context_aquire_callbacks
test2_list_context_acquire_callbacks
test2_list_context_init_callbacks
test2_list_context_release_callbacks
test2_list_exit_callbacks
test2_list_post_load_callbacks
test2_list_pre_subtest_callbacks
test2_ipc
test2_has_ipc
test2_ipc_disable
test2_ipc_disabled
test2_ipc_drivers
test2_ipc_add_driver
test2_ipc_polling
test2_ipc_disable_polling
test2_ipc_enable_polling
test2_ipc_get_pending
test2_ipc_set_pending
test2_ipc_get_timeout
test2_ipc_set_timeout
test2_ipc_enable_shm
test2_formatter
test2_formatters
test2_formatter_add
test2_formatter_set
test2_stdout
test2_stderr
test2_reset_io
};
BEGIN { require Exporter; our @ISA = qw(Exporter) }
my $STACK = $INST->stack;
my $CONTEXTS = $INST->contexts;
my $INIT_CBS = $INST->context_init_callbacks;
my $ACQUIRE_CBS = $INST->context_acquire_callbacks;
my $STDOUT = clone_io(\*STDOUT);
my $STDERR = clone_io(\*STDERR);
sub test2_stdout { $STDOUT ||= clone_io(\*STDOUT) }
sub test2_stderr { $STDERR ||= clone_io(\*STDERR) }
sub test2_post_preload_reset {
test2_reset_io();
$INST->post_preload_reset;
}
sub test2_reset_io {
$STDOUT = clone_io(\*STDOUT);
$STDERR = clone_io(\*STDERR);
}
sub test2_init_done { $INST->finalized }
sub test2_load_done { $INST->loaded }
sub test2_load { $INST->load }
sub test2_start_preload { $ENV{T2_IN_PRELOAD} = 1; $INST->start_preload }
sub test2_stop_preload { $ENV{T2_IN_PRELOAD} = 0; $INST->stop_preload }
sub test2_in_preload { $INST->preload }
sub test2_pid { $INST->pid }
sub test2_tid { $INST->tid }
sub test2_stack { $INST->stack }
sub test2_ipc_wait_enable { $INST->set_no_wait(0) }
sub test2_ipc_wait_disable { $INST->set_no_wait(1) }
sub test2_ipc_wait_enabled { !$INST->no_wait }
sub test2_no_wait {
$INST->set_no_wait(@_) if @_;
$INST->no_wait;
}
sub test2_add_callback_context_acquire { $INST->add_context_acquire_callback(@_) }
sub test2_add_callback_context_aquire { $INST->add_context_acquire_callback(@_) }
sub test2_add_callback_context_init { $INST->add_context_init_callback(@_) }
sub test2_add_callback_context_release { $INST->add_context_release_callback(@_) }
sub test2_add_callback_exit { $INST->add_exit_callback(@_) }
sub test2_add_callback_post_load { $INST->add_post_load_callback(@_) }
sub test2_add_callback_pre_subtest { $INST->add_pre_subtest_callback(@_) }
sub test2_list_context_aquire_callbacks { @{$INST->context_acquire_callbacks} }
sub test2_list_context_acquire_callbacks { @{$INST->context_acquire_callbacks} }
sub test2_list_context_init_callbacks { @{$INST->context_init_callbacks} }
sub test2_list_context_release_callbacks { @{$INST->context_release_callbacks} }
sub test2_list_exit_callbacks { @{$INST->exit_callbacks} }
sub test2_list_post_load_callbacks { @{$INST->post_load_callbacks} }
sub test2_list_pre_subtest_callbacks { @{$INST->pre_subtest_callbacks} }
sub test2_add_uuid_via {
$INST->set_add_uuid_via(@_) if @_;
$INST->add_uuid_via();
}
sub test2_ipc { $INST->ipc }
sub test2_has_ipc { $INST->has_ipc }
sub test2_ipc_disable { $INST->ipc_disable }
sub test2_ipc_disabled { $INST->ipc_disabled }
sub test2_ipc_add_driver { $INST->add_ipc_driver(@_) }
sub test2_ipc_drivers { @{$INST->ipc_drivers} }
sub test2_ipc_polling { $INST->ipc_polling }
sub test2_ipc_enable_polling { $INST->enable_ipc_polling }
sub test2_ipc_disable_polling { $INST->disable_ipc_polling }
sub test2_ipc_get_pending { $INST->get_ipc_pending }
sub test2_ipc_set_pending { $INST->set_ipc_pending(@_) }
sub test2_ipc_set_timeout { $INST->set_ipc_timeout(@_) }
sub test2_ipc_get_timeout { $INST->ipc_timeout() }
sub test2_ipc_enable_shm { $INST->ipc_enable_shm }
sub test2_formatter {
if ($ENV{T2_FORMATTER} && $ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) {
my $formatter = $1 ? $2 : "Test2::Formatter::$2";
my $file = pkg_to_file($formatter);
require $file;
return $formatter;
}
return $INST->formatter;
}
sub test2_formatters { @{$INST->formatters} }
sub test2_formatter_add { $INST->add_formatter(@_) }
sub test2_formatter_set {
my ($formatter) = @_;
croak "No formatter specified" unless $formatter;
croak "Global Formatter already set" if $INST->formatter_set;
$INST->set_formatter($formatter);
}
# Private, for use in Test2::API::Context
sub _contexts_ref { $INST->contexts }
sub _context_acquire_callbacks_ref { $INST->context_acquire_callbacks }
sub _context_init_callbacks_ref { $INST->context_init_callbacks }
sub _context_release_callbacks_ref { $INST->context_release_callbacks }
sub _add_uuid_via_ref { \($INST->{Test2::API::Instance::ADD_UUID_VIA()}) }
# Private, for use in Test2::IPC
sub _set_ipc { $INST->set_ipc(@_) }
sub context_do(&;@) {
my $code = shift;
my @args = @_;
my $ctx = context(level => 1);
my $want = wantarray;
my @out;
my $ok = eval {
$want ? @out = $code->($ctx, @args) :
defined($want) ? $out[0] = $code->($ctx, @args) :
$code->($ctx, @args) ;
1;
};
my $err = $@;
$ctx->release;
die $err unless $ok;
return @out if $want;
return $out[0] if defined $want;
return;
}
sub no_context(&;$) {
my ($code, $hid) = @_;
$hid ||= $STACK->top->hid;
my $ctx = $CONTEXTS->{$hid};
delete $CONTEXTS->{$hid};
my $ok = eval { $code->(); 1 };
my $err = $@;
$CONTEXTS->{$hid} = $ctx;
weaken($CONTEXTS->{$hid});
die $err unless $ok;
return;
};
my $UUID_VIA = _add_uuid_via_ref();
sub context {
# We need to grab these before anything else to ensure they are not
# changed.
my ($errno, $eval_error, $child_error, $extended_error) = (0 + $!, $@, $?, $^E);
my %params = (level => 0, wrapped => 0, @_);
# If something is getting a context then the sync system needs to be
# considered loaded...
$INST->load unless $INST->{loaded};
croak "context() called, but return value is ignored"
unless defined wantarray;
my $stack = $params{stack} || $STACK;
my $hub = $params{hub} || (@$stack ? $stack->[-1] : $stack->top);
my $hid = $hub->{hid};
my $current = $CONTEXTS->{$hid};
$_->(\%params) for @$ACQUIRE_CBS;
map $_->(\%params), @{$hub->{_context_acquire}} if $hub->{_context_acquire};
# This is for https://github.com/Test-More/test-more/issues/16
# and https://rt.perl.org/Public/Bug/Display.html?id=127774
my $phase = ${^GLOBAL_PHASE} || 'NA';
my $end_phase = $ENDING || $phase eq 'END' || $phase eq 'DESTRUCT';
my $level = 1 + $params{level};
my ($pkg, $file, $line, $sub) = $end_phase ? caller(0) : caller($level);
unless ($pkg || $end_phase) {
confess "Could not find context at depth $level" unless $params{fudge};
($pkg, $file, $line, $sub) = caller(--$level) while ($level >= 0 && !$pkg);
}
my $depth = $level;
$depth++ while DO_DEPTH_CHECK && !$end_phase && (!$current || $depth <= $current->{_depth} + $params{wrapped}) && caller($depth + 1);
$depth -= $params{wrapped};
my $depth_ok = !DO_DEPTH_CHECK || $end_phase || !$current || $current->{_depth} < $depth;
if ($current && $params{on_release} && $depth_ok) {
$current->{_on_release} ||= [];
push @{$current->{_on_release}} => $params{on_release};
}
# I know this is ugly....
($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error) and return bless(
{
%$current,
_is_canon => undef,
errno => $errno,
eval_error => $eval_error,
child_error => $child_error,
_is_spawn => [$pkg, $file, $line, $sub],
},
'Test2::API::Context'
) if $current && $depth_ok;
# Handle error condition of bad level
if ($current) {
unless (${$current->{_aborted}}) {
_canon_error($current, [$pkg, $file, $line, $sub, $depth])
unless $current->{_is_canon};
_depth_error($current, [$pkg, $file, $line, $sub, $depth])
unless $depth_ok;
}
$current->release if $current->{_is_canon};
delete $CONTEXTS->{$hid};
}
# Directly bless the object here, calling new is a noticeable performance
# hit with how often this needs to be called.
my $trace = bless(
{
frame => [$pkg, $file, $line, $sub],
pid => $$,
tid => get_tid(),
cid => gen_uid(),
hid => $hid,
nested => $hub->{nested},
buffered => $hub->{buffered},
$$UUID_VIA ? (
huuid => $hub->{uuid},
uuid => ${$UUID_VIA}->('context'),
) : (),
},
'Test2::EventFacet::Trace'
);
# Directly bless the object here, calling new is a noticeable performance
# hit with how often this needs to be called.
my $aborted = 0;
$current = bless(
{
_aborted => \$aborted,
stack => $stack,
hub => $hub,
trace => $trace,
_is_canon => 1,
_depth => $depth,
errno => $errno,
eval_error => $eval_error,
child_error => $child_error,
$params{on_release} ? (_on_release => [$params{on_release}]) : (),
},
'Test2::API::Context'
);
$CONTEXTS->{$hid} = $current;
weaken($CONTEXTS->{$hid});
$_->($current) for @$INIT_CBS;
map $_->($current), @{$hub->{_context_init}} if $hub->{_context_init};
$params{on_init}->($current) if $params{on_init};
($!, $@, $?, $^E) = ($errno, $eval_error, $child_error, $extended_error);
return $current;
}
sub _depth_error {
_existing_error(@_, <<" EOT");
context() was called to retrieve an existing context, however the existing
context was created in a stack frame at the same, or deeper level. This usually
means that a tool failed to release the context when it was finished.
EOT
}
sub _canon_error {
_existing_error(@_, <<" EOT");
context() was called to retrieve an existing context, however the existing
context has an invalid internal state (!_canon_count). This should not normally
happen unless something is mucking about with internals...
EOT
}
sub _existing_error {
my ($ctx, $details, $msg) = @_;
my ($pkg, $file, $line, $sub, $depth) = @$details;
my $oldframe = $ctx->{trace}->frame;
my $olddepth = $ctx->{_depth};
# Older versions of Carp do not export longmess() function, so it needs to be called with package name
my $mess = Carp::longmess();
warn <<" EOT";
$msg
Old context details:
File: $oldframe->[1]
Line: $oldframe->[2]
Tool: $oldframe->[3]
Depth: $olddepth
New context details:
File: $file
Line: $line
Tool: $sub
Depth: $depth
Trace: $mess
Removing the old context and creating a new one...
EOT
}
sub release($;$) {
$_[0]->release;
return $_[1];
}
sub intercept(&) {
my $code = shift;
my $ctx = context();
my $events = _intercept($code, deep => 0);
$ctx->release;
return $events;
}
sub intercept_deep(&) {
my $code = shift;
my $ctx = context();
my $events = _intercept($code, deep => 1);
$ctx->release;
return $events;
}
sub _intercept {
my $code = shift;
my %params = @_;
my $ctx = context();
my $ipc;
if (my $global_ipc = test2_ipc()) {
my $driver = blessed($global_ipc);
$ipc = $driver->new;
}
my $hub = Test2::Hub::Interceptor->new(
ipc => $ipc,
no_ending => 1,
);
my @events;
$hub->listen(sub { push @events => $_[1] }, inherit => $params{deep});
$ctx->stack->top; # Make sure there is a top hub before we begin.
$ctx->stack->push($hub);
my ($ok, $err) = (1, undef);
T2_SUBTEST_WRAPPER: {
# Do not use 'try' cause it localizes __DIE__
$ok = eval { $code->(hub => $hub, context => $ctx->snapshot); 1 };
$err = $@;
# They might have done 'BEGIN { skip_all => "whatever" }'
if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && $err->isa('Test2::Hub::Interceptor::Terminator'))) {
$ok = 1;
$err = undef;
}
}
$hub->cull;
$ctx->stack->pop($hub);
my $trace = $ctx->trace;
$ctx->release;
die $err unless $ok;
$hub->finalize($trace, 1)
if $ok
&& !$hub->no_ending
&& !$hub->ended;
return \@events;
}
sub run_subtest {
my ($name, $code, $params, @args) = @_;
$_->($name,$code,@args)
for Test2::API::test2_list_pre_subtest_callbacks();
$params = {buffered => $params} unless ref $params;
my $inherit_trace = delete $params->{inherit_trace};
my $ctx = context();
my $parent = $ctx->hub;
# If a parent is buffered then the child must be as well.
my $buffered = $params->{buffered} || $parent->{buffered};
$ctx->note($name) unless $buffered;
my $stack = $ctx->stack || $STACK;
my $hub = $stack->new_hub(
class => 'Test2::Hub::Subtest',
%$params,
buffered => $buffered,
);
my @events;
$hub->listen(sub { push @events => $_[1] });
if ($buffered) {
if (my $format = $hub->format) {
my $hide = $format->can('hide_buffered') ? $format->hide_buffered : 1;
$hub->format(undef) if $hide;
}
}
if ($inherit_trace) {
my $orig = $code;
$code = sub {
my $base_trace = $ctx->trace;
my $trace = $base_trace->snapshot(nested => 1 + $base_trace->nested);
my $st_ctx = Test2::API::Context->new(
trace => $trace,
hub => $hub,
);
$st_ctx->do_in_context($orig, @args);
};
}
my ($ok, $err, $finished);
T2_SUBTEST_WRAPPER: {
# Do not use 'try' cause it localizes __DIE__
$ok = eval { $code->(@args); 1 };
$err = $@;
# They might have done 'BEGIN { skip_all => "whatever" }'
if (!$ok && $err =~ m/Label not found for "last T2_SUBTEST_WRAPPER"/ || (blessed($err) && blessed($err) eq 'Test::Builder::Exception')) {
$ok = undef;
$err = undef;
}
else {
$finished = 1;
}
}
if ($params->{no_fork}) {
if ($$ != $ctx->trace->pid) {
warn $ok ? "Forked inside subtest, but subtest never finished!\n" : $err;
exit 255;
}
if (get_tid() != $ctx->trace->tid) {
warn $ok ? "Started new thread inside subtest, but thread never finished!\n" : $err;
exit 255;
}
}
elsif (!$parent->is_local && !$parent->ipc) {
warn $ok ? "A new process or thread was started inside subtest, but IPC is not enabled!\n" : $err;
exit 255;
}
$stack->pop($hub);
my $trace = $ctx->trace;
my $bailed = $hub->bailed_out;
if (!$finished) {
if ($bailed && !$buffered) {
$ctx->bail($bailed->reason);
}
elsif ($bailed && $buffered) {
$ok = 1;
}
else {
my $code = $hub->exit_code;
$ok = !$code;
$err = "Subtest ended with exit code $code" if $code;
}
}
$hub->finalize($trace->snapshot(huuid => $hub->uuid, hid => $hub->hid, nested => $hub->nested, buffered => $buffered), 1)
if $ok
&& !$hub->no_ending
&& !$hub->ended;
my $pass = $ok && $hub->is_passing;
my $e = $ctx->build_event(
'Subtest',
pass => $pass,
name => $name,
subtest_id => $hub->id,
subtest_uuid => $hub->uuid,
buffered => $buffered,
subevents => \@events,
);
my $plan_ok = $hub->check_plan;
$ctx->hub->send($e);
$ctx->failure_diag($e) unless $e->pass;
$ctx->diag("Caught exception in subtest: $err") unless $ok;
$ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count)
if defined($plan_ok) && !$plan_ok;
$ctx->bail($bailed->reason) if $bailed && $buffered;
$ctx->release;
return $pass;
}
# There is a use-cycle between API and API/Context. Context needs to use some
# API functions as the package is compiling. Test2::API::context() needs
# Test2::API::Context to be loaded, but we cannot 'require' the module there as
# it causes a very noticeable performance impact with how often context() is
# called.
require Test2::API::Context;
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::API - Primary interface for writing Test2 based testing tools.
=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 (once there is
a stable release), but the underlying implementation details might.
B<Do not break encapsulation here!>
Currently the implementation is to create a single instance of the
L<Test2::API::Instance> Object. All class methods defer to the single
instance. There is no public access to the singleton, and that is intentional.
The class methods provided by this package provide the only functionality
publicly exposed.
This is done primarily to avoid the problems Test::Builder had by exposing its
singleton. We do not want anyone to replace this singleton, rebless it, or
directly muck with its internals. If you need to do something and cannot
because of the restrictions placed here, then please report it as an issue. If
possible, we will create a way for you to implement your functionality without
exposing things that should not be exposed.
=head1 DESCRIPTION
This package exports all the functions necessary to write and/or verify testing
tools. Using these building blocks you can begin writing test tools very
quickly. You are also provided with tools that help you to test the tools you
write.
=head1 SYNOPSIS
=head2 WRITING A TOOL
The C<context()> method is your primary interface into the Test2 framework.
package My::Ok;
use Test2::API qw/context/;
our @EXPORT = qw/my_ok/;
use base 'Exporter';
# Just like ok() from Test::More
sub my_ok($;$) {
my ($bool, $name) = @_;
my $ctx = context(); # Get a context
$ctx->ok($bool, $name);
$ctx->release; # Release the context
return $bool;
}
See L<Test2::API::Context> for a list of methods available on the context object.
=head2 TESTING YOUR TOOLS
The C<intercept { ... }> tool lets you temporarily intercept all events
generated by the test system:
use Test2::API qw/intercept/;
use My::Ok qw/my_ok/;
my $events = intercept {
# These events are not displayed
my_ok(1, "pass");
my_ok(0, "fail");
};
my_ok(@$events == 2, "got 2 events, the pass and the fail");
my_ok($events->[0]->pass, "first event passed");
my_ok(!$events->[1]->pass, "second event failed");
=head3 DEEP EVENT INTERCEPTION
Normally C<intercept { ... }> only intercepts events sent to the main hub (as
added by intercept itself). Nested hubs, such as those created by subtests,
will not be intercepted. This is normally what you will still see the nested
events by inspecting the subtest event. However there are times where you want
to verify each event as it is sent, in that case use C<intercept_deep { ... }>.
my $events = intercept_Deep {
buffered_subtest foo => sub {
ok(1, "pass");
};
};
C<$events> in this case will contain 3 items:
=over 4
=item The event from C<ok(1, "pass")>
=item The plan event for the subtest
=item The subtest event itself, with the first 2 events nested inside it as children.
=back
This lets you see the order in which the events were sent, unlike
C<intercept { ... }> which only lets you see events as the main hub sees them.
=head2 OTHER API FUNCTIONS
use Test2::API qw{
test2_init_done
test2_stack
test2_set_is_end
test2_get_is_end
test2_ipc
test2_formatter_set
test2_formatter
};
my $init = test2_init_done();
my $stack = test2_stack();
my $ipc = test2_ipc();
test2_formatter_set($FORMATTER)
my $formatter = test2_formatter();
... And others ...
=head1 MAIN API EXPORTS
All exports are optional. You must specify subs to import.
use Test2::API qw/context intercept run_subtest/;
This is the list of exports that are most commonly needed. If you are simply
writing a tool, then this is probably all you need. If you need something and
you cannot find it here, then you can also look at L</OTHER API EXPORTS>.
These exports lack the 'test2_' prefix because of how important/common they
are. Exports in the L</OTHER API EXPORTS> section have the 'test2_' prefix to
ensure they stand out.
=head2 context(...)
Usage:
=over 4
=item $ctx = context()
=item $ctx = context(%params)
=back
The C<context()> function will always return the current context. If
there is already a context active, it will be returned. If there is not an
active context, one will be generated. When a context is generated it will
default to using the file and line number where the currently running sub was
called from.
Please see L<Test2::API::Context/"CRITICAL DETAILS"> for important rules about
what you can and cannot do with a context once it is obtained.
B<Note> This function will throw an exception if you ignore the context object
it returns.
B<Note> On perls 5.14+ a depth check is used to insure there are no context
leaks. This cannot be safely done on older perls due to
L<https://rt.perl.org/Public/Bug/Display.html?id=127774>
You can forcefully enable it either by setting C<$ENV{T2_CHECK_DEPTH} = 1> or
C<$Test2::API::DO_DEPTH_CHECK = 1> B<BEFORE> loading L<Test2::API>.
=head3 OPTIONAL PARAMETERS
All parameters to C<context> are optional.
=over 4
=item level => $int
If you must obtain a context in a sub deeper than your entry point you can use
this to tell it how many EXTRA stack frames to look back. If this option is not
provided the default of C<0> is used.
sub third_party_tool {
my $sub = shift;
... # Does not obtain a context
$sub->();
...
}
third_party_tool(sub {
my $ctx = context(level => 1);
...
$ctx->release;
});
=item wrapped => $int
Use this if you need to write your own tool that wraps a call to C<context()>
with the intent that it should return a context object.
sub my_context {
my %params = ( wrapped => 0, @_ );
$params{wrapped}++;
my $ctx = context(%params);
...
return $ctx;
}
sub my_tool {
my $ctx = my_context();
...
$ctx->release;
}
If you do not do this, then tools you call that also check for a context will
notice that the context they grabbed was created at the same stack depth, which
will trigger protective measures that warn you and destroy the existing
context.
=item stack => $stack
Normally C<context()> looks at the global hub stack. If you are maintaining
your own L<Test2::API::Stack> instance you may pass it in to be used
instead of the global one.
=item hub => $hub
Use this parameter if you want to obtain the context for a specific hub instead
of whatever one happens to be at the top of the stack.
=item on_init => sub { ... }
This lets you provide a callback sub that will be called B<ONLY> if your call
to C<context()> generated a new context. The callback B<WILL NOT> be called if
C<context()> is returning an existing context. The only argument passed into
the callback will be the context object itself.
sub foo {
my $ctx = context(on_init => sub { 'will run' });
my $inner = sub {
# This callback is not run since we are getting the existing
# context from our parent sub.
my $ctx = context(on_init => sub { 'will NOT run' });
$ctx->release;
}
$inner->();
$ctx->release;
}
=item on_release => sub { ... }
This lets you provide a callback sub that will be called when the context
instance is released. This callback will be added to the returned context even
if an existing context is returned. If multiple calls to context add callbacks,
then all will be called in reverse order when the context is finally released.
sub foo {
my $ctx = context(on_release => sub { 'will run second' });
my $inner = sub {
my $ctx = context(on_release => sub { 'will run first' });
# Neither callback runs on this release
$ctx->release;
}
$inner->();
# Both callbacks run here.
$ctx->release;
}
=back
=head2 release($;$)
Usage:
=over 4
=item release $ctx;
=item release $ctx, ...;
=back
This is intended as a shortcut that lets you release your context and return a
value in one statement. This function will get your context, and an optional
return value. It will release your context, then return your value. Scalar
context is always assumed.
sub tool {
my $ctx = context();
...
return release $ctx, 1;
}
This tool is most useful when you want to return the value you get from calling
a function that needs to see the current context:
my $ctx = context();
my $out = some_tool(...);
$ctx->release;
return $out;
We can combine the last 3 lines of the above like so:
my $ctx = context();
release $ctx, some_tool(...);
=head2 context_do(&;@)
Usage:
sub my_tool {
context_do {
my $ctx = shift;
my (@args) = @_;
$ctx->ok(1, "pass");
...
# No need to call $ctx->release, done for you on scope exit.
} @_;
}
Using this inside your test tool takes care of a lot of boilerplate for you. It
will ensure a context is acquired. It will capture and rethrow any exception. It
will insure the context is released when you are done. It preserves the
subroutine call context (array, scalar, void).
This is the safest way to write a test tool. The only two downsides to this are a
slight performance decrease, and some extra indentation in your source. If the
indentation is a problem for you then you can take a peek at the next section.
=head2 no_context(&;$)
Usage:
=over 4
=item no_context { ... };
=item no_context { ... } $hid;
sub my_tool(&) {
my $code = shift;
my $ctx = context();
...
no_context {
# Things in here will not see our current context, they get a new
# one.
$code->();
};
...
$ctx->release;
};
=back
This tool will hide a context for the provided block of code. This means any
tools run inside the block will get a completely new context if they acquire
one. The new context will be inherited by tools nested below the one that
acquired it.
This will normally hide the current context for the top hub. If you need to
hide the context for a different hub you can pass in the optional C<$hid>
parameter.
=head2 intercept(&)
Usage:
my $events = intercept {
ok(1, "pass");
ok(0, "fail");
...
};
This function takes a codeblock as its only argument, and it has a prototype.
It will execute the codeblock, intercepting any generated events in the
process. It will return an array reference with all the generated event
objects. All events should be subclasses of L<Test2::Event>.
This is a very low-level subtest tool. This is useful for writing tools which
produce subtests. This is not intended for people simply writing tests.
=head2 run_subtest(...)
Usage:
run_subtest($NAME, \&CODE, $BUFFERED, @ARGS)
# or
run_subtest($NAME, \&CODE, \%PARAMS, @ARGS)
This will run the provided codeblock with the args in C<@args>. This codeblock
will be run as a subtest. A subtest is an isolated test state that is condensed
into a single L<Test2::Event::Subtest> event, which contains all events
generated inside the subtest.
=head3 ARGUMENTS:
=over 4
=item $NAME
The name of the subtest.
=item \&CODE
The code to run inside the subtest.
=item $BUFFERED or \%PARAMS
If this is a simple scalar then it will be treated as a boolean for the
'buffered' setting. If this is a hash reference then it will be used as a
parameters hash. The param hash will be used for hub construction (with the
specified keys removed).
Keys that are removed and used by run_subtest:
=over 4
=item 'buffered' => $bool
Toggle buffered status.
=item 'inherit_trace' => $bool
Normally the subtest hub is pushed and the sub is allowed to generate its own
root context for the hub. When this setting is turned on a root context will be
created for the hub that shares the same trace as the current context.
Set this to true if your tool is producing subtests without user-specified
subs.
=item 'no_fork' => $bool
Defaults to off. Normally forking inside a subtest will actually fork the
subtest, resulting in 2 final subtest events. This parameter will turn off that
behavior, only the original process/thread will return a final subtest event.
=back
=item @ARGS
Any extra arguments you want passed into the subtest code.
=back
=head3 BUFFERED VS UNBUFFERED (OR STREAMED)
Normally all events inside and outside a subtest are sent to the formatter
immediately by the hub. Sometimes it is desirable to hold off sending events
within a subtest until the subtest is complete. This usually depends on the
formatter being used.
=over 4
=item Things not effected by this flag
In both cases events are generated and stored in an array. This array is
eventually used to populate the C<subevents> attribute on the
L<Test2::Event::Subtest> event that is generated at the end of the subtest.
This flag has no effect on this part, it always happens.
At the end of the subtest, the final L<Test2::Event::Subtest> event is sent to
the formatter.
=item Things that are effected by this flag
The C<buffered> attribute of the L<Test2::Event::Subtest> event will be set to
the value of this flag. This means any formatter, listener, etc which looks at
the event will know if it was buffered.
=item Things that are formatter dependant
Events within a buffered subtest may or may not be sent to the formatter as
they happen. If a formatter fails to specify then the default is to B<NOT SEND>
the events as they are generated, instead the formatter can pull them from the
C<subevents> attribute.
A formatter can specify by implementing the C<hide_buffered()> method. If this
method returns true then events generated inside a buffered subtest will not be
sent independently of the final subtest event.
=back
An example of how this is used is the L<Test2::Formatter::TAP> formatter. For
unbuffered subtests the events are rendered as they are generated. At the end
of the subtest, the final subtest event is rendered, but the C<subevents>
attribute is ignored. For buffered subtests the opposite occurs, the events are
NOT rendered as they are generated, instead the C<subevents> attribute is used
to render them all at once. This is useful when running subtests tests in
parallel, since without it the output from subtests would be interleaved
together.
=head1 OTHER API EXPORTS
Exports in this section are not commonly needed. These all have the 'test2_'
prefix to help ensure they stand out. You should look at the L</MAIN API
EXPORTS> section before looking here. This section is one where "Great power
comes with great responsibility". It is possible to break things badly if you
are not careful with these.
All exports are optional. You need to list which ones you want at import time:
use Test2::API qw/test2_init_done .../;
=head2 STATUS AND INITIALIZATION STATE
These provide access to internal state and object instances.
=over 4
=item $bool = test2_init_done()
This will return true if the stack and IPC instances have already been
initialized. It will return false if they have not. Init happens as late as
possible. It happens as soon as a tool requests the IPC instance, the
formatter, or the stack.
=item $bool = test2_load_done()
This will simply return the boolean value of the loaded flag. If Test2 has
finished loading this will be true, otherwise false. Loading is considered
complete the first time a tool requests a context.
=item test2_set_is_end()
=item test2_set_is_end($bool)
This is used to toggle Test2's belief that the END phase has already started.
With no arguments this will set it to true. With arguments it will set it to
the first argument's value.
This is used to prevent the use of C<caller()> in END blocks which can cause
segfaults. This is only necessary in some persistent environments that may have
multiple END phases.
=item $bool = test2_get_is_end()
Check if Test2 believes it is the END phase.
=item $stack = test2_stack()
This will return the global L<Test2::API::Stack> instance. If this has not
yet been initialized it will be initialized now.
=item test2_ipc_disable
Disable IPC.
=item $bool = test2_ipc_diabled
Check if IPC is disabled.
=item test2_ipc_wait_enable()
=item test2_ipc_wait_disable()
=item $bool = test2_ipc_wait_enabled()
These can be used to turn IPC waiting on and off, or check the current value of
the flag.
Waiting is turned on by default. Waiting will cause the parent process/thread
to wait until all child processes and threads are finished before exiting. You
will almost never want to turn this off.
=item $bool = test2_no_wait()
=item test2_no_wait($bool)
B<DISCOURAGED>: This is a confusing interface, it is better to use
C<test2_ipc_wait_enable()>, C<test2_ipc_wait_disable()> and
C<test2_ipc_wait_enabled()>.
This can be used to get/set the no_wait status. Waiting is turned on by
default. Waiting will cause the parent process/thread to wait until all child
processes and threads are finished before exiting. You will almost never want
to turn this off.
=item $fh = test2_stdout()
=item $fh = test2_stderr()
These functions return the filehandles that test output should be written to.
They are primarily useful when writing a custom formatter and code that turns
events into actual output (TAP, etc.) They will return a dupe of the original
filehandles that formatted output can be sent to regardless of whatever state
the currently running test may have left STDOUT and STDERR in.
=item test2_reset_io()
Re-dupe the internal filehandles returned by C<test2_stdout()> and
C<test2_stderr()> from the current STDOUT and STDERR. You shouldn't need to do
this except in very peculiar situations (for example, you're testing a new
formatter and you need control over where the formatter is sending its output.)
=back
=head2 BEHAVIOR HOOKS
These are hooks that allow you to add custom behavior to actions taken by Test2
and tools built on top of it.
=over 4
=item test2_add_callback_exit(sub { ... })
This can be used to add a callback that is called after all testing is done. This
is too late to add additional results, the main use of this callback is to set the
exit code.
test2_add_callback_exit(
sub {
my ($context, $exit, \$new_exit) = @_;
...
}
);
The C<$context> passed in will be an instance of L<Test2::API::Context>. The
C<$exit> argument will be the original exit code before anything modified it.
C<$$new_exit> is a reference to the new exit code. You may modify this to
change the exit code. Please note that C<$$new_exit> may already be different
from C<$exit>
=item test2_add_callback_post_load(sub { ... })
Add a callback that will be called when Test2 is finished loading. This
means the callback will be run once, the first time a context is obtained.
If Test2 has already finished loading then the callback will be run immediately.
=item test2_add_callback_context_acquire(sub { ... })
Add a callback that will be called every time someone tries to acquire a
context. This will be called on EVERY call to C<context()>. It gets a single
argument, a reference to 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.
=item test2_add_callback_context_init(sub { ... })
Add a callback that will be called every time a new context is created. The
callback will receive the newly created context as its only argument.
=item test2_add_callback_context_release(sub { ... })
Add a callback that will be called every time a context is released. The
callback will receive the released context as its only argument.
=item test2_add_callback_pre_subtest(sub { ... })
Add a callback that will be called every time a subtest is going to be
run. The callback will receive the subtest name, coderef, and any
arguments.
=item @list = test2_list_context_acquire_callbacks()
Return all the context acquire callback references.
=item @list = test2_list_context_init_callbacks()
Returns all the context init callback references.
=item @list = test2_list_context_release_callbacks()
Returns all the context release callback references.
=item @list = test2_list_exit_callbacks()
Returns all the exit callback references.
=item @list = test2_list_post_load_callbacks()
Returns all the post load callback references.
=item @list = test2_list_pre_subtest_callbacks()
Returns all the pre-subtest callback references.
=item test2_add_uuid_via(sub { ... })
=item $sub = test2_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
=head2 IPC AND CONCURRENCY
These let you access, or specify, the IPC system internals.
=over 4
=item $bool = test2_has_ipc()
Check if IPC is enabled.
=item $ipc = test2_ipc()
This will return the global L<Test2::IPC::Driver> instance. If this has not yet
been initialized it will be initialized now.
=item test2_ipc_add_driver($DRIVER)
Add an IPC driver to the list. This will add the driver to the start of the
list.
=item @drivers = test2_ipc_drivers()
Get the list of IPC drivers.
=item $bool = test2_ipc_polling()
Check if polling is enabled.
=item test2_ipc_enable_polling()
Turn on polling. This will cull events from other processes and threads every
time a context is created.
=item test2_ipc_disable_polling()
Turn off IPC polling.
=item test2_ipc_enable_shm()
Turn on IPC SHM. Only some IPC drivers use this, and most will turn it on
themselves.
=item test2_ipc_set_pending($uniq_val)
Tell other processes and events that an event is pending. C<$uniq_val> should
be a unique value no other thread/process will generate.
B<Note:> After calling this C<test2_ipc_get_pending()> will return 1. This is
intentional, and not avoidable.
=item $pending = test2_ipc_get_pending()
This returns -1 if there is no way to check (assume yes)
This returns 0 if there are (most likely) no pending events.
This returns 1 if there are (likely) pending events. Upon return it will reset,
nothing else will be able to see that there were pending events.
=item $timeout = test2_ipc_get_timeout()
=item test2_ipc_set_timeout($timeout)
Get/Set the timeout value for the IPC system. This timeout is how long the IPC
system will wait for child processes and threads to finish before aborting.
The default value is C<30> seconds.
=back
=head2 MANAGING FORMATTERS
These let you access, or specify, the formatters that can/should be used.
=over 4
=item $formatter = test2_formatter
This will return the global formatter class. This is not an instance. By
default the formatter is set to L<Test2::Formatter::TAP>.
You can override this default using the C<T2_FORMATTER> environment variable.
Normally 'Test2::Formatter::' is prefixed to the value in the
environment variable:
$ T2_FORMATTER='TAP' perl test.t # Use the Test2::Formatter::TAP formatter
$ T2_FORMATTER='Foo' perl test.t # Use the Test2::Formatter::Foo formatter
If you want to specify a full module name you use the '+' prefix:
$ T2_FORMATTER='+Foo::Bar' perl test.t # Use the Foo::Bar formatter
=item test2_formatter_set($class_or_instance)
Set the global formatter class. This can only be set once. B<Note:> This will
override anything specified in the 'T2_FORMATTER' environment variable.
=item @formatters = test2_formatters()
Get a list of all loaded formatters.
=item test2_formatter_add($class_or_instance)
Add a formatter to the list. Last formatter added is used at initialization. If
this is called after initialization a warning will be issued.
=back
=head1 OTHER EXAMPLES
See the C</Examples/> directory included in this distribution.
=head1 SEE ALSO
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 MAGIC
This package has an END block. This END block is responsible for setting the
exit code based on the test results. This end block also calls the callbacks that
can be added to this package.
=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 2018 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
PK V�[����F F IPC.pmnu �[��� package Test2::IPC;
use strict;
use warnings;
our $VERSION = '1.302135';
use Test2::API::Instance;
use Test2::Util qw/get_tid/;
use Test2::API qw{
test2_init_done
test2_ipc
test2_has_ipc
test2_ipc_enable_polling
test2_pid
test2_stack
test2_tid
context
};
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 2018 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
PK V�[�%�=� �
EventFacet.pmnu �[��� PK V�[��L�( �( Util.pmnu �[��� PK V�[ �\s} } E/ Event/Subtest.pmnu �[��� PK V�[.y�� < Event/Generic.pmnu �[��� PK V�[K�� �
WS Event/Pass.pmnu �[��� PK V�[ RB6� � "[ Event/V2.pmnu �[��� PK V�[&�7� �
'n Event/Bail.pmnu �[��� PK V�[� L�� � u Event/Encoding.pmnu �[��� PK V�[d��<
<
.| Event/Plan.pmnu �[��� PK V�[�Q��S S �� Event/Ok.pmnu �[��� PK V�[�v� � 5� Event/Exception.pmnu �[��� PK V�[yx�� � l� Event/Waiting.pmnu �[��� PK V�[R�/� �
�� Event/Note.pmnu �[��� PK V�[.��R� �
H� Event/Fail.pmnu �[��� PK V�[XA
�l l g� Event/TAP/Version.pmnu �[��� PK V�[G'L[� �
� Event/Diag.pmnu �[��� PK V�[>�i�� �
� Event/Skip.pmnu �[��� PK V�[h�)7P
P
� Hub/Subtest.pmnu �[��� PK V�[*���� � �� Hub/Interceptor/Terminator.pmnu �[��� PK V�[�L�� � �� Hub/Interceptor.pmnu �[��� PK V�[���g_ _ �� API/Instance.pmnu �[��� PK V�[�:JE� � n7 API/Stack.pmnu �[��� PK V�[�x� � SJ API/Breakage.pmnu �[��� PK V�[o
�,�g �g ] API/Context.pmnu �[��� PK V�[Lv~qX qX �� Event.pmnu �[��� PK V�[Dǘ.N0 N0 � Formatter/TAP.pmnu �[��� PK V�[L��.2 .2 #N IPC/Driver/Files.pmnu �[��� PK V�[�i\} }
�� IPC/Driver.pmnu �[��� PK V�[e���X �X N� Hub.pmnu �[��� PK V�[lU�� � z� Util/ExternalMeta.pmnu �[��� PK V�[w���- �- � Util/HashBase.pmnu �[��� PK V�[0��� � �2 Util/Facets2Legacy.pmnu �[��� PK V�[��
/S S
�M Util/Trace.pmnu �[��� PK V�[h��# �#
[Q Tools/Tiny.pmnu �[��� PK V�[ 8�ea
a
Mu Formatter.pmnu �[��� PK V�[λ���4 �4 � Transition.podnu �[��� PK V�[�cҗ, , η EventFacet/Control.pmnu �[��� PK V�[P
�F F ?� EventFacet/Meta.pmnu �[��� PK V�[h�� �� EventFacet/Error.pmnu �[��� PK V�[{0^ ^ � EventFacet/Plan.pmnu �[��� PK V�[!�U U �� EventFacet/Hub.pmnu �[��� PK V�[����� � K� EventFacet/Render.pmnu �[��� PK V�[M �o o �� EventFacet/Info.pmnu �[��� PK V�[&P~�� � ?� EventFacet/About.pmnu �[��� PK V�[h��� � N� EventFacet/Trace.pmnu �[��� PK V�[N�t�� � J EventFacet/Parent.pmnu �[��� PK V�[��_� � ^ EventFacet/Assert.pmnu �[��� PK V�[I�k k R EventFacet/Amnesty.pmnu �[��� PK V�[��
�� � ! API.pmnu �[��� PK V�[����F F S� IPC.pmnu �[��� PK 2 2 ~ ��