GSP/Panel
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

Added Cyg-Win

Browse source
This commit is contained in:
Frank Harris 2026-06-06 18:46:40 -04:00
parent 82cbc206eb
commit 413c315806
10586 changed files with 3806249 additions and 0 deletions
Download patch file Download diff file Expand all files Collapse all files

1718
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/API.pm Normal file
View file

File diff suppressed because it is too large Load diff

180
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/API/Breakage.pm Normal file
View file

@ -0,0 +1,180 @@
package Test2::API::Breakage;
use strict;
use warnings;
our $VERSION = '1.302199';
use Test2::Util qw/pkg_to_file/;
our @EXPORT_OK = qw{
upgrade_suggested
upgrade_required
known_broken
};
BEGIN { require Exporter; our @ISA = qw(Exporter) }
sub upgrade_suggested {
return (
'Test::Exception' => '0.42',
'Test::FITesque' => '0.04',
'Test::Module::Used' => '0.2.5',
'Test::Moose::More' => '0.025',
);
}
sub upgrade_required {
return (
'Test::Builder::Clutch' => '0.07',
'Test::Dist::VersionSync' => '1.1.4',
'Test::Modern' => '0.012',
'Test::SharedFork' => '0.34',
'Test::Alien' => '0.04',
'Test::UseAllModules' => '0.14',
'Test::More::Prefix' => '0.005',
'Test2::Tools::EventDumper' => 0.000007,
'Test2::Harness' => 0.000013,
'Test::DBIx::Class::Schema' => '1.0.9',
'Test::Clustericious::Cluster' => '0.30',
);
}
sub known_broken {
return (
'Net::BitTorrent' => '0.052',
'Test::Able' => '0.11',
'Test::Aggregate' => '0.373',
'Test::Flatten' => '0.11',
'Test::Group' => '0.20',
'Test::ParallelSubtest' => '0.05',
'Test::Pretty' => '0.32',
'Test::Wrapper' => '0.3.0',
'Log::Dispatch::Config::TestLog' => '0.02',
);
}
# Not reportable:
# Device::Chip => 0.07 - Tests will not pass, but not broken if already installed, also no fixed version we can upgrade to.
sub report {
my $class = shift;
my ($require) = @_;
my %suggest = __PACKAGE__->upgrade_suggested();
my %required = __PACKAGE__->upgrade_required();
my %broken = __PACKAGE__->known_broken();
my @warn;
for my $mod (keys %suggest) {
my $file = pkg_to_file($mod);
next unless $INC{$file} || ($require && eval { require $file; 1 });
my $want = $suggest{$mod};
next if eval { $mod->VERSION($want); 1 };
my $error = $@;
chomp $error;
push @warn => " * Module '$mod' is outdated, we recommend updating above $want. error was: '$error'; INC is $INC{$file}";
}
for my $mod (keys %required) {
my $file = pkg_to_file($mod);
next unless $INC{$file} || ($require && eval { require $file; 1 });
my $want = $required{$mod};
next if eval { $mod->VERSION($want); 1 };
push @warn => " * Module '$mod' is outdated and known to be broken, please update to $want or higher.";
}
for my $mod (keys %broken) {
my $file = pkg_to_file($mod);
next unless $INC{$file} || ($require && eval { require $file; 1 });
my $tested = $broken{$mod};
push @warn => " * Module '$mod' is known to be broken in version $tested and below, newer versions have not been tested. You have: " . $mod->VERSION;
}
return @warn;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::API::Breakage - What breaks at what version
=head1 DESCRIPTION
This module provides lists of modules that are broken, or have been broken in
the past, when upgrading L<Test::Builder> to use L<Test2>.
=head1 FUNCTIONS
These can be imported, or called as methods on the class.
=over 4
=item %mod_ver = upgrade_suggested()
=item %mod_ver = Test2::API::Breakage->upgrade_suggested()
This returns key/value pairs. The key is the module name, the value is the
version number. If the installed version of the module is at or below the
specified one then an upgrade would be a good idea, but not strictly necessary.
=item %mod_ver = upgrade_required()
=item %mod_ver = Test2::API::Breakage->upgrade_required()
This returns key/value pairs. The key is the module name, the value is the
version number. If the installed version of the module is at or below the
specified one then an upgrade is required for the module to work properly.
=item %mod_ver = known_broken()
=item %mod_ver = Test2::API::Breakage->known_broken()
This returns key/value pairs. The key is the module name, the value is the
version number. If the installed version of the module is at or below the
specified one then the module will not work. A newer version may work, but is
not tested or verified.
=back
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

1018
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/API/Context.pm Normal file
View file

File diff suppressed because it is too large Load diff

830
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/API/Instance.pm Normal file
View file

@ -0,0 +1,830 @@
package Test2::API::Instance;
use strict;
use warnings;
our $VERSION = '1.302199';
our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/;
use Carp qw/confess carp/;
use Scalar::Util qw/reftype/;
use Test2::Util qw/get_tid USE_THREADS CAN_FORK pkg_to_file try CAN_SIGSYS/;
use Test2::EventFacet::Trace();
use Test2::API::Stack();
use Test2::Util::HashBase qw{
_pid _tid
no_wait
finalized loaded
ipc stack formatter
contexts
add_uuid_via
-preload
ipc_disabled
ipc_polling
ipc_drivers
ipc_timeout
formatters
exit_callbacks
post_load_callbacks
context_acquire_callbacks
context_init_callbacks
context_release_callbacks
pre_subtest_callbacks
trace_stamps
};
sub DEFAULT_IPC_TIMEOUT() { 30 }
sub test2_enable_trace_stamps { $_[0]->{+TRACE_STAMPS} = 1 }
sub test2_disable_trace_stamps { $_[0]->{+TRACE_STAMPS} = 0 }
sub test2_trace_stamps_enabled { $_[0]->{+TRACE_STAMPS} }
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->{+TRACE_STAMPS} = $ENV{T2_TRACE_STAMPS} || 0;
$self->{+ADD_UUID_VIA} = undef;
$self->{+CONTEXTS} = {};
$self->{+IPC_DRIVERS} = [];
$self->{+IPC_POLLING} = undef;
$self->{+FORMATTERS} = [];
$self->{+FORMATTER} = undef;
$self->{+FINALIZED} = undef;
$self->{+IPC} = undef;
$self->{+IPC_DISABLED} = $ENV{T2_NO_IPC} ? 1 : 0;
$self->{+IPC_TIMEOUT} = DEFAULT_IPC_TIMEOUT() unless defined $self->{+IPC_TIMEOUT};
$self->{+NO_WAIT} = 0;
$self->{+LOADED} = 0;
$self->{+EXIT_CALLBACKS} = [];
$self->{+POST_LOAD_CALLBACKS} = [];
$self->{+CONTEXT_ACQUIRE_CALLBACKS} = [];
$self->{+CONTEXT_INIT_CALLBACKS} = [];
$self->{+CONTEXT_RELEASE_CALLBACKS} = [];
$self->{+PRE_SUBTEST_CALLBACKS} = [];
$self->{+STACK} = Test2::API::Stack->new;
}
sub _finalize {
my $self = shift;
my ($caller) = @_;
$caller ||= [caller(1)];
confess "Attempt to initialize Test2::API during preload"
if $self->{+PRELOAD};
$self->{+FINALIZED} = $caller;
$self->{+_PID} = $$ unless defined $self->{+_PID};
$self->{+_TID} = get_tid() unless defined $self->{+_TID};
unless ($self->{+FORMATTER}) {
my ($formatter, $source);
if ($ENV{T2_FORMATTER}) {
$source = "set by the 'T2_FORMATTER' environment variable";
if ($ENV{T2_FORMATTER} =~ m/^(\+)?(.*)$/) {
$formatter = $1 ? $2 : "Test2::Formatter::$2"
}
else {
$formatter = '';
}
}
elsif (@{$self->{+FORMATTERS}}) {
($formatter) = @{$self->{+FORMATTERS}};
$source = "Most recently added";
}
else {
$formatter = 'Test2::Formatter::TAP';
$source = 'default formatter';
}
unless (ref($formatter) || $formatter->can('write')) {
my $file = pkg_to_file($formatter);
my ($ok, $err) = try { require $file };
unless ($ok) {
my $line = "* COULD NOT LOAD FORMATTER '$formatter' ($source) *";
my $border = '*' x length($line);
die "\n\n $border\n $line\n $border\n\n$err";
}
}
$self->{+FORMATTER} = $formatter;
}
# Turn on IPC if threads are on, drivers are registered, or the Test2::IPC
# module is loaded.
return if $self->{+IPC_DISABLED};
return unless USE_THREADS || $INC{'Test2/IPC.pm'} || @{$self->{+IPC_DRIVERS}};
# Turn on polling by default, people expect it.
$self->enable_ipc_polling;
unless (@{$self->{+IPC_DRIVERS}}) {
my ($ok, $error) = try { require Test2::IPC::Driver::Files };
die $error unless $ok;
push @{$self->{+IPC_DRIVERS}} => 'Test2::IPC::Driver::Files';
}
for my $driver (@{$self->{+IPC_DRIVERS}}) {
next unless $driver->can('is_viable') && $driver->is_viable;
$self->{+IPC} = $driver->new or next;
return;
}
die "IPC has been requested, but no viable drivers were found. Aborting...\n";
}
sub formatter_set { $_[0]->{+FORMATTER} ? 1 : 0 }
sub add_formatter {
my $self = shift;
my ($formatter) = @_;
unshift @{$self->{+FORMATTERS}} => $formatter;
return unless $self->{+FINALIZED};
# Why is the @CARP_NOT entry not enough?
local %Carp::Internal = %Carp::Internal;
$Carp::Internal{'Test2::Formatter'} = 1;
carp "Formatter $formatter loaded too late to be used as the global formatter";
}
sub add_context_acquire_callback {
my $self = shift;
my ($code) = @_;
my $rtype = reftype($code) || "";
confess "Context-acquire callbacks must be coderefs"
unless $code && $rtype eq 'CODE';
push @{$self->{+CONTEXT_ACQUIRE_CALLBACKS}} => $code;
}
sub add_context_init_callback {
my $self = shift;
my ($code) = @_;
my $rtype = reftype($code) || "";
confess "Context-init callbacks must be coderefs"
unless $code && $rtype eq 'CODE';
push @{$self->{+CONTEXT_INIT_CALLBACKS}} => $code;
}
sub add_context_release_callback {
my $self = shift;
my ($code) = @_;
my $rtype = reftype($code) || "";
confess "Context-release callbacks must be coderefs"
unless $code && $rtype eq 'CODE';
push @{$self->{+CONTEXT_RELEASE_CALLBACKS}} => $code;
}
sub add_post_load_callback {
my $self = shift;
my ($code) = @_;
my $rtype = reftype($code) || "";
confess "Post-load callbacks must be coderefs"
unless $code && $rtype eq 'CODE';
push @{$self->{+POST_LOAD_CALLBACKS}} => $code;
$code->() if $self->{+LOADED};
}
sub add_pre_subtest_callback {
my $self = shift;
my ($code) = @_;
my $rtype = reftype($code) || "";
confess "Pre-subtest callbacks must be coderefs"
unless $code && $rtype eq 'CODE';
push @{$self->{+PRE_SUBTEST_CALLBACKS}} => $code;
}
sub load {
my $self = shift;
unless ($self->{+LOADED}) {
confess "Attempt to initialize Test2::API during preload"
if $self->{+PRELOAD};
$self->{+_PID} = $$ unless defined $self->{+_PID};
$self->{+_TID} = get_tid() unless defined $self->{+_TID};
# This is for https://github.com/Test-More/test-more/issues/16
# and https://rt.perl.org/Public/Bug/Display.html?id=127774
# END blocks run in reverse order. This insures the END block is loaded
# as late as possible. It will not solve all cases, but it helps.
eval "END { Test2::API::test2_set_is_end() }; 1" or die $@;
$self->{+LOADED} = 1;
$_->() for @{$self->{+POST_LOAD_CALLBACKS}};
}
return $self->{+LOADED};
}
sub add_exit_callback {
my $self = shift;
my ($code) = @_;
my $rtype = reftype($code) || "";
confess "End callbacks must be coderefs"
unless $code && $rtype eq 'CODE';
push @{$self->{+EXIT_CALLBACKS}} => $code;
}
sub ipc_disable {
my $self = shift;
confess "Attempt to disable IPC after it has been initialized"
if $self->{+IPC};
$self->{+IPC_DISABLED} = 1;
}
sub add_ipc_driver {
my $self = shift;
my ($driver) = @_;
unshift @{$self->{+IPC_DRIVERS}} => $driver;
return unless $self->{+FINALIZED};
# Why is the @CARP_NOT entry not enough?
local %Carp::Internal = %Carp::Internal;
$Carp::Internal{'Test2::IPC::Driver'} = 1;
carp "IPC driver $driver loaded too late to be used as the global ipc driver";
}
sub enable_ipc_polling {
my $self = shift;
$self->{+_PID} = $$ unless defined $self->{+_PID};
$self->{+_TID} = get_tid() unless defined $self->{+_TID};
$self->add_context_init_callback(
# This is called every time a context is created, it needs to be fast.
# $_[0] is a context object
sub {
return unless $self->{+IPC_POLLING};
return unless $self->{+IPC};
return unless $self->{+IPC}->pending();
return $_[0]->{hub}->cull;
}
) unless defined $self->ipc_polling;
$self->set_ipc_polling(1);
}
sub get_ipc_pending {
my $self = shift;
return -1 unless $self->{+IPC};
$self->{+IPC}->pending();
}
sub _check_pid {
my $self = shift;
my ($pid) = @_;
return kill(0, $pid);
}
sub set_ipc_pending {
my $self = shift;
return unless $self->{+IPC};
my ($val) = @_;
confess "value is required for set_ipc_pending"
unless $val;
$self->{+IPC}->set_pending($val);
}
sub disable_ipc_polling {
my $self = shift;
return unless defined $self->{+IPC_POLLING};
$self->{+IPC_POLLING} = 0;
}
sub _ipc_wait {
my ($timeout) = @_;
my $fail = 0;
$timeout = DEFAULT_IPC_TIMEOUT() unless defined $timeout;
my $ok = eval {
if (CAN_FORK) {
local $SIG{ALRM} = sub { die "Timeout waiting on child processes" };
alarm $timeout;
while (1) {
my $pid = CORE::wait();
my $err = $?;
last if $pid == -1;
next unless $err;
$fail++;
my $sig = $err & 127;
my $exit = $err >> 8;
warn "Process $pid did not exit cleanly (wstat: $err, exit: $exit, sig: $sig)\n";
}
alarm 0;
}
if (USE_THREADS) {
my $start = time;
while (1) {
last unless threads->list();
die "Timeout waiting on child thread" if time - $start >= $timeout;
sleep 1;
for my $t (threads->list) {
# threads older than 1.34 do not have this :-(
next if $t->can('is_joinable') && !$t->is_joinable;
$t->join;
# In older threads we cannot check if a thread had an error unless
# we control it and its return.
my $err = $t->can('error') ? $t->error : undef;
next unless $err;
my $tid = $t->tid();
$fail++;
chomp($err);
warn "Thread $tid did not end cleanly: $err\n";
}
}
}
1;
};
my $error = $@;
return 0 if $ok && !$fail;
warn $error unless $ok;
return 255;
}
sub set_exit {
my $self = shift;
return if $self->{+PRELOAD};
my $exit = $?;
my $new_exit = $exit;
if ($INC{'Test/Builder.pm'} && $Test::Builder::VERSION ne $Test2::API::VERSION) {
print STDERR <<" EOT";
********************************************************************************
* *
* Test::Builder -- Test2::API version mismatch detected *
* *
********************************************************************************
Test2::API Version: $Test2::API::VERSION
Test::Builder Version: $Test::Builder::VERSION
This is not a supported configuration, you will have problems.
EOT
}
for my $ctx (values %{$self->{+CONTEXTS}}) {
next unless $ctx;
next if $ctx->_aborted && ${$ctx->_aborted};
# Only worry about contexts in this PID
my $trace = $ctx->trace || next;
next unless $trace->pid && $trace->pid == $$;
# Do not worry about contexts that have no hub
my $hub = $ctx->hub || next;
# Do not worry if the state came to a sudden end.
next if $hub->bailed_out;
next if defined $hub->skip_reason;
# now we worry
$trace->alert("context object was never released! This means a testing tool is behaving very badly");
$exit = 255;
$new_exit = 255;
}
if (!defined($self->{+_PID}) or !defined($self->{+_TID}) or $self->{+_PID} != $$ or $self->{+_TID} != get_tid()) {
$? = $exit;
return;
}
my @hubs = $self->{+STACK} ? $self->{+STACK}->all : ();
if (@hubs and $self->{+IPC} and !$self->{+NO_WAIT}) {
local $?;
my %seen;
for my $hub (reverse @hubs) {
my $ipc = $hub->ipc or next;
next if $seen{$ipc}++;
$ipc->waiting();
}
my $ipc_exit = _ipc_wait($self->{+IPC_TIMEOUT});
$new_exit ||= $ipc_exit;
}
# None of this is necessary if we never got a root hub
if(my $root = shift @hubs) {
my $trace = Test2::EventFacet::Trace->new(
frame => [__PACKAGE__, __FILE__, 0, __PACKAGE__ . '::END'],
detail => __PACKAGE__ . ' END Block finalization',
);
my $ctx = Test2::API::Context->new(
trace => $trace,
hub => $root,
);
if (@hubs) {
$ctx->diag("Test ended with extra hubs on the stack!");
$new_exit = 255;
}
unless ($root->no_ending) {
local $?;
$root->finalize($trace) unless $root->ended;
$_->($ctx, $exit, \$new_exit) for @{$self->{+EXIT_CALLBACKS}};
$new_exit ||= $root->failed;
$new_exit ||= 255 unless $root->is_passing;
}
}
$new_exit = 255 if $new_exit > 255;
if ($new_exit && eval { require Test2::API::Breakage; 1 }) {
my @warn = Test2::API::Breakage->report();
if (@warn) {
print STDERR "\nYou have loaded versions of test modules known to have problems with Test2.\nThis could explain some test failures.\n";
print STDERR "$_\n" for @warn;
print STDERR "\n";
}
}
$? = $new_exit;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::API::Instance - Object used by Test2::API under the hood
=head1 DESCRIPTION
This object encapsulates the global shared state tracked by
L<Test2>. A single global instance of this package is stored (and
obscured) by the L<Test2::API> package.
There is no reason to directly use this package. This package is documented for
completeness. This package can change, or go away completely at any time.
Directly using, or monkeypatching this package is not supported in any way
shape or form.
=head1 SYNOPSIS
use Test2::API::Instance;
my $obj = Test2::API::Instance->new;
=over 4
=item $pid = $obj->pid
PID of this instance.
=item $obj->tid
Thread ID of this instance.
=item $obj->reset()
Reset the object to defaults.
=item $obj->load()
Set the internal state to loaded, and run and stored post-load callbacks.
=item $bool = $obj->loaded
Check if the state is set to loaded.
=item $arrayref = $obj->post_load_callbacks
Get the post-load callbacks.
=item $obj->add_post_load_callback(sub { ... })
Add a post-load callback. If C<load()> has already been called then the callback will
be immediately executed. If C<load()> has not been called then the callback will be
stored and executed later when C<load()> is called.
=item $hashref = $obj->contexts()
Get a hashref of all active contexts keyed by hub id.
=item $arrayref = $obj->context_acquire_callbacks
Get all context acquire callbacks.
=item $arrayref = $obj->context_init_callbacks
Get all context init callbacks.
=item $arrayref = $obj->context_release_callbacks
Get all context release callbacks.
=item $arrayref = $obj->pre_subtest_callbacks
Get all pre-subtest callbacks.
=item $obj->add_context_init_callback(sub { ... })
Add a context init callback. Subs are called every time a context is created. Subs
get the newly created context as their only argument.
=item $obj->add_context_release_callback(sub { ... })
Add a context release callback. Subs are called every time a context is released. Subs
get the released context as their only argument. These callbacks should not
call release on the context.
=item $obj->add_pre_subtest_callback(sub { ... })
Add a pre-subtest callback. Subs are called every time a subtest is
going to be run. Subs get the subtest name, coderef, and any
arguments.
=item $obj->set_exit()
This is intended to be called in an C<END { ... }> block. This will look at
test state and set $?. This will also call any end callbacks, and wait on child
processes/threads.
=item $obj->set_ipc_pending($val)
Tell other processes and threads there is a pending event. C<$val> should be a
unique value no other thread/process will generate.
B<Note:> This will also make the current process see a pending event.
=item $pending = $obj->get_ipc_pending()
This returns -1 if it is not possible to know.
This returns 0 if there are no pending events.
This returns 1 if there are pending events.
=item $timeout = $obj->ipc_timeout;
=item $obj->set_ipc_timeout($timeout);
How long to wait for child processes and threads before aborting.
=item $drivers = $obj->ipc_drivers
Get the list of IPC drivers.
=item $obj->add_ipc_driver($DRIVER_CLASS)
Add an IPC driver to the list. The most recently added IPC driver will become
the global one during initialization. If a driver is added after initialization
has occurred a warning will be generated:
"IPC driver $driver loaded too late to be used as the global ipc driver"
=item $bool = $obj->ipc_polling
Check if polling is enabled.
=item $obj->enable_ipc_polling
Turn on polling. This will cull events from other processes and threads every
time a context is created.
=item $obj->disable_ipc_polling
Turn off IPC polling.
=item $bool = $obj->no_wait
=item $bool = $obj->set_no_wait($bool)
Get/Set no_wait. This option is used to turn off process/thread waiting at exit.
=item $arrayref = $obj->exit_callbacks
Get the exit callbacks.
=item $obj->add_exit_callback(sub { ... })
Add an exit callback. This callback will be called by C<set_exit()>.
=item $bool = $obj->finalized
Check if the object is finalized. Finalization happens when either C<ipc()>,
C<stack()>, or C<format()> are called on the object. Once finalization happens
these fields are considered unchangeable (not enforced here, enforced by
L<Test2>).
=item $ipc = $obj->ipc
Get the one true IPC instance.
=item $obj->ipc_disable
Turn IPC off
=item $bool = $obj->ipc_disabled
Check if IPC is disabled
=item $stack = $obj->stack
Get the one true hub stack.
=item $formatter = $obj->formatter
Get the global formatter. By default this is the C<'Test2::Formatter::TAP'>
package. This could be any package that implements the C<write()> method. This
can also be an instantiated object.
=item $bool = $obj->formatter_set()
Check if a formatter has been set.
=item $obj->add_formatter($class)
=item $obj->add_formatter($obj)
Add a formatter. The most recently added formatter will become the global one
during initialization. If a formatter is added after initialization has occurred
a warning will be generated:
"Formatter $formatter loaded too late to be used as the global formatter"
=item $obj->set_add_uuid_via(sub { ... })
=item $sub = $obj->add_uuid_via()
This allows you to provide a UUID generator. If provided UUIDs will be attached
to all events, hubs, and contexts. This is useful for storing, tracking, and
linking these objects.
The sub you provide should always return a unique identifier. Most things will
expect a proper UUID string, however nothing in Test2::API enforces this.
The sub will receive exactly 1 argument, the type of thing being tagged
'context', 'hub', or 'event'. In the future additional things may be tagged, in
which case new strings will be passed in. These are purely informative, you can
(and usually should) ignore them.
=back
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

634
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/API/InterceptResult.pm Normal file
View file

@ -0,0 +1,634 @@
package Test2::API::InterceptResult;
use strict;
use warnings;
our $VERSION = '1.302199';
use Scalar::Util qw/blessed/;
use Test2::Util qw/pkg_to_file/;
use Storable qw/dclone/;
use Carp qw/croak/;
use Test2::API::InterceptResult::Squasher;
use Test2::API::InterceptResult::Event;
use Test2::API::InterceptResult::Hub;
sub new {
croak "Called a method that creates a new instance in void context" unless defined wantarray;
my $class = shift;
bless([@_], $class);
}
sub new_from_ref {
croak "Called a method that creates a new instance in void context" unless defined wantarray;
bless($_[1], $_[0]);
}
sub clone { blessed($_[0])->new(@{dclone($_[0])}) }
sub event_list { @{$_[0]} }
sub _upgrade {
my $self = shift;
my ($event, %params) = @_;
my $blessed = blessed($event);
my $upgrade_class = $params{upgrade_class} ||= 'Test2::API::InterceptResult::Event';
return $event if $blessed && $event->isa($upgrade_class) && !$params{_upgrade_clone};
my $fd = dclone($blessed ? $event->facet_data : $event);
my $class = $params{result_class} ||= blessed($self);
if (my $parent = $fd->{parent}) {
$parent->{children} = $class->new_from_ref($parent->{children} || [])->upgrade(%params);
}
my $uc_file = pkg_to_file($upgrade_class);
require($uc_file) unless $INC{$uc_file};
return $upgrade_class->new(facet_data => $fd, result_class => $class);
}
sub hub {
my $self = shift;
my $hub = Test2::API::InterceptResult::Hub->new();
$hub->process($_) for @$self;
$hub->set_ended(1);
return $hub;
}
sub state {
my $self = shift;
my %params = @_;
my $hub = $self->hub;
my $out = {
map {($_ => scalar $hub->$_)} qw/count failed is_passing plan bailed_out skip_reason/
};
$out->{bailed_out} = $self->_upgrade($out->{bailed_out}, %params)->bailout_reason || 1
if $out->{bailed_out};
$out->{follows_plan} = $hub->check_plan;
return $out;
}
sub upgrade {
my $self = shift;
my %params = @_;
my @out = map { $self->_upgrade($_, %params, _upgrade_clone => 1) } @$self;
return blessed($self)->new_from_ref(\@out)
unless $params{in_place};
@$self = @out;
return $self;
}
sub squash_info {
my $self = shift;
my %params = @_;
my @out;
{
my $squasher = Test2::API::InterceptResult::Squasher->new(events => \@out);
# Clone to make sure we do not indirectly modify an existing one if it
# is already upgraded
$squasher->process($self->_upgrade($_, %params)->clone) for @$self;
$squasher->flush_down();
}
return blessed($self)->new_from_ref(\@out)
unless $params{in_place};
@$self = @out;
return $self;
}
sub asserts { shift->grep(has_assert => @_) }
sub subtests { shift->grep(has_subtest => @_) }
sub diags { shift->grep(has_diags => @_) }
sub notes { shift->grep(has_notes => @_) }
sub errors { shift->grep(has_errors => @_) }
sub plans { shift->grep(has_plan => @_) }
sub causes_fail { shift->grep(causes_fail => @_) }
sub causes_failure { shift->grep(causes_failure => @_) }
sub flatten { shift->map(flatten => @_) }
sub briefs { shift->map(brief => @_) }
sub summaries { shift->map(summary => @_) }
sub subtest_results { shift->map(subtest_result => @_) }
sub diag_messages { shift->map(diag_messages => @_) }
sub note_messages { shift->map(note_messages => @_) }
sub error_messages { shift->map(error_messages => @_) }
no warnings 'once';
*map = sub {
my $self = shift;
my ($call, %params) = @_;
my $args = $params{args} ||= [];
return [map { local $_ = $self->_upgrade($_, %params); $_->$call(@$args) } @$self];
};
*grep = sub {
my $self = shift;
my ($call, %params) = @_;
my $args = $params{args} ||= [];
my @out = grep { local $_ = $self->_upgrade($_, %params); $_->$call(@$args) } @$self;
return blessed($self)->new_from_ref(\@out)
unless $params{in_place};
@$self = @out;
return $self;
};
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::API::InterceptResult - Representation of a list of events.
=head1 DESCRIPTION
This class represents a list of events, normally obtained using C<intercept()>
from L<Test2::API>.
This class is intended for people who with to verify the results of test tools
they write.
This class provides methods to normalize, summarize, or map the list of events.
The output of these operations makes verifying your testing tools and the
events they generate significantly easier. In most cases this spares you from
needing a deep understanding of the event/facet model.
=head1 SYNOPSIS
Usually you get an instance of this class when you use C<intercept()> from
L<Test2::API>.
use Test2::V0;
use Test2::API qw/intercept/;
my $events = intercept {
ok(1, "pass");
ok(0, "fail");
todo "broken" => sub { ok(0, "fixme") };
plan 3;
};
# This is typically the most useful construct
# squash_info() merges assertions and diagnostics that are associated
# (and returns a new instance with the modifications)
# flatten() condenses the facet data into the key details for each event
# (and returns those structures in an arrayref)
is(
$events->squash_info->flatten(),
[
{
causes_failure => 0,
name => 'pass',
pass => 1,
trace_file => 'xxx.t',
trace_line => 5,
},
{
causes_failure => 1,
name => 'fail',
pass => 0,
trace_file => 'xxx.t',
trace_line => 6,
# There can be more than one diagnostics message so this is
# always an array when present.
diag => ["Failed test 'fail'\nat xxx.t line 6."],
},
{
causes_failure => 0,
name => 'fixme',
pass => 0,
trace_file => 'xxx.t',
trace_line => 7,
# There can be more than one diagnostics message or todo
# reason, so these are always an array when present.
todo => ['broken'],
# Diag message was turned into a note since the assertion was
# TODO
note => ["Failed test 'fixme'\nat xxx.t line 7."],
},
{
causes_failure => 0,
plan => 3,
trace_file => 'xxx.t',
trace_line => 8,
},
],
"Flattened events look like we expect"
);
See L<Test2::API::InterceptResult::Event> for a full description of what
C<flatten()> provides for each event.
=head1 METHODS
Please note that no methods modify the original instance unless asked to do so.
=head2 CONSTRUCTION
=over 4
=item $events = Test2::API::InterceptResult->new(@EVENTS)
=item $events = Test2::API::InterceptResult->new_from_ref(\@EVENTS)
These create a new instance of Test2::API::InterceptResult from the given
events.
In the first form a new blessed arrayref is returned. In the 'new_from_ref'
form the reference you pass in is directly blessed.
Both of these will throw an exception if called in void context. This is mainly
important for the 'filtering' methods listed below which normally return a new
instance, they throw an exception in such cases as it probably means someone
meant to filter the original in place.
=item $clone = $events->clone()
Make a clone of the original events. Note that this is a deep copy, the entire
structure is duplicated. This uses C<dclone> from L<Storable> to achieve the
deep clone.
=back
=head2 NORMALIZATION
=over 4
=item @events = $events->event_list
This returns all the events in list-form.
=item $hub = $events->hub
This returns a new L<Test2::Hub> instance that has processed all the events
contained in the instance. This gives you a simple way to inspect the state
changes your events cause.
=item $state = $events->state
This returns a summary of the state of a hub after processing all the events.
{
count => 2, # Number of assertions made
failed => 1, # Number of test failures seen
is_passing => 0, # Boolean, true if the test would be passing
# after the events are processed.
plan => 2, # Plan, either a number, undef, 'SKIP', or 'NO PLAN'
follows_plan => 1, # True if there is a plan and it was followed.
# False if the plan and assertions did not
# match, undef if no plan was present in the
# event list.
bailed_out => undef, # undef unless there was a bail-out in the
# events in which case this will be a string
# explaining why there was a bailout, if no
# reason was given this will simply be set to
# true (1).
skip_reason => undef, # If there was a skip_all this will give the
# reason.
}
=item $new = $events->upgrade
=item $events->upgrade(in_place => $BOOL)
B<Note:> This normally returns a new instance, leaving the original unchanged.
If you call it in void context it will throw an exception. If you want to
modify the original you must pass in the C<< in_place => 1 >> option. You may
call this in void context when you ask to modify it in place. The in-place form
returns the instance that was modified so you can chain methods.
This will create a clone of the list where all events have been converted into
L<Test2::API::InterceptResult::Event> instances. This is extremely helpful as
L<Test2::API::InterceptResult::Event> provide a much better interface for
working with events. This allows you to avoid thinking about legacy event
types.
This also means your tests against the list are not fragile if the tool
you are testing randomly changes what type of events it generates (IE Changing
from L<Test2::Event::Ok> to L<Test2::Event::Pass>, both make assertions and
both will normalize to identical (or close enough)
L<Test2::API::InterceptResult::Event> instances.
Really you almost always want this, the only reason it is not done
automatically is to make sure the C<intercept()> tool is backwards compatible.
=item $new = $events->squash_info
=item $events->squash_info(in_place => $BOOL)
B<Note:> This normally returns a new instance, leaving the original unchanged.
If you call it in void context it will throw an exception. If you want to
modify the original you must pass in the C<< in_place => 1 >> option. You may
call this in void context when you ask to modify it in place. The in-place form
returns the instance that was modified so you can chain methods.
B<Note:> All events in the new or modified instance will be converted to
L<Test2::API::InterceptResult::Event> instances. There is no way to avoid this,
the squash operation requires the upgraded event class.
L<Test::More> and many other legacy tools would send notes, diags, and
assertions as separate events. A subtest in L<Test::More> would send a note
with the subtest name, the subtest assertion, and finally a diagnostics event
if the subtest failed. This method will normalize things by squashing the note
and diag into the same event as the subtest (This is different from putting
them into the subtest, which is not what happens).
=back
=head2 FILTERING
B<Note:> These normally return new instances, leaving the originals unchanged.
If you call them in void context they will throw exceptions. If you want to
modify the originals you must pass in the C<< in_place => 1 >> option. You may
call these in void context when you ask to modify them in place. The in-place
forms return the instance that was modified so you can chain methods.
=head3 %PARAMS
These all accept the same 2 optional parameters:
=over 4
=item in_place => $BOOL
When true the method will modify the instance in place instead of returning a
new instance.
=item args => \@ARGS
If you wish to pass parameters into the event method being used for filtering,
you may do so here.
=back
=head3 METHODS
=over 4
=item $events->grep($CALL, %PARAMS)
This is essentially:
Test2::API::InterceptResult->new(
grep { $_->$CALL( @{$PARAMS{args}} ) } $self->event_list,
);
B<Note:> that $CALL is called on an upgraded version of the event, though
the events returned will be the original ones, not the upgraded ones.
$CALL may be either the name of a method on
L<Test2::API::InterceptResult::Event>, or a coderef.
=item $events->asserts(%PARAMS)
This is essentially:
$events->grep(has_assert => @{$PARAMS{args}})
It returns a new instance containing only the events that made assertions.
=item $events->subtests(%PARAMS)
This is essentially:
$events->grep(has_subtest => @{$PARAMS{args}})
It returns a new instance containing only the events that have subtests.
=item $events->diags(%PARAMS)
This is essentially:
$events->grep(has_diags => @{$PARAMS{args}})
It returns a new instance containing only the events that have diags.
=item $events->notes(%PARAMS)
This is essentially:
$events->grep(has_notes => @{$PARAMS{args}})
It returns a new instance containing only the events that have notes.
=item $events->errors(%PARAMS)
B<Note:> Errors are NOT failing assertions. Failing assertions are a different
thing.
This is essentially:
$events->grep(has_errors => @{$PARAMS{args}})
It returns a new instance containing only the events that have errors.
=item $events->plans(%PARAMS)
This is essentially:
$events->grep(has_plan => @{$PARAMS{args}})
It returns a new instance containing only the events that set the plan.
=item $events->causes_fail(%PARAMS)
=item $events->causes_failure(%PARAMS)
These are essentially:
$events->grep(causes_fail => @{$PARAMS{args}})
$events->grep(causes_failure => @{$PARAMS{args}})
B<Note:> C<causes_fail()> and C<causes_failure()> are both aliases for
eachother in events, so these methods are effectively aliases here as well.
It returns a new instance containing only the events that cause failure.
=back
=head2 MAPPING
These methods B<ALWAYS> return an arrayref.
B<Note:> No methods on L<Test2::API::InterceptResult::Event> alter the event in
any way.
B<Important Notes about Events>:
L<Test2::API::InterceptResult::Event> was tailor-made to be used in
event-lists. Most methods that are not applicable to a given event will return
an empty list, so you normally do not need to worry about unwanted C<undef>
values or exceptions being thrown. Mapping over event methods is an entended
use, so it works well to produce lists.
B<Exceptions to the rule:>
Some methods such as C<causes_fail> always return a boolean true or false for
all events. Any method prefixed with C<the_> conveys the intent that the event
should have exactly 1 of something, so those will throw an exception when that
condition is not true.
=over 4
=item $arrayref = $events->map($CALL, %PARAMS)
This is essentially:
[ map { $_->$CALL(@{ $PARAMS{args} }) } $events->upgrade->event_list ];
$CALL may be either the name of a method on
L<Test2::API::InterceptResult::Event>, or a coderef.
=item $arrayref = $events->flatten(%PARAMS)
This is essentially:
[ map { $_->flatten(@{ $PARAMS{args} }) } $events->upgrade->event_list ];
It returns a new list of flattened structures.
See L<Test2::API::InterceptResult::Event> for details on what C<flatten()>
returns.
=item $arrayref = $events->briefs(%PARAMS)
This is essentially:
[ map { $_->briefs(@{ $PARAMS{args} }) } $events->upgrade->event_list ];
It returns a new list of event briefs.
See L<Test2::API::InterceptResult::Event> for details on what C<brief()>
returns.
=item $arrayref = $events->summaries(%PARAMS)
This is essentially:
[ map { $_->summaries(@{ $PARAMS{args} }) } $events->upgrade->event_list ];
It returns a new list of event summaries.
See L<Test2::API::InterceptResult::Event> for details on what C<summary()>
returns.
=item $arrayref = $events->subtest_results(%PARAMS)
This is essentially:
[ map { $_->subtest_result(@{ $PARAMS{args} }) } $events->upgrade->event_list ];
It returns a new list of event summaries.
See L<Test2::API::InterceptResult::Event> for details on what
C<subtest_result()> returns.
=item $arrayref = $events->diag_messages(%PARAMS)
This is essentially:
[ map { $_->diag_messages(@{ $PARAMS{args} }) } $events->upgrade->event_list ];
It returns a new list of diagnostic messages (strings).
See L<Test2::API::InterceptResult::Event> for details on what
C<diag_messages()> returns.
=item $arrayref = $events->note_messages(%PARAMS)
This is essentially:
[ map { $_->note_messages(@{ $PARAMS{args} }) } $events->upgrade->event_list ];
It returns a new list of notification messages (strings).
See L<Test2::API::InterceptResult::Event> for details on what
C<note_messages()> returns.
=item $arrayref = $events->error_messages(%PARAMS)
This is essentially:
[ map { $_->error_messages(@{ $PARAMS{args} }) } $events->upgrade->event_list ];
It returns a new list of error messages (strings).
See L<Test2::API::InterceptResult::Event> for details on what
C<error_messages()> returns.
=back
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

1088
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/API/InterceptResult/Event.pm Normal file
View file

File diff suppressed because it is too large Load diff

25
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/API/InterceptResult/Facet.pm Normal file
View file

@ -0,0 +1,25 @@
package Test2::API::InterceptResult::Facet;
use strict;
use warnings;
our $VERSION = '1.302199';
BEGIN {
require Test2::EventFacet;
our @ISA = ('Test2::EventFacet');
}
our $AUTOLOAD;
sub AUTOLOAD {
my $self = shift;
my $name = $AUTOLOAD;
$name =~ s/^.*:://g;
return undef unless exists $self->{$name};
return $self->{$name};
}
sub DESTROY {}
1;

66
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/API/InterceptResult/Hub.pm Normal file
View file

@ -0,0 +1,66 @@
package Test2::API::InterceptResult::Hub;
use strict;
use warnings;
our $VERSION = '1.302199';
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;
$self->{+NESTED} = 0;
}
sub terminate { }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::API::InterceptResult::Hub - Hub used by InterceptResult.
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

196
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/API/InterceptResult/Squasher.pm Normal file
View file

@ -0,0 +1,196 @@
package Test2::API::InterceptResult::Squasher;
use strict;
use warnings;
our $VERSION = '1.302199';
use Carp qw/croak/;
use List::Util qw/first/;
use Test2::Util::HashBase qw{
<events
+down_sig +down_buffer
+up_into +up_sig +up_clear
};
sub init {
my $self = shift;
croak "'events' is a required attribute" unless $self->{+EVENTS};
}
sub can_squash {
my $self = shift;
my ($event) = @_;
# No info, no squash
return unless $event->has_info;
# Do not merge up if one of these is true
return if first { $event->$_ } 'causes_fail', 'has_assert', 'has_bailout', 'has_errors', 'has_plan', 'has_subtest';
# Signature if we can squash
return $event->trace_signature;
}
sub process {
my $self = shift;
my ($event) = @_;
return if $self->squash_up($event);
return if $self->squash_down($event);
$self->flush_down($event);
push @{$self->{+EVENTS}} => $event;
return;
}
sub squash_down {
my $self = shift;
my ($event) = @_;
my $sig = $self->can_squash($event)
or return;
$self->flush_down()
if $self->{+DOWN_SIG} && $self->{+DOWN_SIG} ne $sig;
$self->{+DOWN_SIG} ||= $sig;
push @{$self->{+DOWN_BUFFER}} => $event;
return 1;
}
sub flush_down {
my $self = shift;
my ($into) = @_;
my $sig = delete $self->{+DOWN_SIG};
my $buffer = delete $self->{+DOWN_BUFFER};
return unless $buffer && @$buffer;
my $fsig = $into ? $into->trace_signature : undef;
if ($fsig && $fsig eq $sig) {
$self->squash($into, @$buffer);
}
else {
push @{$self->{+EVENTS}} => @$buffer if $buffer;
}
}
sub clear_up {
my $self = shift;
return unless $self->{+UP_CLEAR};
delete $self->{+UP_INTO};
delete $self->{+UP_SIG};
delete $self->{+UP_CLEAR};
}
sub squash_up {
my $self = shift;
my ($event) = @_;
no warnings 'uninitialized';
$self->clear_up;
if ($event->has_assert) {
if(my $sig = $event->trace_signature) {
$self->{+UP_INTO} = $event;
$self->{+UP_SIG} = $sig;
$self->{+UP_CLEAR} = 0;
}
else {
$self->{+UP_CLEAR} = 1;
$self->clear_up;
}
return;
}
my $into = $self->{+UP_INTO} or return;
# Next iteration should clear unless something below changes that
$self->{+UP_CLEAR} = 1;
# Only merge into matching trace signatres
my $sig = $self->can_squash($event);
return unless $sig eq $self->{+UP_SIG};
# OK Merge! Do not clear merge in case the return event is also a matching sig diag-only
$self->{+UP_CLEAR} = 0;
$self->squash($into, $event);
return 1;
}
sub squash {
my $self = shift;
my ($into, @from) = @_;
push @{$into->facet_data->{info}} => $_->info for @from;
}
sub DESTROY {
my $self = shift;
return unless $self->{+EVENTS};
$self->flush_down();
return;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::API::InterceptResult::Squasher - Encapsulation of the algorithm that
squashes diags into assertions.
=head1 DESCRIPTION
Internal use only, please ignore.
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

226
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/API/Stack.pm Normal file
View file

@ -0,0 +1,226 @@
package Test2::API::Stack;
use strict;
use warnings;
our $VERSION = '1.302199';
use Test2::Hub();
use Carp qw/confess/;
sub new {
my $class = shift;
return bless [], $class;
}
sub new_hub {
my $self = shift;
my %params = @_;
my $class = delete $params{class} || 'Test2::Hub';
my $hub = $class->new(%params);
if (@$self) {
$hub->inherit($self->[-1], %params);
}
else {
require Test2::API;
$hub->format(Test2::API::test2_formatter()->new_root)
unless $hub->format || exists($params{formatter});
my $ipc = Test2::API::test2_ipc();
if ($ipc && !$hub->ipc && !exists($params{ipc})) {
$hub->set_ipc($ipc);
$ipc->add_hub($hub->hid);
}
}
push @$self => $hub;
$hub;
}
sub top {
my $self = shift;
return $self->new_hub unless @$self;
return $self->[-1];
}
sub peek {
my $self = shift;
return @$self ? $self->[-1] : undef;
}
sub cull {
my $self = shift;
$_->cull for reverse @$self;
}
sub all {
my $self = shift;
return @$self;
}
sub root {
my $self = shift;
return unless @$self;
return $self->[0];
}
sub clear {
my $self = shift;
@$self = ();
}
# Do these last without keywords in order to prevent them from getting used
# when we want the real push/pop.
{
no warnings 'once';
*push = sub {
my $self = shift;
my ($hub) = @_;
$hub->inherit($self->[-1]) if @$self;
push @$self => $hub;
};
*pop = sub {
my $self = shift;
my ($hub) = @_;
confess "No hubs on the stack"
unless @$self;
confess "You cannot pop the root hub"
if 1 == @$self;
confess "Hub stack mismatch, attempted to pop incorrect hub"
unless $self->[-1] == $hub;
pop @$self;
};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::API::Stack - Object to manage a stack of L<Test2::Hub>
instances.
=head1 ***INTERNALS NOTE***
B<The internals of this package are subject to change at any time!> The public
methods provided will not change in backwards incompatible ways, but the
underlying implementation details might. B<Do not break encapsulation here!>
=head1 DESCRIPTION
This module is used to represent and manage a stack of L<Test2::Hub>
objects. Hubs are usually in a stack so that you can push a new hub into place
that can intercept and handle events differently than the primary hub.
=head1 SYNOPSIS
my $stack = Test2::API::Stack->new;
my $hub = $stack->top;
=head1 METHODS
=over 4
=item $stack = Test2::API::Stack->new()
This will create a new empty stack instance. All arguments are ignored.
=item $hub = $stack->new_hub()
=item $hub = $stack->new_hub(%params)
=item $hub = $stack->new_hub(%params, class => $class)
This will generate a new hub and push it to the top of the stack. Optionally
you can provide arguments that will be passed into the constructor for the
L<Test2::Hub> object.
If you specify the C<< 'class' => $class >> argument, the new hub will be an
instance of the specified class.
Unless your parameters specify C<'formatter'> or C<'ipc'> arguments, the
formatter and IPC instance will be inherited from the current top hub. You can
set the parameters to C<undef> to avoid having a formatter or IPC instance.
If there is no top hub, and you do not ask to leave IPC and formatter undef,
then a new formatter will be created, and the IPC instance from
L<Test2::API> will be used.
=item $hub = $stack->top()
This will return the top hub from the stack. If there is no top hub yet this
will create it.
=item $hub = $stack->peek()
This will return the top hub from the stack. If there is no top hub yet this
will return undef.
=item $stack->cull
This will call C<< $hub->cull >> on all hubs in the stack.
=item @hubs = $stack->all
This will return all the hubs in the stack as a list.
=item $stack->clear
This will completely remove all hubs from the stack. Normally you do not want
to do this, but there are a few valid reasons for it.
=item $stack->push($hub)
This will push the new hub onto the stack.
=item $stack->pop($hub)
This will pop a hub from the stack, if the hub at the top of the stack does not
match the hub you expect (passed in as an argument) it will throw an exception.
=back
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

823
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/AsyncSubtest.pm Normal file
View file

@ -0,0 +1,823 @@
package Test2::AsyncSubtest;
use strict;
use warnings;
use Test2::IPC;
our $VERSION = '0.000162';
our @CARP_NOT = qw/Test2::Util::HashBase/;
use Carp qw/croak cluck confess/;
use Test2::Util qw/get_tid CAN_THREAD CAN_FORK/;
use Scalar::Util qw/blessed weaken/;
use List::Util qw/first/;
use Test2::API();
use Test2::API::Context();
use Test2::Util::Trace();
use Test2::Util::Guard();
use Time::HiRes();
use Test2::AsyncSubtest::Hub();
use Test2::AsyncSubtest::Event::Attach();
use Test2::AsyncSubtest::Event::Detach();
use Test2::Util::HashBase qw{
name hub
trace frame send_to
events
finished
active
stack
id cid uuid
children
_in_use
_attached pid tid
start_stamp stop_stamp
};
sub CAN_REALLY_THREAD {
return 0 unless CAN_THREAD;
return 0 unless eval { require threads; threads->VERSION('1.34'); 1 };
return 1;
}
my $UUID_VIA = Test2::API::_add_uuid_via_ref();
my $CID = 1;
my @STACK;
sub TOP { @STACK ? $STACK[-1] : undef }
sub init {
my $self = shift;
croak "'name' is a required attribute"
unless $self->{+NAME};
my $to = $self->{+SEND_TO} ||= Test2::API::test2_stack()->top;
$self->{+STACK} = [@STACK];
$_->{+_IN_USE}++ for reverse @STACK;
$self->{+TID} = get_tid;
$self->{+PID} = $$;
$self->{+CID} = 'AsyncSubtest-' . $CID++;
$self->{+ID} = 1;
$self->{+FINISHED} = 0;
$self->{+ACTIVE} = 0;
$self->{+_IN_USE} = 0;
$self->{+CHILDREN} = [];
$self->{+UUID} = ${$UUID_VIA}->() if defined $$UUID_VIA;
unless($self->{+HUB}) {
my $ipc = Test2::API::test2_ipc();
my $formatter = Test2::API::test2_stack->top->format;
my $args = delete $self->{hub_init_args} || {};
my $hub = Test2::AsyncSubtest::Hub->new(
%$args,
ipc => $ipc,
nested => $to->nested + 1,
buffered => 1,
formatter => $formatter,
);
weaken($hub->{ast} = $self);
$self->{+HUB} = $hub;
}
$self->{+TRACE} ||= Test2::Util::Trace->new(
frame => $self->{+FRAME} || [caller(1)],
buffered => $to->buffered,
nested => $to->nested,
cid => $self->{+CID},
uuid => $self->{+UUID},
hid => $to->hid,
huuid => $to->uuid,
);
my $hub = $self->{+HUB};
$hub->set_ast_ids({}) unless $hub->ast_ids;
$hub->listen($self->_listener);
}
sub _listener {
my $self = shift;
my $events = $self->{+EVENTS} ||= [];
sub { push @$events => $_[1] };
}
sub context {
my $self = shift;
my $send_to = $self->{+SEND_TO};
confess "Attempt to close AsyncSubtest when original parent hub (a non async-subtest?) has ended"
if $send_to->ended;
return Test2::API::Context->new(
trace => $self->{+TRACE},
hub => $send_to,
);
}
sub _gen_event {
my $self = shift;
my ($type, $id, $hub) = @_;
my $class = "Test2::AsyncSubtest::Event::$type";
return $class->new(
id => $id,
trace => Test2::Util::Trace->new(
frame => [caller(1)],
buffered => $hub->buffered,
nested => $hub->nested,
cid => $self->{+CID},
uuid => $self->{+UUID},
hid => $hub->hid,
huuid => $hub->uuid,
),
);
}
sub cleave {
my $self = shift;
my $id = $self->{+ID}++;
$self->{+HUB}->ast_ids->{$id} = 0;
return $id;
}
sub attach {
my $self = shift;
my ($id) = @_;
croak "An ID is required" unless $id;
croak "ID $id is not valid"
unless defined $self->{+HUB}->ast_ids->{$id};
croak "ID $id is already attached"
if $self->{+HUB}->ast_ids->{$id};
croak "You must attach INSIDE the child process/thread"
if $self->{+HUB}->is_local;
$self->{+_ATTACHED} = [ $$, get_tid, $id ];
$self->{+HUB}->send($self->_gen_event('Attach', $id, $self->{+HUB}));
}
sub detach {
my $self = shift;
if ($self->{+PID} == $$ && $self->{+TID} == get_tid) {
cluck "You must detach INSIDE the child process/thread ($$, " . get_tid . " instead of $self->{+PID}, $self->{+TID})";
return;
}
my $att = $self->{+_ATTACHED}
or croak "Not attached";
croak "Attempt to detach from wrong child"
unless $att->[0] == $$ && $att->[1] == get_tid;
my $id = $att->[2];
$self->{+HUB}->send($self->_gen_event('Detach', $id, $self->{+HUB}));
delete $self->{+_ATTACHED};
}
sub ready { return !shift->pending }
sub pending {
my $self = shift;
my $hub = $self->{+HUB};
return -1 unless $hub->is_local;
$hub->cull;
return $self->{+_IN_USE} + keys %{$self->{+HUB}->ast_ids};
}
sub run {
my $self = shift;
my ($code, @args) = @_;
croak "AsyncSubtest->run() takes a codeblock as the first argument"
unless $code && ref($code) eq 'CODE';
$self->start;
my ($ok, $err, $finished);
T2_SUBTEST_WRAPPER: {
$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"/) {
$ok = undef;
$err = undef;
}
else {
$finished = 1;
}
}
$self->stop;
my $hub = $self->{+HUB};
if (!$finished) {
if(my $bailed = $hub->bailed_out) {
my $ctx = $self->context;
$ctx->bail($bailed->reason);
return;
}
my $code = $hub->exit_code;
$ok = !$code;
$err = "Subtest ended with exit code $code" if $code;
}
unless ($ok) {
my $e = Test2::Event::Exception->new(
error => $err,
trace => Test2::Util::Trace->new(
frame => [caller(0)],
buffered => $hub->buffered,
nested => $hub->nested,
cid => $self->{+CID},
uuid => $self->{+UUID},
hid => $hub->hid,
huuid => $hub->uuid,
),
);
$hub->send($e);
}
return $hub->is_passing;
}
sub start {
my $self = shift;
croak "Subtest is already complete"
if $self->{+FINISHED};
$self->{+START_STAMP} = Time::HiRes::time() unless defined $self->{+START_STAMP};
$self->{+ACTIVE}++;
push @STACK => $self;
my $hub = $self->{+HUB};
my $stack = Test2::API::test2_stack();
$stack->push($hub);
return $hub->is_passing;
}
sub stop {
my $self = shift;
croak "Subtest is not active"
unless $self->{+ACTIVE}--;
croak "AsyncSubtest stack mismatch"
unless @STACK && $self == $STACK[-1];
$self->{+STOP_STAMP} = Time::HiRes::time();
pop @STACK;
my $hub = $self->{+HUB};
my $stack = Test2::API::test2_stack();
$stack->pop($hub);
return $hub->is_passing;
}
sub finish {
my $self = shift;
my %params = @_;
my $hub = $self->hub;
croak "Subtest is already finished"
if $self->{+FINISHED}++;
croak "Subtest can only be finished in the process/thread that created it"
unless $hub->is_local;
croak "Subtest is still active"
if $self->{+ACTIVE};
$self->wait;
$self->{+STOP_STAMP} = Time::HiRes::time() unless defined $self->{+STOP_STAMP};
my $stop_stamp = $self->{+STOP_STAMP};
my $todo = $params{todo};
my $skip = $params{skip};
my $empty = !@{$self->{+EVENTS}};
my $no_asserts = !$hub->count;
my $collapse = $params{collapse};
my $no_plan = $params{no_plan} || ($collapse && $no_asserts) || $skip;
my $trace = Test2::Util::Trace->new(
frame => $self->{+TRACE}->{frame},
buffered => $hub->buffered,
nested => $hub->nested,
cid => $self->{+CID},
uuid => $self->{+UUID},
hid => $hub->hid,
huuid => $hub->uuid,
);
$hub->finalize($trace, !$no_plan)
unless $hub->no_ending || $hub->ended;
if ($hub->ipc) {
$hub->ipc->drop_hub($hub->hid);
$hub->set_ipc(undef);
}
return $hub->is_passing if $params{silent};
my $ctx = $self->context;
my $pass = 1;
if ($skip) {
$ctx->skip($self->{+NAME}, $skip);
}
else {
if ($collapse && $empty) {
$ctx->ok($hub->is_passing, $self->{+NAME});
return $hub->is_passing;
}
if ($collapse && $no_asserts) {
push @{$self->{+EVENTS}} => Test2::Event::Plan->new(trace => $trace, max => 0, directive => 'SKIP', reason => "No assertions");
}
my $e = $ctx->build_event(
'Subtest',
pass => $hub->is_passing,
subtest_id => $hub->id,
subtest_uuid => $hub->uuid,
name => $self->{+NAME},
buffered => 1,
subevents => $self->{+EVENTS},
start_stamp => $self->{+START_STAMP},
stop_stamp => $self->{+STOP_STAMP},
$todo ? (
todo => $todo,
effective_pass => 1,
) : (),
);
$ctx->hub->send($e);
unless ($e->effective_pass) {
$ctx->failure_diag($e);
$ctx->diag("Bad subtest plan, expected " . $hub->plan . " but ran " . $hub->count)
if $hub->plan && !$hub->check_plan && !grep {$_->causes_fail} @{$self->{+EVENTS}};
}
$pass = $e->pass;
}
$_->{+_IN_USE}-- for reverse @{$self->{+STACK}};
return $pass;
}
sub wait {
my $self = shift;
my $hub = $self->{+HUB};
my $children = $self->{+CHILDREN};
while (@$children) {
$hub->cull;
if (my $child = pop @$children) {
if (blessed($child)) {
$child->join;
}
else {
waitpid($child, 0);
}
}
else {
Time::HiRes::sleep('0.01');
}
}
$hub->cull;
cluck "Subtest '$self->{+NAME}': All children have completed, but we still appear to be pending"
if $hub->is_local && keys %{$self->{+HUB}->ast_ids};
}
sub fork {
croak "Forking is not supported" unless CAN_FORK;
my $self = shift;
my $id = $self->cleave;
my $pid = CORE::fork();
unless (defined $pid) {
delete $self->{+HUB}->ast_ids->{$id};
croak "Failed to fork";
}
if($pid) {
push @{$self->{+CHILDREN}} => $pid;
return $pid;
}
$self->attach($id);
return $self->_guard;
}
sub run_fork {
my $self = shift;
my ($code, @args) = @_;
my $f = $self->fork;
return $f unless blessed($f);
$self->run($code, @args);
$self->detach();
$f->dismiss();
exit 0;
}
sub run_thread {
croak "Threading is not supported"
unless CAN_REALLY_THREAD;
my $self = shift;
my ($code, @args) = @_;
my $id = $self->cleave;
my $thr = threads->create(sub {
$self->attach($id);
$self->run($code, @args);
$self->detach(get_tid);
return 0;
});
push @{$self->{+CHILDREN}} => $thr;
return $thr;
}
sub _guard {
my $self = shift;
my ($pid, $tid) = ($$, get_tid);
return Test2::Util::Guard->new(sub {
return unless $$ == $pid && get_tid == $tid;
my $error = "Scope Leak";
if (my $ex = $@) {
chomp($ex);
$error .= " ($ex)";
}
cluck $error;
my $e = $self->context->build_event(
'Exception',
error => "$error\n",
);
$self->{+HUB}->send($e);
$self->detach();
exit 255;
});
}
sub DESTROY {
my $self = shift;
return unless $self->{+NAME};
if (my $att = $self->{+_ATTACHED}) {
return unless $self->{+HUB};
eval { $self->detach() };
}
return if $self->{+FINISHED};
return unless $self->{+PID} == $$;
return unless $self->{+TID} == get_tid;
local $@;
eval { $_->{+_IN_USE}-- for reverse @{$self->{+STACK}} };
warn "Subtest $self->{+NAME} did not finish!";
exit 255;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::AsyncSubtest - Object representing an async subtest.
=head1 DESCRIPTION
Regular subtests have a limited scope, they start, events are generated, then
they close and send an L<Test2::Event::Subtest> event. This is a problem if you
want the subtest to keep receiving events while other events are also being
generated. This class implements subtests that stay open until you decide to
close them.
This is mainly useful for tools that start a subtest in one process and then
spawn children. In many cases it is nice to let the parent process continue
instead of waiting on the children.
=head1 SYNOPSIS
use Test2::AsyncSubtest;
my $ast = Test2::AsyncSubtest->new(name => foo);
$ast->run(sub {
ok(1, "Event in parent" );
});
ok(1, "Event outside of subtest");
$ast->run_fork(sub {
ok(1, "Event in child process");
});
...
$ast->finish;
done_testing;
=head1 CONSTRUCTION
my $ast = Test2::AsyncSubtest->new( ... );
=over 4
=item name => $name (required)
Name of the subtest. This construction argument is required.
=item send_to => $hub (optional)
Hub to which the final subtest event should be sent. This must be an instance
of L<Test2::Hub> or a subclass. If none is specified then the current top hub
will be used.
=item trace => $trace (optional)
File/Line to which errors should be attributed. This must be an instance of
L<Test2::Util::Trace>. If none is specified then the file/line where the
constructor was called will be used.
=item hub => $hub (optional)
Use this to specify a hub the subtest should use. By default a new hub is
generated. This must be an instance of L<Test2::AsyncSubtest::Hub>.
=back
=head1 METHODS
=head2 SIMPLE ACCESSORS
=over 4
=item $bool = $ast->active
True if the subtest is active. The subtest is active if its hub appears in the
global hub stack. This is true when C<< $ast->run(...) >> us running.
=item $arrayref = $ast->children
Get an arrayref of child processes/threads. Numerical items are PIDs, blessed
items are L<threads> instances.
=item $arrayref = $ast->events
Get an arrayref of events that have been sent to the subtests hub.
=item $bool = $ast->finished
True if C<finished()> has already been called.
=item $hub = $ast->hub
The hub created for the subtest.
=item $int = $ast->id
Attach/Detach counter. Used internally, not useful to users.
=item $str = $ast->name
Name of the subtest.
=item $pid = $ast->pid
PID in which the subtest was created.
=item $tid = $ast->tid
Thread ID in which the subtest was created.
=item $hub = $ast->send_to
Hub to which the final subtest event should be sent.
=item $arrayref = $ast->stack
Stack of async subtests at the time this one was created. This is mainly for
internal use.
=item $trace = $ast->trace
L<Test2::Util::Trace> instance used for error reporting.
=back
=head2 INTERFACE
=over 4
=item $ast->attach($id)
Attach a subtest in a child/process to the original.
B<Note:> C<< my $id = $ast->cleave >> must have been called in the parent
process/thread before the child was started, the id it returns must be used in
the call to C<< $ast->attach($id) >>
=item $id = $ast->cleave
Prepare a slot for a child process/thread to attach. This must be called BEFORE
the child process or thread is started. The ID returned is used by C<attach()>.
This must only be called in the original process/thread.
=item $ctx = $ast->context
Get an L<Test2::API::Context> instance that can be used to send events to the
context in which the hub was created. This is not a canonical context, you
should not call C<< $ctx->release >> on it.
=item $ast->detach
Detach from the parent in a child process/thread. This should be called just
before the child exits.
=item $ast->finish
=item $ast->finish(%options)
Finish the subtest, wait on children, and send the final subtest event.
This must only be called in the original process/thread.
B<Note:> This calls C<< $ast->wait >>.
These are the options:
=over 4
=item collapse => 1
This intelligently allows a subtest to be empty.
If no events bump the test count then the subtest no final plan will be added.
The subtest will not be considered a failure (normally an empty subtest is a
failure).
If there are no events at all the subtest will be collapsed into an
L<Test2::Event::Ok> event.
=item silent => 1
This will prevent finish from generating a final L<Test2::Event::Subtest>
event. This effectively ends the subtest without it effecting the parent
subtest (or top level test).
=item no_plan => 1
This will prevent a final plan from being added to the subtest for you when
none is directly specified.
=item skip => "reason"
This will issue an L<Test2::Event::Skip> instead of a subtest. This will throw
an exception if any events have been seen, or if state implies events have
occurred.
=back
=item $out = $ast->fork
This is a slightly higher level interface to fork. Running it will fork your
code in-place just like C<fork()>. It will return a pid in the parent, and an
L<Test2::Util::Guard> instance in the child. An exception will be thrown if
fork fails.
It is recommended that you use C<< $ast->run_fork(sub { ... }) >> instead.
=item $bool = $ast->pending
True if there are child processes, threads, or subtests that depend on this
one.
=item $bool = $ast->ready
This is essentially C<< !$ast->pending >>.
=item $ast->run(sub { ... })
Run the provided codeblock inside the subtest. This will push the subtest hub
onto the stack, run the code, then pop the hub off the stack.
=item $pid = $ast->run_fork(sub { ... })
Same as C<< $ast->run() >>, except that the codeblock is run in a child
process.
You do not need to directly call C<wait($pid)>, that will be done for you when
C<< $ast->wait >>, or C<< $ast->finish >> are called.
=item my $thr = $ast->run_thread(sub { ... });
B<** DISCOURAGED **> Threads cause problems. This method remains for anyone who
REALLY wants it, but it is no longer supported. Tests for this functionality do
not even run unless the AUTHOR_TESTING or T2_DO_THREAD_TESTS env vars are
enabled.
Same as C<< $ast->run() >>, except that the codeblock is run in a child
thread.
You do not need to directly call C<< $thr->join >>, that is done for you when
C<< $ast->wait >>, or C<< $ast->finish >> are called.
=item $passing = $ast->start
Push the subtest hub onto the stack. Returns the current pass/fail status of
the subtest.
=item $ast->stop
Pop the subtest hub off the stack. Returns the current pass/fail status of the
subtest.
=item $ast->wait
Wait on all threads/processes that were started using C<< $ast->fork >>,
C<< $ast->run_fork >>, or C<< $ast->run_thread >>.
=back
=head1 SOURCE
The source code repository for Test2-AsyncSubtest can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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>exodist7@gmail.comE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

90
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/AsyncSubtest/Event/Attach.pm Normal file
View file

@ -0,0 +1,90 @@
package Test2::AsyncSubtest::Event::Attach;
use strict;
use warnings;
our $VERSION = '0.000162';
use base 'Test2::Event';
use Test2::Util::HashBase qw/id/;
sub no_display { 1 }
sub callback {
my $self = shift;
my ($hub) = @_;
my $id = $self->{+ID};
my $ids = $hub->ast_ids;
unless (defined $ids->{$id}) {
require Test2::Event::Exception;
my $trace = $self->trace;
$hub->send(
Test2::Event::Exception->new(
trace => $trace,
error => "Invalid AsyncSubtest attach ID: $id at " . $trace->debug . "\n",
)
);
return;
}
if ($ids->{$id}++) {
require Test2::Event::Exception;
my $trace = $self->trace;
$hub->send(
Test2::Event::Exception->new(
trace => $trace,
error => "AsyncSubtest ID $id already attached at " . $trace->debug . "\n",
)
);
return;
}
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::AsyncSubtest::Event::Attach - Event to attach a subtest to the parent.
=head1 DESCRIPTION
Used internally by L<Test2::AsyncSubtest>. No user serviceable parts inside.
=head1 SOURCE
The source code repository for Test2-AsyncSubtest can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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>exodist7@gmail.comE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

90
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/AsyncSubtest/Event/Detach.pm Normal file
View file

@ -0,0 +1,90 @@
package Test2::AsyncSubtest::Event::Detach;
use strict;
use warnings;
our $VERSION = '0.000162';
use base 'Test2::Event';
use Test2::Util::HashBase qw/id/;
sub no_display { 1 }
sub callback {
my $self = shift;
my ($hub) = @_;
my $id = $self->{+ID};
my $ids = $hub->ast_ids;
unless (defined $ids->{$id}) {
require Test2::Event::Exception;
my $trace = $self->trace;
$hub->send(
Test2::Event::Exception->new(
trace => $trace,
error => "Invalid AsyncSubtest detach ID: $id at " . $trace->debug . "\n",
)
);
return;
}
unless (delete $ids->{$id}) {
require Test2::Event::Exception;
my $trace = $self->trace;
$hub->send(
Test2::Event::Exception->new(
trace => $trace,
error => "AsyncSubtest ID $id is not attached at " . $trace->debug . "\n",
)
);
return;
}
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::AsyncSubtest::Event::Detach - Event to detach a subtest from the parent.
=head1 DESCRIPTION
Used internally by L<Test2::AsyncSubtest>. No user serviceable parts inside.
=head1 SOURCE
The source code repository for Test2-AsyncSubtest can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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>exodist7@gmail.comE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

9
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/AsyncSubtest/Formatter.pm Normal file
View file

@ -0,0 +1,9 @@
package Test2::AsyncSubtest::Formatter;
use strict;
use warnings;
our $VERSION = '0.000162';
die "Should not load this anymore";
1;

119
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/AsyncSubtest/Hub.pm Normal file
View file

@ -0,0 +1,119 @@
package Test2::AsyncSubtest::Hub;
use strict;
use warnings;
our $VERSION = '0.000162';
use base 'Test2::Hub::Subtest';
use Test2::Util::HashBase qw/ast_ids ast/;
use Test2::Util qw/get_tid/;
sub init {
my $self = shift;
$self->SUPER::init();
if (my $format = $self->format) {
my $hide = $format->can('hide_buffered') ? $format->hide_buffered : 1;
$self->format(undef) if $hide;
}
}
sub inherit {
my $self = shift;
my ($from, %params) = @_;
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 send {
my $self = shift;
my ($e) = @_;
if (my $ast = $self->ast) {
if ($$ != $ast->pid || get_tid != $ast->tid) {
if (my $plan = $e->facet_data->{plan}) {
unless ($plan->{skip}) {
my $trace = $e->facet_data->{trace};
bless($trace, 'Test2::EventFacet::Trace');
$trace->alert("A plan should not be set inside an async-subtest (did you call done_testing()?)");
return;
}
}
}
}
return $self->SUPER::send($e);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::AsyncSubtest::Hub - Hub used by async subtests.
=head1 DESCRIPTION
This is a subclass of L<Test2::Hub::Subtest> used for async subtests.
=head1 SYNOPSIS
You should not use this directly.
=head1 METHODS
=over 4
=item $ast = $hub->ast
Get the L<Test2::AsyncSubtest> object to which this hub is bound.
=back
=head1 SOURCE
The source code repository for Test2-AsyncSubtest can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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>exodist7@gmail.comE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See F<http://dev.perl.org/licenses/>
=cut

87
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Bundle.pm Normal file
View file

@ -0,0 +1,87 @@
package Test2::Bundle;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Bundle - Documentation for bundles.
=head1 DESCRIPTION
Bundles are collections of Tools and Plugins. Bundles should not provide any
tools or behaviors of their own, they should simply combine the tools and
behaviors of other packages.
=head1 FAQ
=over 4
=item Should my bundle subclass Test2::Bundle?
No. Currently this class is empty. Eventually we may want to add behavior, in
which case we do not want anyone to already be subclassing it.
=back
=head1 HOW DO I WRITE A BUNDLE?
Writing a bundle can be very simple:
package Test2::Bundle::MyBundle;
use strict;
use warnings;
use Test2::Plugin::ExitSummary; # Load a plugin
use Test2::Tools::Basic qw/ok plan done_testing/;
# Re-export the tools
our @EXPORTS = qw/ok plan done_testing/;
use base 'Exporter';
1;
If you want to do anything more complex you should look into L<Import::Into>
and L<Symbol::Move>.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

487
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Bundle/Extended.pm Normal file
View file

@ -0,0 +1,487 @@
package Test2::Bundle::Extended;
use strict;
use warnings;
use Test2::V0;
our $VERSION = '0.000162';
BEGIN {
push @Test2::Bundle::Extended::ISA => 'Test2::V0';
no warnings 'once';
*EXPORT = \@Test2::V0::EXPORT;
}
our %EXPORT_TAGS = (
'v1' => \@Test2::Bundle::Extended::EXPORT,
);
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Bundle::Extended - Old name for Test2::V0
=head1 *** DEPRECATED ***
This bundle has been renamed to L<Test2::V0>, in which the C<':v1'> tag has
been removed as unnecessary.
=head1 DESCRIPTION
This is the big-daddy bundle. This bundle includes nearly every tool, and
several plugins, that the Test2 author uses. This bundle is used
extensively to test L<Test2::Suite> itself.
=head1 SYNOPSIS
use Test2::Bundle::Extended ':v1';
ok(1, "pass");
...
done_testing;
=head1 RESOLVING CONFLICTS WITH MOOSE
use Test2::Bundle::Extended '!meta';
L<Moose> and L<Test2::Bundle::Extended> both export very different C<meta()>
subs. Adding C<'!meta'> to the import args will prevent the sub from being
imported. This bundle also exports the sub under the name C<meta_check()> so
you can use that spelling as an alternative.
=head2 TAGS
=over 4
=item :v1
=item :DEFAULT
The following are all identical:
use Test2::Bundle::Extended;
use Test2::Bundle::Extended ':v1';
use Test2::Bundle::Extended ':DEFAULT';
=back
=head2 RENAMING ON IMPORT
use Test2::Bundle::Extended ':v1', '!ok', ok => {-as => 'my_ok'};
This bundle uses L<Importer> for exporting, as such you can use any arguments
it accepts.
Explanation:
=over 4
=item ':v1'
Use the default tag, all default exports.
=item '!ok'
Do not export C<ok()>
=item ok => {-as => 'my_ok'}
Actually, go ahead and import C<ok()> but under the name C<my_ok()>.
=back
If you did not add the C<'!ok'> argument then you would have both C<ok()> and
C<my_ok()>
=head1 PRAGMAS
All of these can be disabled via individual import arguments, or by the
C<-no_pragmas> argument.
use Test2::Bundle::Extended -no_pragmas => 1;
=head2 STRICT
L<strict> is turned on for you. You can disable this with the C<-no_strict> or
C<-no_pragmas> import arguments:
use Test2::Bundle::Extended -no_strict => 1;
=head2 WARNINGS
L<warnings> are turned on for you. You can disable this with the
C<-no_warnings> or C<-no_pragmas> import arguments:
use Test2::Bundle::Extended -no_warnings => 1;
=head2 UTF8
This is actually done via the L<Test2::Plugin::UTF8> plugin, see the
L</PLUGINS> section for details.
B<Note:> C<< -no_pragmas => 1 >> will turn off the entire plugin.
=head1 PLUGINS
=head2 SRAND
See L<Test2::Plugin::SRand>.
This will set the random seed to today's date. You can provide an alternate seed
with the C<-srand> import option:
use Test2::Bundle::Extended -srand => 1234;
=head2 UTF8
See L<Test2::Plugin::UTF8>.
This will set the file, and all output handles (including formatter handles), to
utf8. This will turn on the utf8 pragma for the current scope.
This can be disabled using the C<< -no_utf8 => 1 >> or C<< -no_pragmas => 1 >>
import arguments.
use Test2::Bundle::Extended -no_utf8 => 1;
=head2 EXIT SUMMARY
See L<Test2::Plugin::ExitSummary>.
This plugin has no configuration.
=head1 API FUNCTIONS
See L<Test2::API> for these
=over 4
=item $ctx = context()
=item $events = intercept { ... }
=back
=head1 TOOLS
=head2 TARGET
See L<Test2::Tools::Target>.
You can specify a target class with the C<-target> import argument. If you do
not provide a target then C<$CLASS> and C<CLASS()> will not be imported.
use Test2::Bundle::Extended -target => 'My::Class';
print $CLASS; # My::Class
print CLASS(); # My::Class
Or you can specify names:
use Test2::Bundle::Extended -target => { pkg => 'Some::Package' };
pkg()->xxx; # Call 'xxx' on Some::Package
$pkg->xxx; # Same
=over 4
=item $CLASS
Package variable that contains the target class name.
=item $class = CLASS()
Constant function that returns the target class name.
=back
=head2 DEFER
See L<Test2::Tools::Defer>.
=over 4
=item def $func => @args;
=item do_def()
=back
=head2 BASIC
See L<Test2::Tools::Basic>.
=over 4
=item ok($bool, $name)
=item pass($name)
=item fail($name)
=item diag($message)
=item note($message)
=item $todo = todo($reason)
=item todo $reason => sub { ... }
=item skip($reason, $count)
=item plan($count)
=item skip_all($reason)
=item done_testing()
=item bail_out($reason)
=back
=head2 COMPARE
See L<Test2::Tools::Compare>.
=over 4
=item is($got, $want, $name)
=item isnt($got, $do_not_want, $name)
=item like($got, qr/match/, $name)
=item unlike($got, qr/mismatch/, $name)
=item $check = match(qr/pattern/)
=item $check = mismatch(qr/pattern/)
=item $check = validator(sub { return $bool })
=item $check = hash { ... }
=item $check = array { ... }
=item $check = bag { ... }
=item $check = object { ... }
=item $check = meta { ... }
=item $check = number($num)
=item $check = string($str)
=item $check = check_isa($class_name)
=item $check = in_set(@things)
=item $check = not_in_set(@things)
=item $check = check_set(@things)
=item $check = item($thing)
=item $check = item($idx => $thing)
=item $check = field($name => $val)
=item $check = call($method => $expect)
=item $check = call_list($method => $expect)
=item $check = call_hash($method => $expect)
=item $check = prop($name => $expect)
=item $check = check($thing)
=item $check = T()
=item $check = F()
=item $check = D()
=item $check = DF()
=item $check = E()
=item $check = DNE()
=item $check = FDNE()
=item $check = U()
=item $check = L()
=item $check = exact_ref($ref)
=item end()
=item etc()
=item filter_items { grep { ... } @_ }
=item $check = event $type => ...
=item @checks = fail_events $type => ...
=back
=head2 CLASSIC COMPARE
See L<Test2::Tools::ClassicCompare>.
=over 4
=item cmp_ok($got, $op, $want, $name)
=back
=head2 SUBTEST
See L<Test2::Tools::Subtest>.
=over 4
=item subtest $name => sub { ... }
(Note: This is called C<subtest_buffered()> in the Tools module.)
=back
=head2 CLASS
See L<Test2::Tools::Class>.
=over 4
=item can_ok($thing, @methods)
=item isa_ok($thing, @classes)
=item DOES_ok($thing, @roles)
=back
=head2 ENCODING
See L<Test2::Tools::Encoding>.
=over 4
=item set_encoding($encoding)
=back
=head2 EXPORTS
See L<Test2::Tools::Exports>.
=over 4
=item imported_ok('function', '$scalar', ...)
=item not_imported_ok('function', '$scalar', ...)
=back
=head2 REF
See L<Test2::Tools::Ref>.
=over 4
=item ref_ok($ref, $type)
=item ref_is($got, $want)
=item ref_is_not($got, $do_not_want)
=back
=head2 MOCK
See L<Test2::Tools::Mock>.
=over 4
=item $control = mock ...
=item $bool = mocked($thing)
=back
=head2 EXCEPTION
See L<Test2::Tools::Exception>.
=over 4
=item $exception = dies { ... }
=item $bool = lives { ... }
=item $bool = try_ok { ... }
=back
=head2 WARNINGS
See L<Test2::Tools::Warnings>.
=over 4
=item $count = warns { ... }
=item $warning = warning { ... }
=item $warnings_ref = warnings { ... }
=item $bool = no_warnings { ... }
=back
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

241
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Bundle/More.pm Normal file
View file

@ -0,0 +1,241 @@
package Test2::Bundle::More;
use strict;
use warnings;
our $VERSION = '0.000162';
use Test2::Plugin::ExitSummary;
use Test2::Tools::Basic qw{
ok pass fail skip todo diag note
plan skip_all done_testing bail_out
};
use Test2::Tools::ClassicCompare qw{
is is_deeply isnt like unlike cmp_ok
};
use Test2::Tools::Class qw/can_ok isa_ok/;
use Test2::Tools::Subtest qw/subtest_streamed/;
BEGIN {
*BAIL_OUT = \&bail_out;
*subtest = \&subtest_streamed;
}
our @EXPORT = qw{
ok pass fail skip todo diag note
plan skip_all done_testing BAIL_OUT
is isnt like unlike is_deeply cmp_ok
isa_ok can_ok
subtest
};
use base 'Exporter';
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Bundle::More - ALMOST a drop-in replacement for Test::More.
=head1 DESCRIPTION
This bundle is intended to be a (mostly) drop-in replacement for
L<Test::More>. See L<"KEY DIFFERENCES FROM Test::More"> for details.
=head1 SYNOPSIS
use Test2::Bundle::More;
ok(1, "pass");
...
done_testing;
=head1 PLUGINS
This loads L<Test2::Plugin::ExitSummary>.
=head1 TOOLS
These are from L<Test2::Tools::Basic>. See L<Test2::Tools::Basic> for details.
=over 4
=item ok($bool, $name)
=item pass($name)
=item fail($name)
=item skip($why, $count)
=item $todo = todo($why)
=item diag($message)
=item note($message)
=item plan($count)
=item skip_all($why)
=item done_testing()
=item BAIL_OUT($why)
=back
These are from L<Test2::Tools::ClassicCompare>. See
L<Test2::Tools::ClassicCompare> for details.
=over 4
=item is($got, $want, $name)
=item isnt($got, $donotwant, $name)
=item like($got, qr/match/, $name)
=item unlike($got, qr/mismatch/, $name)
=item is_deeply($got, $want, "Deep compare")
=item cmp_ok($got, $op, $want, $name)
=back
These are from L<Test2::Tools::Class>. See L<Test2::Tools::Class> for details.
=over 4
=item isa_ok($thing, @classes)
=item can_ok($thing, @subs)
=back
This is from L<Test2::Tools::Subtest>. It is called C<subtest_streamed()> in
that package.
=over 4
=item subtest $name => sub { ... }
=back
=head1 KEY DIFFERENCES FROM Test::More
=over 4
=item You cannot plan at import.
THIS WILL B<NOT> WORK:
use Test2::Bundle::More tests => 5;
Instead you must plan in a separate statement:
use Test2::Bundle::More;
plan 5;
=item You have three subs imported for use in planning
Use C<plan($count)>, C<skip_all($reason)>, or C<done_testing()> for your
planning.
=item isa_ok accepts different arguments
C<isa_ok> in Test::More was:
isa_ok($thing, $isa, $alt_thing_name);
This was very inconsistent with tools like C<can_ok($thing, @subs)>.
In Test2::Bundle::More, C<isa_ok()> takes a C<$thing> and a list of C<@isa>.
isa_ok($thing, $class1, $class2, ...);
=back
=head2 THESE FUNCTIONS AND VARIABLES HAVE BEEN REMOVED
=over 4
=item $TODO
See C<todo()>.
=item use_ok()
=item require_ok()
These are not necessary. Use C<use> and C<require> directly. If there is an
error loading the module the test will catch the error and fail.
=item todo_skip()
Not necessary.
=item eq_array()
=item eq_hash()
=item eq_set()
Discouraged in Test::More.
=item explain()
This started a fight between Test developers, who may now each write their own
implementations in L<Test2>. (See explain in L<Test::Most> vs L<Test::More>.
Hint: Test::Most wrote it first, then Test::More added it, but broke
compatibility).
=item new_ok()
Not necessary.
=back
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

120
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Bundle/Simple.pm Normal file
View file

@ -0,0 +1,120 @@
package Test2::Bundle::Simple;
use strict;
use warnings;
our $VERSION = '0.000162';
use Test2::Plugin::ExitSummary;
use Test2::Tools::Basic qw/ok plan done_testing skip_all/;
our @EXPORT = qw/ok plan done_testing skip_all/;
use base 'Exporter';
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Bundle::Simple - ALMOST a drop-in replacement for Test::Simple.
=head1 DESCRIPTION
This bundle is intended to be a (mostly) drop-in replacement for
L<Test::Simple>. See L<"KEY DIFFERENCES FROM Test::Simple"> for details.
=head1 SYNOPSIS
use Test2::Bundle::Simple;
ok(1, "pass");
done_testing;
=head1 PLUGINS
This loads L<Test2::Plugin::ExitSummary>.
=head1 TOOLS
These are all from L<Test2::Tools::Basic>.
=over 4
=item ok($bool, $name)
Run a test. If bool is true, the test passes. If bool is false, it fails.
=item plan($count)
Tell the system how many tests to expect.
=item skip_all($reason)
Tell the system to skip all the tests (this will exit the script).
=item done_testing();
Tell the system that all tests are complete. You can use this instead of
setting a plan.
=back
=head1 KEY DIFFERENCES FROM Test::Simple
=over 4
=item You cannot plan at import.
THIS WILL B<NOT> WORK:
use Test2::Bundle::Simple tests => 5;
Instead you must plan in a separate statement:
use Test2::Bundle::Simple;
plan 5;
=item You have three subs imported for use in planning
Use C<plan($count)>, C<skip_all($reason)>, or C<done_testing()> for your
planning.
=back
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

449
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare.pm Normal file
View file

@ -0,0 +1,449 @@
package Test2::Compare;
use strict;
use warnings;
our $VERSION = '0.000162';
use Scalar::Util qw/blessed/;
use Test2::Util qw/try/;
use Test2::Util::Ref qw/rtype/;
use Carp qw/croak/;
our @EXPORT_OK = qw{
compare
get_build push_build pop_build build
strict_convert relaxed_convert convert
};
use base 'Exporter';
sub compare {
my ($got, $check, $convert) = @_;
$check = $convert->($check);
return $check->run(
id => undef,
got => $got,
exists => 1,
convert => $convert,
seen => {},
);
}
my @BUILD;
sub get_build { @BUILD ? $BUILD[-1] : undef }
sub push_build { push @BUILD => $_[0] }
sub pop_build {
return pop @BUILD if @BUILD && $_[0] && $BUILD[-1] == $_[0];
my $have = @BUILD ? "$BUILD[-1]" : 'undef';
my $want = $_[0] ? "$_[0]" : 'undef';
croak "INTERNAL ERROR: Attempted to pop incorrect build, have $have, tried to pop $want";
}
sub build {
my ($class, $code) = @_;
my @caller = caller(1);
die "'$caller[3]\()' should not be called in void context in $caller[1] line $caller[2]\n"
unless defined(wantarray);
my $build = $class->new(builder => $code, called => \@caller);
push @BUILD => $build;
my ($ok, $err) = try { $code->($build); 1 };
pop @BUILD;
die $err unless $ok;
return $build;
}
sub strict_convert { convert($_[0], { implicit_end => 1, use_regex => 0, use_code => 0 }) }
sub relaxed_convert { convert($_[0], { implicit_end => 0, use_regex => 1, use_code => 1 }) }
my $CONVERT_LOADED = 0;
my %ALLOWED_KEYS = ( implicit_end => 1, use_regex => 1, use_code => 1 );
sub convert {
my ($thing, $config) = @_;
unless($CONVERT_LOADED) {
require Test2::Compare::Array;
require Test2::Compare::Base;
require Test2::Compare::Custom;
require Test2::Compare::DeepRef;
require Test2::Compare::Hash;
require Test2::Compare::Pattern;
require Test2::Compare::Ref;
require Test2::Compare::Regex;
require Test2::Compare::Scalar;
require Test2::Compare::String;
require Test2::Compare::Undef;
require Test2::Compare::Wildcard;
$CONVERT_LOADED = 1;
}
if (ref($config)) {
my $bad = join ', ' => grep { !$ALLOWED_KEYS{$_} } keys %$config;
croak "The following config options are not understood by convert(): $bad" if $bad;
$config->{implicit_end} = 1 unless defined $config->{implicit_end};
$config->{use_regex} = 1 unless defined $config->{use_regex};
$config->{use_code} = 0 unless defined $config->{use_code};
}
else { # Legacy...
if ($config) {
$config = {
implicit_end => 1,
use_regex => 0,
use_code => 0,
};
}
else {
$config = {
implicit_end => 0,
use_regex => 1,
use_code => 1,
};
}
}
return _convert($thing, $config);
}
sub _convert {
my ($thing, $config) = @_;
return Test2::Compare::Undef->new()
unless defined $thing;
if (blessed($thing) && $thing->isa('Test2::Compare::Base')) {
if ($config->{implicit_end} && $thing->can('set_ending') && !defined $thing->ending) {
my $clone = $thing->clone;
$clone->set_ending('implicit');
return $clone;
}
return $thing unless $thing->isa('Test2::Compare::Wildcard');
my $newthing = _convert($thing->expect, $config);
$newthing->set_builder($thing->builder) unless $newthing->builder;
$newthing->set_file($thing->_file) unless $newthing->_file;
$newthing->set_lines($thing->_lines) unless $newthing->_lines;
return $newthing;
}
my $type = rtype($thing);
return Test2::Compare::Array->new(inref => $thing, $config->{implicit_end} ? (ending => 1) : ())
if $type eq 'ARRAY';
return Test2::Compare::Hash->new(inref => $thing, $config->{implicit_end} ? (ending => 1) : ())
if $type eq 'HASH';
return Test2::Compare::Pattern->new(
pattern => $thing,
stringify_got => 1,
) if $config->{use_regex} && $type eq 'REGEXP';
return Test2::Compare::Custom->new(code => $thing)
if $config->{use_code} && $type eq 'CODE';
return Test2::Compare::Regex->new(input => $thing)
if $type eq 'REGEXP';
if ($type eq 'SCALAR' || $type eq 'VSTRING') {
my $nested = _convert($$thing, $config);
return Test2::Compare::Scalar->new(item => $nested);
}
return Test2::Compare::DeepRef->new(input => $thing)
if $type eq 'REF';
return Test2::Compare::Ref->new(input => $thing)
if $type;
# is() will assume string and use 'eq'
return Test2::Compare::String->new(input => $thing);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare - Test2 extension for writing deep comparison tools.
=head1 DESCRIPTION
This library is the driving force behind deep comparison tools such as
C<Test2::Tools::Compare::is()> and
C<Test2::Tools::ClassicCompare::is_deeply()>.
=head1 SYNOPSIS
package Test2::Tools::MyCheck;
use Test2::Compare::MyCheck;
use Test2::Compare qw/compare/;
sub MyCheck {
my ($got, $exp, $name, @diag) = @_;
my $ctx = context();
my $delta = compare($got, $exp, \&convert);
if ($delta) {
$ctx->fail($name, $delta->diag, @diag);
}
else {
$ctx->ok(1, $name);
}
$ctx->release;
return !$delta;
}
sub convert {
my $thing = shift;
return $thing if blessed($thing) && $thing->isa('Test2::Compare::MyCheck');
return Test2::Compare::MyCheck->new(stuff => $thing);
}
See L<Test2::Compare::Base> for details about writing a custom check.
=head1 EXPORTS
=over 4
=item $delta = compare($got, $expect, \&convert)
This will compare the structures in C<$got> with those in C<$expect>, The
convert sub should convert vanilla structures inside C<$expect> into checks.
If there are differences in the structures they will be reported back as an
L<Test2::Compare::Delta> tree.
=item $build = get_build()
Get the current global build, if any.
=item push_build($build)
Set the current global build.
=item $build = pop_build($build)
Unset the current global build. This will throw an exception if the build
passed in is different from the current global.
=item build($class, sub { ... })
Run the provided codeblock with a new instance of C<$class> as the current
build. Returns the new build.
=item $check = convert($thing)
=item $check = convert($thing, $config)
This convert function is used by C<strict_convert()> and C<relaxed_convert()>
under the hood. It can also be used as the basis for other convert functions.
If you want to use it with a custom configuration you should wrap it in another
sub like so:
sub my_convert {
my $thing_to_convert = shift;
return convert(
$thing_to_convert,
{ ... }
);
}
Or the short variant:
sub my_convert { convert($_[0], { ... }) }
There are several configuration options, here they are with the default setting
listed first:
=over 4
=item implicit_end => 1
This option toggles array/hash boundaries. If this is true then no extra hash
keys or array indexes will be allowed. This setting effects generated compare
objects as well as any passed in.
=item use_regex => 1
This option toggles regex matching. When true (default) regexes are converted
to checks such that values must match the regex. When false regexes will be
compared to see if they are identical regexes.
=item use_code => 0
This option toggles code matching. When false (default) coderefs in structures
must be the same coderef as specified. When true coderefs will be run to verify
the value being checked.
=back
=item $check = strict_convert($thing)
Convert C<$thing> to an L<Test2::Compare::*> object. This will behave strictly
which means it uses these settings:
=over 4
=item implicit_end => 1
Array bounds will be checked when this object is used in a comparison. No
unexpected hash keys can be present.
=item use_code => 0
Sub references will be compared as refs (IE are these sub refs the same ref?)
=item use_regex => 0
Regexes will be compared directly (IE are the regexes the same?)
=back
=item $compare = relaxed_convert($thing)
Convert C<$thing> to an L<Test2::Compare::*> object. This will be relaxed which
means it uses these settings:
=over 4
=item implicit_end => 0
Array bounds will not be checked when this object is used in a comparison.
Unexpected hash keys can be present.
=item use_code => 1
Sub references will be run to verify a value.
=item use_regex => 1
Values will be checked against any regexes provided.
=back
=back
=head1 WRITING A VARIANT OF IS/LIKE
use Test2::Compare qw/compare convert/;
sub my_like($$;$@) {
my ($got, $exp, $name, @diag) = @_;
my $ctx = context();
# A custom converter that does the same thing as the one used by like()
my $convert = sub {
my $thing = shift;
return convert(
$thing,
{
implicit_end => 0,
use_code => 1,
use_regex => 1,
}
);
};
my $delta = compare($got, $exp, $convert);
if ($delta) {
$ctx->fail($name, $delta->diag, @diag);
}
else {
$ctx->ok(1, $name);
}
$ctx->release;
return !$delta;
}
The work of a comparison tool is done by 3 entities:
=over 4
=item compare()
The C<compare()> function takes the structure you got, the specification you
want to check against, and a C<\&convert> sub that will convert anything that
is not an instance of an L<Test2::Compare::Base> subclass into one.
This tool will use the C<\&convert> function on the specification, and then
produce an L<Test2::Compare::Delta> structure that outlines all the ways the
structure you got deviates from the specification.
=item \&convert
Converts anything that is not an instance of an L<Test2::Compare::Base>
subclass, and turns it into one. The objects this produces are able to check
that a structure matches a specification.
=item $delta
An instance of L<Test2::Compare::Delta> is ultimately returned. This object
represents all the ways in with the structure you got deviated from the
specification. The delta is a tree and may contain child deltas for nested
structures.
The delta is capable of rendering itself as a table, use C<< @lines =
$delta->diag >> to get the table (lines in C<@lines> will not be terminated
with C<"\n">).
=back
The C<convert()> function provided by this package contains all the
specification behavior of C<like()> and C<is()>. It is intended to be wrapped
in a sub that passes in a configuration hash, which allows you to control the
behavior.
You are free to write your own C<$check = compare($thing)> function, it just
needs to accept a single argument, and produce a single instance of an
L<Test2::Compare::Base> subclass.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

329
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Array.pm Normal file
View file

@ -0,0 +1,329 @@
package Test2::Compare::Array;
use strict;
use warnings;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/inref meta ending items order for_each/;
use Carp qw/croak confess/;
use Scalar::Util qw/reftype looks_like_number/;
sub init {
my $self = shift;
if( defined( my $ref = $self->{+INREF}) ) {
croak "Cannot specify both 'inref' and 'items'" if $self->{+ITEMS};
croak "Cannot specify both 'inref' and 'order'" if $self->{+ORDER};
croak "'inref' must be an array reference, got '$ref'" unless reftype($ref) eq 'ARRAY';
my $order = $self->{+ORDER} = [];
my $items = $self->{+ITEMS} = {};
for (my $i = 0; $i < @$ref; $i++) {
push @$order => $i;
$items->{$i} = $ref->[$i];
}
}
else {
$self->{+ITEMS} ||= {};
croak "All indexes listed in the 'items' hashref must be numeric"
if grep { !looks_like_number($_) } keys %{$self->{+ITEMS}};
$self->{+ORDER} ||= [sort { $a <=> $b } keys %{$self->{+ITEMS}}];
croak "All indexes listed in the 'order' arrayref must be numeric"
if grep { !(looks_like_number($_) || (ref($_) && reftype($_) eq 'CODE')) } @{$self->{+ORDER}};
}
$self->{+FOR_EACH} ||= [];
$self->SUPER::init();
}
sub name { '<ARRAY>' }
sub meta_class { 'Test2::Compare::Meta' }
sub verify {
my $self = shift;
my %params = @_;
return 0 unless $params{exists};
my $got = $params{got};
return 0 unless defined $got;
return 0 unless ref($got);
return 0 unless reftype($got) eq 'ARRAY';
return 1;
}
sub add_prop {
my $self = shift;
$self->{+META} = $self->meta_class->new unless defined $self->{+META};
$self->{+META}->add_prop(@_);
}
sub top_index {
my $self = shift;
my @order = @{$self->{+ORDER}};
while(@order) {
my $idx = pop @order;
next if ref $idx;
return $idx;
}
return undef; # No indexes
}
sub add_item {
my $self = shift;
my $check = pop;
my ($idx) = @_;
my $top = $self->top_index;
croak "elements must be added in order!"
if $top && $idx && $idx <= $top;
$idx = defined($top) ? $top + 1 : 0
unless defined($idx);
push @{$self->{+ORDER}} => $idx;
$self->{+ITEMS}->{$idx} = $check;
}
sub add_filter {
my $self = shift;
my ($code) = @_;
croak "A single coderef is required"
unless @_ == 1 && $code && ref $code && reftype($code) eq 'CODE';
push @{$self->{+ORDER}} => $code;
}
sub add_for_each {
my $self = shift;
push @{$self->{+FOR_EACH}} => @_;
}
sub deltas {
my $self = shift;
my %params = @_;
my ($got, $convert, $seen) = @params{qw/got convert seen/};
my @deltas;
my $state = 0;
my @order = @{$self->{+ORDER}};
my $items = $self->{+ITEMS};
my $for_each = $self->{+FOR_EACH};
my $meta = $self->{+META};
push @deltas => $meta->deltas(%params) if defined $meta;
# Make a copy that we can munge as needed.
my @list = @$got;
while (@order) {
my $idx = shift @order;
my $overflow = 0;
my $val;
# We have a filter, not an index
if (ref($idx)) {
@list = $idx->(@list);
next;
}
confess "Internal Error: Stacks are out of sync (state > idx)"
if $state > $idx + 1;
while ($state <= $idx) {
$overflow = !@list;
$val = shift @list;
# check-all goes here so we hit each item, even unspecified ones.
for my $check (@$for_each) {
last if $overflow; # avoid doing 'for each' checks beyond array bounds
$check = $convert->($check);
push @deltas => $check->run(
id => [ARRAY => $state],
convert => $convert,
seen => $seen,
exists => !$overflow,
$overflow ? () : (got => $val),
);
}
$state++;
}
confess "Internal Error: Stacks are out of sync (state != idx + 1)"
unless $state == $idx + 1;
my $check = $convert->($items->{$idx});
push @deltas => $check->run(
id => [ARRAY => $idx],
convert => $convert,
seen => $seen,
exists => !$overflow,
$overflow ? () : (got => $val),
);
}
while (@list && (@$for_each || $self->{+ENDING})) {
my $item = shift @list;
for my $check (@$for_each) {
$check = $convert->($check);
push @deltas => $check->run(
id => [ARRAY => $state],
convert => $convert,
seen => $seen,
got => $item,
exists => 1,
);
}
# if items are left over, and ending is true, we have a problem!
if ($self->{+ENDING}) {
push @deltas => $self->delta_class->new(
dne => 'check',
verified => undef,
id => [ARRAY => $state],
got => $item,
check => undef,
$self->{+ENDING} eq 'implicit' ? (note => 'implicit end') : (),
);
}
$state++;
}
return @deltas;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Array - Internal representation of an array comparison.
=head1 DESCRIPTION
This module is an internal representation of an array for comparison purposes.
=head1 METHODS
=over 4
=item $ref = $arr->inref()
If the instance was constructed from an actual array, this will return the
reference to that array.
=item $bool = $arr->ending
=item $arr->set_ending($bool)
Set this to true if you would like to fail when the array being validated has
more items than the check. That is, if you check indexes 0-3 but the array has
values for indexes 0-4, it will fail and list that last item in the array as
unexpected. If set to false then it is assumed you do not care about extra
items.
=item $hashref = $arr->items()
Returns the hashref of C<< key => val >> pairs to be checked in the
array.
=item $arr->set_items($hashref)
Accepts a hashref to permit indexes to be skipped if desired.
B<Note:> that there is no validation when using C<set_items>, it is better to
use the C<add_item> interface.
=item $arrayref = $arr->order()
Returns an arrayref of all indexes that will be checked, in order.
=item $arr->set_order($arrayref)
Sets the order in which indexes will be checked.
B<Note:> that there is no validation when using C<set_order>, it is better to
use the C<add_item> interface.
=item $name = $arr->name()
Always returns the string C<< "<ARRAY>" >>.
=item $bool = $arr->verify(got => $got, exists => $bool)
Check if C<$got> is an array reference or not.
=item $idx = $arr->top_index()
Returns the topmost index which is checked. This will return undef if there
are no items, or C<0> if there is only 1 item.
=item $arr->add_item($item)
Push an item onto the list of values to be checked.
=item $arr->add_item($idx => $item)
Add an item to the list of values to be checked at the specified index.
=item $arr->add_filter(sub { ... })
Add a filter sub. The filter receives all remaining values of the array being
checked, and should return the values that should still be checked. The filter
will be run between the last item added and the next item added.
=item @deltas = $arr->deltas(got => $got, convert => \&convert, seen => \%seen)
Find the differences between the expected array values and those in the C<$got>
arrayref.
=back
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

244
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Bag.pm Normal file
View file

@ -0,0 +1,244 @@
package Test2::Compare::Bag;
use strict;
use warnings;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/ending meta items for_each/;
use Carp qw/croak confess/;
use Scalar::Util qw/reftype looks_like_number/;
sub init {
my $self = shift;
$self->{+ITEMS} ||= [];
$self->{+FOR_EACH} ||= [];
$self->SUPER::init();
}
sub name { '<BAG>' }
sub meta_class { 'Test2::Compare::Meta' }
sub verify {
my $self = shift;
my %params = @_;
return 0 unless $params{exists};
my $got = $params{got} || return 0;
return 0 unless ref($got);
return 0 unless reftype($got) eq 'ARRAY';
return 1;
}
sub add_prop {
my $self = shift;
$self->{+META} = $self->meta_class->new unless defined $self->{+META};
$self->{+META}->add_prop(@_);
}
sub add_item {
my $self = shift;
my $check = pop;
my ($idx) = @_;
push @{$self->{+ITEMS}}, $check;
}
sub add_for_each {
my $self = shift;
push @{$self->{+FOR_EACH}} => @_;
}
sub deltas {
my $self = shift;
my %params = @_;
my ($got, $convert, $seen) = @params{qw/got convert seen/};
my @deltas;
my $state = 0;
my @items = @{$self->{+ITEMS}};
my @for_each = @{$self->{+FOR_EACH}};
# Make a copy that we can munge as needed.
my @list = @$got;
my %unmatched = map { $_ => $list[$_] } 0..$#list;
my $meta = $self->{+META};
push @deltas => $meta->deltas(%params) if defined $meta;
while (@items) {
my $item = shift @items;
my $check = $convert->($item);
my $match = 0;
for my $idx (0..$#list) {
next unless exists $unmatched{$idx};
my $val = $list[$idx];
my $deltas = $check->run(
id => [ARRAY => $idx],
convert => $convert,
seen => $seen,
exists => 1,
got => $val,
);
unless ($deltas) {
$match++;
delete $unmatched{$idx};
last;
}
}
unless ($match) {
push @deltas => $self->delta_class->new(
dne => 'got',
verified => undef,
id => [ARRAY => '*'],
got => undef,
check => $check,
);
}
}
if (@for_each) {
my @checks = map { $convert->($_) } @for_each;
for my $idx (0..$#list) {
# All items are matched if we have conditions for all items
delete $unmatched{$idx};
my $val = $list[$idx];
for my $check (@checks) {
push @deltas => $check->run(
id => [ARRAY => $idx],
convert => $convert,
seen => $seen,
exists => 1,
got => $val,
);
}
}
}
# if elements are left over, and ending is true, we have a problem!
if($self->{+ENDING} && keys %unmatched) {
for my $idx (sort keys %unmatched) {
my $elem = $list[$idx];
push @deltas => $self->delta_class->new(
dne => 'check',
verified => undef,
id => [ARRAY => $idx],
got => $elem,
check => undef,
$self->{+ENDING} eq 'implicit' ? (note => 'implicit end') : (),
);
}
}
return @deltas;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Bag - Internal representation of a bag comparison.
=head1 DESCRIPTION
This module is an internal representation of a bag for comparison purposes.
=head1 METHODS
=over 4
=item $bool = $arr->ending
=item $arr->set_ending($bool)
Set this to true if you would like to fail when the array being validated has
more items than the check. That is, if you check for 4 items but the array has
5 values, it will fail and list that unmatched item in the array as
unexpected. If set to false then it is assumed you do not care about extra
items.
=item $arrayref = $arr->items()
Returns the arrayref of values to be checked in the array.
=item $arr->set_items($arrayref)
Accepts an arrayref.
B<Note:> that there is no validation when using C<set_items>, it is better to
use the C<add_item> interface.
=item $name = $arr->name()
Always returns the string C<< "<BAG>" >>.
=item $bool = $arr->verify(got => $got, exists => $bool)
Check if C<$got> is an array reference or not.
=item $arr->add_item($item)
Push an item onto the list of values to be checked.
=item @deltas = $arr->deltas(got => $got, convert => \&convert, seen => \%seen)
Find the differences between the expected bag values and those in the C<$got>
arrayref.
=back
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=item Gianni Ceccarelli E<lt>dakkar@thenautilus.netE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=item Gianni Ceccarelli E<lt>dakkar@thenautilus.netE<gt>
=back
=head1 COPYRIGHT
Copyright 2018 Chad Granum E<lt>exodist@cpan.orgE<gt>.
Copyright 2018 Gianni Ceccarelli E<lt>dakkar@thenautilus.netE<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

252
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Base.pm Normal file
View file

@ -0,0 +1,252 @@
package Test2::Compare::Base;
use strict;
use warnings;
our $VERSION = '0.000162';
use Carp qw/confess croak/;
use Scalar::Util qw/blessed/;
use Test2::Util::Sub qw/sub_info/;
use Test2::Compare::Delta();
sub MAX_CYCLES() { 75 }
use Test2::Util::HashBase qw{builder _file _lines _info called};
use Test2::Util::Ref qw/render_ref/;
{
no warnings 'once';
*set_lines = \&set__lines;
*set_file = \&set__file;
}
sub clone {
my $self = shift;
my $class = blessed($self);
# Shallow copy is good enough for all the current compare types.
return bless({%$self}, $class);
}
sub init {
my $self = shift;
$self->{+_LINES} = delete $self->{lines} if exists $self->{lines};
$self->{+_FILE} = delete $self->{file} if exists $self->{file};
}
sub file {
my $self = shift;
return $self->{+_FILE} if $self->{+_FILE};
if ($self->{+BUILDER}) {
$self->{+_INFO} ||= sub_info($self->{+BUILDER});
return $self->{+_INFO}->{file};
}
elsif ($self->{+CALLED}) {
return $self->{+CALLED}->[1];
}
return undef;
}
sub lines {
my $self = shift;
return $self->{+_LINES} if $self->{+_LINES};
if ($self->{+BUILDER}) {
$self->{+_INFO} ||= sub_info($self->{+BUILDER});
return $self->{+_INFO}->{lines} if @{$self->{+_INFO}->{lines}};
}
if ($self->{+CALLED}) {
return [$self->{+CALLED}->[2]];
}
return [];
}
sub delta_class { 'Test2::Compare::Delta' }
sub deltas { () }
sub got_lines { () }
sub stringify_got { 0 }
sub operator { '' }
sub verify { confess "unimplemented" }
sub name { confess "unimplemented" }
sub render {
my $self = shift;
return $self->name;
}
sub run {
my $self = shift;
my %params = @_;
my $id = $params{id};
my $convert = $params{convert} or confess "no convert sub provided";
my $seen = $params{seen} ||= {};
$params{exists} = exists $params{got} ? 1 : 0
unless exists $params{exists};
my $exists = $params{exists};
my $got = $exists ? $params{got} : undef;
my $gotname = render_ref($got);
# Prevent infinite cycles
if (defined($got) && ref $got) {
die "Cycle detected in comparison, aborting"
if $seen->{$gotname} && $seen->{$gotname} >= MAX_CYCLES;
$seen->{$gotname}++;
}
my $ok = $self->verify(%params);
my @deltas = $ok ? $self->deltas(%params) : ();
$seen->{$gotname}-- if defined $got && ref $got;
return if $ok && !@deltas;
return $self->delta_class->new(
verified => $ok,
id => $id,
got => $got,
check => $self,
children => \@deltas,
$exists ? () : (dne => 'got'),
);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Base - Base class for comparison classes.
=head1 DESCRIPTION
All comparison classes for Test2::Compare should inherit from this base class.
=head1 SYNOPSIS
package Test2::Compare::MyCheck;
use strict;
use warnings;
use base 'Test2::Compare::Base';
use Test2::Util::HashBase qw/stuff/;
sub name { 'STUFF' }
sub operator {
my $self = shift;
my ($got) = @_;
return 'eq';
}
sub verify {
my $self = shift;
my $params = @_;
# Always check if $got exists! This method must return false if no
# value at all was received.
return 0 unless $params{exists};
my $got = $params{got};
# Returns true if both values match. This includes undef, 0, and other
# false-y values!
return $got eq $self->stuff;
}
=head1 METHODS
Some of these must be overridden, others can be.
=over 4
=item $dclass = $check->delta_class
Returns the delta subclass that should be used. By default
L<Test2::Compare::Delta> is used.
=item @deltas = $check->deltas(id => $id, exists => $bool, got => $got, convert => \&convert, seen => \%seen)
Should return child deltas.
=item @lines = $check->got_lines($got)
This is your chance to provide line numbers for errors in the C<$got>
structure.
=item $op = $check->operator()
=item $op = $check->operator($got)
Returns the operator that was used to compare the check with the received data
in C<$got>. If there was no value for got then there will be no arguments,
undef will only be an argument if undef was seen in C<$got>. This is how you
can tell the difference between a missing value and an undefined one.
=item $bool = $check->verify(id => $id, exists => $bool, got => $got, convert => \&convert, seen => \%seen)
Return true if there is a shallow match, that is both items are arrayrefs, both
items are the same string or same number, etc. This should not recurse, as deep
checks are done in C<< $check->deltas() >>.
=item $name = $check->name
Get the name of the check.
=item $display = $check->render
What should be displayed in a table for this check, usually the name or value.
=item $delta = $check->run(id => $id, exists => $bool, got => $got, convert => \&convert, seen => \%seen)
This is where the checking is done, first a shallow check using
C<< $check->verify >>, then checking C<< $check->deltas() >>. C<\%seen> is used
to prevent cycles.
=back
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

111
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Bool.pm Normal file
View file

@ -0,0 +1,111 @@
package Test2::Compare::Bool;
use strict;
use warnings;
use Carp qw/confess/;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/input/;
# Overloads '!' for us.
use Test2::Compare::Negatable;
sub name {
my $self = shift;
my $in = $self->{+INPUT};
return _render_bool($in);
}
sub operator {
my $self = shift;
return '!=' if $self->{+NEGATE};
return '==';
}
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
return 0 unless $exists;
my $want = $self->{+INPUT};
my $match = ($want xor $got) ? 0 : 1;
$match = $match ? 0 : 1 if $self->{+NEGATE};
return $match;
}
sub run {
my $self = shift;
my $delta = $self->SUPER::run(@_) or return;
my $dne = $delta->dne || "";
unless ($dne eq 'got') {
my $got = $delta->got;
$delta->set_got(_render_bool($got));
}
return $delta;
}
sub _render_bool {
my $bool = shift;
my $name = $bool ? 'TRUE' : 'FALSE';
my $val = defined $bool ? $bool : 'undef';
$val = "''" unless length($val);
return "<$name ($val)>";
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Bool - Compare two values as booleans
=head1 DESCRIPTION
Check if two values have the same boolean result (both true, or both false).
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

182
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Custom.pm Normal file
View file

@ -0,0 +1,182 @@
package Test2::Compare::Custom;
use strict;
use warnings;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/code name operator stringify_got/;
use Carp qw/croak/;
sub init {
my $self = shift;
croak "'code' is required" unless $self->{+CODE};
$self->{+OPERATOR} ||= 'CODE(...)';
$self->{+NAME} ||= '<Custom Code>';
$self->{+STRINGIFY_GOT} = $self->SUPER::stringify_got()
unless defined $self->{+STRINGIFY_GOT};
$self->SUPER::init();
}
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
my $code = $self->{+CODE};
local $_ = $got;
my $ok = $code->(
got => $got,
exists => $exists,
operator => $self->{+OPERATOR},
name => $self->{+NAME},
);
return $ok;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Custom - Custom field check for comparisons.
=head1 DESCRIPTION
Sometimes you want to do something complicated or unusual when validating a
field nested inside a deep data structure. You could pull it out of the
structure and test it separately, or you can use this to embed the check. This
provides a way for you to write custom checks for fields in deep comparisons.
=head1 SYNOPSIS
my $cus = Test2::Compare::Custom->new(
name => 'IsRef',
operator => 'ref(...)',
stringify_got => 1,
code => sub {
my %args = @_;
return $args{got} ? 1 : 0;
},
);
# Pass
is(
{ a => 1, ref => {}, b => 2 },
{ a => 1, ref => $cus, b => 2 },
"This will pass"
);
# Fail
is(
{a => 1, ref => 'notref', b => 2},
{a => 1, ref => $cus, b => 2},
"This will fail"
);
=head1 ARGUMENTS
Your custom sub will be passed 4 arguments in a hash:
code => sub {
my %args = @_;
# provides got, exists, operator, name
return ref($args{got}) ? 1 : 0;
},
C<$_> is also localized to C<got> to make it easier for those who need to use
regexes.
=over 4
=item got
=item $_
The value to be checked.
=item exists
This will be a boolean. This will be true if C<got> exists at all. If
C<exists> is false then it means C<got> is not simply undef, but doesn't
exist at all (think checking the value of a hash key that does not exist).
=item operator
The operator specified at construction.
=item name
The name provided at construction.
=back
=head1 METHODS
=over 4
=item $code = $cus->code
Returns the coderef provided at construction.
=item $name = $cus->name
Returns the name provided at construction.
=item $op = $cus->operator
Returns the operator provided at construction.
=item $stringify = $cus->stringify_got
Returns the stringify_got flag provided at construction.
=item $bool = $cus->verify(got => $got, exists => $bool)
=back
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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 Daniel Böhmer E<lt>dboehmer@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

119
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/DeepRef.pm Normal file
View file

@ -0,0 +1,119 @@
package Test2::Compare::DeepRef;
use strict;
use warnings;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/input/;
use Test2::Util::Ref qw/render_ref rtype/;
use Scalar::Util qw/refaddr/;
use Carp qw/croak/;
sub init {
my $self = shift;
croak "'input' is a required attribute"
unless $self->{+INPUT};
croak "'input' must be a reference, got '" . $self->{+INPUT} . "'"
unless ref $self->{+INPUT};
$self->SUPER::init();
}
sub name { '<REF>' }
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
return 0 unless $exists;
my $in = $self->{+INPUT};
return 0 unless ref $in;
return 0 unless ref $got;
my $in_type = rtype($in);
my $got_type = rtype($got);
return 0 unless $in_type eq $got_type;
return 1;
}
sub deltas {
my $self = shift;
my %params = @_;
my ($got, $convert, $seen) = @params{qw/got convert seen/};
my $in = $self->{+INPUT};
my $in_type = rtype($in);
my $got_type = rtype($got);
my $check = $convert->($$in);
return $check->run(
id => ['DEREF' => '$*'],
convert => $convert,
seen => $seen,
got => $$got,
exists => 1,
);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::DeepRef - Ref comparison
=head1 DESCRIPTION
Used to compare two refs in a deep comparison.
=head1 SYNOPSIS
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

558
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Delta.pm Normal file
View file

@ -0,0 +1,558 @@
package Test2::Compare::Delta;
use strict;
use warnings;
our $VERSION = '0.000162';
use Test2::Util::HashBase qw{verified id got chk children dne exception note};
use Test2::EventFacet::Info::Table;
use Test2::Util::Table();
use Test2::API qw/context/;
use Test2::Util::Ref qw/render_ref rtype/;
use Carp qw/croak/;
# 'CHECK' constant would not work, but I like exposing 'check()' to people
# using this class.
BEGIN {
no warnings 'once';
*check = \&chk;
*set_check = \&set_chk;
}
my @COLUMN_ORDER = qw/PATH GLNs GOT OP CHECK CLNs/;
my %COLUMNS = (
GOT => {name => 'GOT', value => sub { $_[0]->render_got }, no_collapse => 1},
CHECK => {name => 'CHECK', value => sub { $_[0]->render_check }, no_collapse => 1},
OP => {name => 'OP', value => sub { $_[0]->table_op } },
PATH => {name => 'PATH', value => sub { $_[1] } },
'GLNs' => {name => 'GLNs', alias => 'LNs', value => sub { $_[0]->table_got_lines } },
'CLNs' => {name => 'CLNs', alias => 'LNs', value => sub { $_[0]->table_check_lines }},
);
{
my $i = 0;
$COLUMNS{$_}->{id} = $i++ for @COLUMN_ORDER;
}
sub remove_column {
my $class = shift;
my $header = shift;
@COLUMN_ORDER = grep { $_ ne $header } @COLUMN_ORDER;
delete $COLUMNS{$header} ? 1 : 0;
}
sub add_column {
my $class = shift;
my $name = shift;
croak "Column name is required"
unless $name;
croak "Column '$name' is already defined"
if $COLUMNS{$name};
my %params;
if (@_ == 1) {
%params = (value => @_, name => $name);
}
else {
%params = (@_, name => $name);
}
my $value = $params{value};
croak "You must specify a 'value' callback"
unless $value;
croak "'value' callback must be a CODE reference"
unless rtype($value) eq 'CODE';
if ($params{prefix}) {
unshift @COLUMN_ORDER => $name;
}
else {
push @COLUMN_ORDER => $name;
}
$COLUMNS{$name} = \%params;
}
sub set_column_alias {
my ($class, $name, $alias) = @_;
croak "Tried to alias a non-existent column"
unless exists $COLUMNS{$name};
croak "Missing alias" unless defined $alias;
$COLUMNS{$name}->{alias} = $alias;
}
sub init {
my $self = shift;
croak "Cannot specify both 'check' and 'chk' as arguments"
if exists($self->{check}) && exists($self->{+CHK});
# Allow 'check' as an argument
$self->{+CHK} ||= delete $self->{check}
if exists $self->{check};
}
sub render_got {
my $self = shift;
my $exp = $self->{+EXCEPTION};
if ($exp) {
chomp($exp = "$exp");
$exp =~ s/\n.*$//g;
return "<EXCEPTION: $exp>";
}
my $dne = $self->{+DNE};
return '<DOES NOT EXIST>' if $dne && $dne eq 'got';
my $got = $self->{+GOT};
return '<UNDEF>' unless defined $got;
my $check = $self->{+CHK};
my $stringify = defined( $check ) && $check->stringify_got;
return render_ref($got) if ref $got && !$stringify;
return "$got";
}
sub render_check {
my $self = shift;
my $dne = $self->{+DNE};
return '<DOES NOT EXIST>' if $dne && $dne eq 'check';
my $check = $self->{+CHK};
return '<UNDEF>' unless defined $check;
return $check->render;
}
sub _full_id {
my ($type, $id) = @_;
return "<$id>" if !$type || $type eq 'META';
return $id if $type eq 'SCALAR';
return "{$id}" if $type eq 'HASH';
return "{$id} <KEY>" if $type eq 'HASHKEY';
return "[$id]" if $type eq 'ARRAY';
return "$id()" if $type eq 'METHOD';
return "$id" if $type eq 'DEREF';
return "<$id>";
}
sub _arrow_id {
my ($path, $type) = @_;
return '' unless $path;
return ' ' if !$type || $type eq 'META'; # Meta gets a space, not an arrow
return '->' if $type eq 'METHOD'; # Method always needs an arrow
return '->' if $type eq 'SCALAR'; # Scalar always needs an arrow
return '->' if $type eq 'DEREF'; # deref always needs arrow
return '->' if $path =~ m/(>|\(\))$/; # Need an arrow after meta, or after a method
return '->' if $path eq '$VAR'; # Need an arrow after the initial ref
# Hash and array need an arrow unless they follow another hash/array
return '->' if $type =~ m/^(HASH|ARRAY)$/ && $path !~ m/(\]|\})$/;
# No arrow needed
return '';
}
sub _join_id {
my ($path, $parts) = @_;
my ($type, $key) = @$parts;
my $id = _full_id($type, $key);
my $join = _arrow_id($path, $type);
return "${path}${join}${id}";
}
sub should_show {
my $self = shift;
return 1 unless $self->verified;
defined( my $check = $self->check ) || return 0;
return 0 unless $check->lines;
my $file = $check->file || return 0;
my $ctx = context();
my $cfile = $ctx->trace->file;
$ctx->release;
return 0 unless $file eq $cfile;
return 1;
}
sub filter_visible {
my $self = shift;
my @deltas;
my @queue = (['', $self]);
while (my $set = shift @queue) {
my ($path, $delta) = @$set;
push @deltas => [$path, $delta] if $delta->should_show;
my $children = $delta->children || next;
next unless @$children;
my @new;
for my $child (@$children) {
my $cpath = _join_id($path, $child->id);
push @new => [$cpath, $child];
}
unshift @queue => @new;
}
return \@deltas;
}
sub table_header { [map {$COLUMNS{$_}->{alias} || $_} @COLUMN_ORDER] }
sub table_op {
my $self = shift;
defined( my $check = $self->{+CHK} ) || return '!exists';
return $check->operator($self->{+GOT})
unless $self->{+DNE} && $self->{+DNE} eq 'got';
return $check->operator();
}
sub table_check_lines {
my $self = shift;
defined( my $check = $self->{+CHK} ) || return '';
my $lines = $check->lines || return '';
return '' unless @$lines;
return join ', ' => @$lines;
}
sub table_got_lines {
my $self = shift;
defined( my $check = $self->{+CHK} ) || return '';
return '' if $self->{+DNE} && $self->{+DNE} eq 'got';
my @lines = $check->got_lines($self->{+GOT});
return '' unless @lines;
return join ', ' => @lines;
}
sub table_rows {
my $self = shift;
my $deltas = $self->filter_visible;
my @rows;
for my $set (@$deltas) {
my ($id, $d) = @$set;
my @row;
for my $col (@COLUMN_ORDER) {
my $spec = $COLUMNS{$col};
my $val = $spec->{value}->($d, $id);
$val = '' unless defined $val;
push @row => $val;
}
push @rows => \@row;
}
return \@rows;
}
sub table {
my $self = shift;
my @diag;
my $header = $self->table_header;
my $rows = $self->table_rows;
my $render_rows = [@$rows];
my $max = exists $ENV{TS_MAX_DELTA} ? $ENV{TS_MAX_DELTA} : 25;
if ($max && @$render_rows > $max) {
@$render_rows = map { [@$_] } @{$render_rows}[0 .. ($max - 1)];
@diag = (
"************************************************************",
sprintf("* Stopped after %-42.42s *", "$max differences."),
"* Set the TS_MAX_DELTA environment var to raise the limit. *",
"* Set it to 0 for no limit. *",
"************************************************************",
);
}
my @dne;
for my $row (@$render_rows) {
my $got = $row->[$COLUMNS{GOT}->{id}] || '';
my $chk = $row->[$COLUMNS{CHECK}->{id}] || '';
if ($got eq '<DOES NOT EXIST>') {
push @dne => "$row->[$COLUMNS{PATH}->{id}]: DOES NOT EXIST";
}
elsif ($chk eq '<DOES NOT EXIST>') {
push @dne => "$row->[$COLUMNS{PATH}->{id}]: SHOULD NOT EXIST";
}
}
if (@dne) {
unshift @dne => '==== Summary of missing/extra items ====';
push @dne => '== end summary of missing/extra items ==';
}
my $table_args = {
header => $header,
collapse => 1,
sanitize => 1,
mark_tail => 1,
no_collapse => [grep { $COLUMNS{$COLUMN_ORDER[$_]}->{no_collapse} } 0 .. $#COLUMN_ORDER],
};
my $render = join "\n" => (
Test2::Util::Table::table(%$table_args, rows => $render_rows),
@dne,
@diag,
);
my $table = Test2::EventFacet::Info::Table->new(
%$table_args,
rows => $rows,
as_string => $render,
);
return $table;
}
sub diag { shift->table }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Delta - Representation of differences between nested data
structures.
=head1 DESCRIPTION
This is used by L<Test2::Compare>. When data structures are compared a
delta will be returned. Deltas are a tree data structure that represent all the
differences between two other data structures.
=head1 METHODS
=head2 CLASS METHODS
=over 4
=item $class->add_column($NAME => sub { ... })
=item $class->add_column($NAME, %PARAMS)
This can be used to add columns to the table that it produced when a comparison
fails. The first argument should always be the column name, which must be
unique.
The first form simply takes a coderef that produces the value that should be
displayed in the column for any given delta. The arguments passed into the sub
are the delta, and the row ID.
Test2::Compare::Delta->add_column(
Foo => sub {
my ($delta, $id) = @_;
return $delta->... ? 'foo' : 'bar'
},
);
The second form allows you some extra options. The C<'value'> key is required,
and must be a coderef. All other keys are optional.
Test2::Compare::Delta->add_column(
'Foo', # column name
value => sub { ... }, # how to get the cell value
alias => 'FOO', # Display name (used in table header)
no_collapse => $bool, # Show column even if it has no values?
);
=item $bool = $class->remove_column($NAME)
This will remove the specified column. This will return true if the column
existed and was removed. This will return false if the column did not exist. No
exceptions are thrown. If a missing column is a problem then you need to check
the return yourself.
=item $class->set_column_alias($NAME, $ALIAS)
This can be used to change the table header, overriding the default column
names with new ones.
=back
=head2 ATTRIBUTES
=over 4
=item $bool = $delta->verified
=item $delta->set_verified($bool)
This will be true if the delta itself matched, if the delta matched then the
problem is in the delta's children, not the delta itself.
=item $aref = $delta->id
=item $delta->set_id([$type, $name])
ID for the delta, used to produce the path into the data structure. An
example is C<< ['HASH' => 'foo'] >> which means the delta is in the path
C<< ...->{'foo'} >>. Valid types are C<HASH>, C<ARRAY>, C<SCALAR>, C<META>, and
C<METHOD>.
=item $val = $delta->got
=item $delta->set_got($val)
Deltas are produced by comparing a received data structure 'got' against a
check data structure 'check'. The 'got' attribute contains the value that was
received for comparison.
=item $check = $delta->chk
=item $check = $delta->check
=item $delta->set_chk($check)
=item $delta->set_check($check)
Deltas are produced by comparing a received data structure 'got' against a
check data structure 'check'. The 'check' attribute contains the value that was
expected in the comparison.
C<check> and C<chk> are aliases for the same attribute.
=item $aref = $delta->children
=item $delta->set_children([$delta1, $delta2, ...])
A Delta may have child deltas. If it does then this is an arrayref with those
children.
=item $dne = $delta->dne
=item $delta->set_dne($dne)
Sometimes a comparison results in one side or the other not existing at all, in
which case this is set to the name of the attribute that does not exist. This
can be set to 'got' or 'check'.
=item $e = $delta->exception
=item $delta->set_exception($e)
This will be set to the exception in cases where the comparison failed due to
an exception being thrown.
=back
=head2 OTHER
=over 4
=item $string = $delta->render_got
Renders the string that should be used in a table to represent the received
value in a comparison.
=item $string = $delta->render_check
Renders the string that should be used in a table to represent the expected
value in a comparison.
=item $bool = $delta->should_show
This will return true if the delta should be shown in the table. This is
normally true for any unverified delta. This will also be true for deltas that
contain extra useful debug information.
=item $aref = $delta->filter_visible
This will produce an arrayref of C<< [ $path => $delta ] >> for all deltas that
should be displayed in the table.
=item $aref = $delta->table_header
This returns an array ref of the headers for the table.
=item $string = $delta->table_op
This returns the operator that should be shown in the table.
=item $string = $delta->table_check_lines
This returns the defined lines (extra debug info) that should be displayed.
=item $string = $delta->table_got_lines
This returns the generated lines (extra debug info) that should be displayed.
=item $aref = $delta->table_rows
This returns an arrayref of table rows, each row is itself an arrayref.
=item @table_lines = $delta->table
Returns all the lines of the table that should be displayed.
=back
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

81
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Event.pm Normal file
View file

@ -0,0 +1,81 @@
package Test2::Compare::Event;
use strict;
use warnings;
use Scalar::Util qw/blessed/;
use Test2::Compare::EventMeta();
use base 'Test2::Compare::Object';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/etype/;
sub name {
my $self = shift;
my $etype = $self->etype;
return "<EVENT: $etype>";
}
sub meta_class { 'Test2::Compare::EventMeta' }
sub object_base { 'Test2::Event' }
sub got_lines {
my $self = shift;
my ($event) = @_;
return unless $event;
return unless blessed($event);
return unless $event->isa('Test2::Event');
return unless $event->trace;
return ($event->trace->line);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Event - Event specific Object subclass.
=head1 DESCRIPTION
This module is used to represent an expected event in a deep comparison.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

100
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/EventMeta.pm Normal file
View file

@ -0,0 +1,100 @@
package Test2::Compare::EventMeta;
use strict;
use warnings;
use base 'Test2::Compare::Meta';
our $VERSION = '0.000162';
use Test2::Util::HashBase;
sub get_prop_file { $_[1]->trace->file }
sub get_prop_line { $_[1]->trace->line }
sub get_prop_package { $_[1]->trace->package }
sub get_prop_subname { $_[1]->trace->subname }
sub get_prop_debug { $_[1]->trace->debug }
sub get_prop_tid { $_[1]->trace->tid }
sub get_prop_pid { $_[1]->trace->pid }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::EventMeta - Meta class for events in deep comparisons
=head1 DESCRIPTION
This is used in deep comparisons of event objects. You should probably never
use this directly.
=head1 DEFINED CHECKS
=over 4
=item file
File that generated the event.
=item line
Line where the event was generated.
=item package
Package that generated the event.
=item subname
Name of the tool that generated the event.
=item debug
The debug information that will be printed in event of a failure.
=item tid
Thread ID of the thread that generated the event.
=item pid
Process ID of the process that generated the event.
=back
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

177
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Float.pm Normal file
View file

@ -0,0 +1,177 @@
package Test2::Compare::Float;
use strict;
use warnings;
use Carp qw/confess/;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
our $DEFAULT_TOLERANCE = 1e-08;
use Test2::Util::HashBase qw/input tolerance precision/;
# Overloads '!' for us.
use Test2::Compare::Negatable;
sub init {
my $self = shift;
my $input = $self->{+INPUT};
if ( exists $self->{+TOLERANCE} and exists $self->{+PRECISION} ) {
confess "can't set both tolerance and precision";
} elsif (!exists $self->{+PRECISION} and !exists $self->{+TOLERANCE}) {
$self->{+TOLERANCE} = $DEFAULT_TOLERANCE
}
confess "input must be defined for 'Float' check"
unless defined $input;
# Check for ''
confess "input must be a number for 'Float' check"
unless length($input) && $input =~ m/\S/;
confess "precision must be an integer for 'Float' check"
if exists $self->{+PRECISION} && $self->{+PRECISION} !~ m/^\d+$/;
$self->SUPER::init(@_);
}
sub name {
my $self = shift;
my $in = $self->{+INPUT};
my $precision = $self->{+PRECISION};
if ( defined $precision) {
return sprintf "%.*f", $precision, $in;
}
my $tolerance = $self->{+TOLERANCE};
return "$in +/- $tolerance";
}
sub operator {
my $self = shift;
return '' unless @_;
my ($got) = @_;
return '' unless defined($got);
return '' unless length($got) && $got =~ m/\S/;
if ( $self->{+PRECISION} )
{
return 'ne' if $self->{+NEGATE};
return 'eq';
}
return '!=' if $self->{+NEGATE};
return '==';
}
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
return 0 unless $exists;
return 0 unless defined $got;
return 0 if ref $got;
return 0 unless length($got) && $got =~ m/\S/;
my $input = $self->{+INPUT};
my $negate = $self->{+NEGATE};
my $tolerance = $self->{+TOLERANCE};
my $precision = $self->{+PRECISION};
my @warnings;
my $out;
{
local $SIG{__WARN__} = sub { push @warnings => @_ };
my $equal = ($input == $got);
if (!$equal) {
if (defined $tolerance) {
$equal = 1 if
$got > $input - $tolerance &&
$got < $input + $tolerance;
} else {
$equal =
sprintf("%.*f", $precision, $got) eq
sprintf("%.*f", $precision, $input);
}
}
$out = $negate ? !$equal : $equal;
}
for my $warn (@warnings) {
if ($warn =~ m/numeric/) {
$out = 0;
next; # This warning won't help anyone.
}
warn $warn;
}
return $out;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Float - Compare two values as numbers with tolerance.
=head1 DESCRIPTION
This is used to compare two numbers. You can also check that two numbers are not
the same.
This is similar to Test2::Compare::Number, with extra checks to work around floating
point representation issues.
The optional 'tolerance' parameter controls how close the two numbers must be to
be considered equal. Tolerance defaults to 1e-08.
B<Note>: This will fail if the received value is undefined. It must be a number.
B<Note>: This will fail if the comparison generates a non-numeric value warning
(which will not be shown). This is because it must get a number. The warning is
not shown as it will report to a useless line and filename. However, the test
diagnostics show both values.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Andrew Grangaard E<lt>spazm@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

238
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Hash.pm Normal file
View file

@ -0,0 +1,238 @@
package Test2::Compare::Hash;
use strict;
use warnings;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/inref meta ending items order for_each_key for_each_val/;
use Carp qw/croak confess/;
use Scalar::Util qw/reftype/;
sub init {
my $self = shift;
if( defined( my $ref = $self->{+INREF} ) ) {
croak "Cannot specify both 'inref' and 'items'" if $self->{+ITEMS};
croak "Cannot specify both 'inref' and 'order'" if $self->{+ORDER};
$self->{+ITEMS} = {%$ref};
$self->{+ORDER} = [sort keys %$ref];
}
else {
# Clone the ref to be safe
$self->{+ITEMS} = $self->{+ITEMS} ? {%{$self->{+ITEMS}}} : {};
if ($self->{+ORDER}) {
my @all = keys %{$self->{+ITEMS}};
my %have = map { $_ => 1 } @{$self->{+ORDER}};
my @missing = grep { !$have{$_} } @all;
croak "Keys are missing from the 'order' array: " . join(', ', sort @missing)
if @missing;
}
else {
$self->{+ORDER} = [sort keys %{$self->{+ITEMS}}];
}
}
$self->{+FOR_EACH_KEY} ||= [];
$self->{+FOR_EACH_VAL} ||= [];
$self->SUPER::init();
}
sub name { '<HASH>' }
sub meta_class { 'Test2::Compare::Meta' }
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
return 0 unless $exists;
return 0 unless defined $got;
return 0 unless ref($got);
return 0 unless reftype($got) eq 'HASH';
return 1;
}
sub add_prop {
my $self = shift;
$self->{+META} = $self->meta_class->new unless defined $self->{+META};
$self->{+META}->add_prop(@_);
}
sub add_field {
my $self = shift;
my ($name, $check) = @_;
croak "field name is required"
unless defined $name;
croak "field '$name' has already been specified"
if exists $self->{+ITEMS}->{$name};
push @{$self->{+ORDER}} => $name;
$self->{+ITEMS}->{$name} = $check;
}
sub add_for_each_key {
my $self = shift;
push @{$self->{+FOR_EACH_KEY}} => @_;
}
sub add_for_each_val {
my $self = shift;
push @{$self->{+FOR_EACH_VAL}} => @_;
}
sub deltas {
my $self = shift;
my %params = @_;
my ($got, $convert, $seen) = @params{qw/got convert seen/};
my @deltas;
my $items = $self->{+ITEMS};
my $each_key = $self->{+FOR_EACH_KEY};
my $each_val = $self->{+FOR_EACH_VAL};
# Make a copy that we can munge as needed.
my %fields = %$got;
my $meta = $self->{+META};
push @deltas => $meta->deltas(%params) if defined $meta;
for my $key (@{$self->{+ORDER}}) {
my $check = $convert->($items->{$key});
my $exists = exists $fields{$key};
my $val = delete $fields{$key};
if ($exists) {
for my $kcheck (@$each_key) {
$kcheck = $convert->($kcheck);
push @deltas => $kcheck->run(
id => [HASHKEY => $key],
convert => $convert,
seen => $seen,
exists => $exists,
got => $key,
);
}
for my $vcheck (@$each_val) {
$vcheck = $convert->($vcheck);
push @deltas => $vcheck->run(
id => [HASH => $key],
convert => $convert,
seen => $seen,
exists => $exists,
got => $val,
);
}
}
push @deltas => $check->run(
id => [HASH => $key],
convert => $convert,
seen => $seen,
exists => $exists,
$exists ? (got => $val) : (),
);
}
if (keys %fields) {
for my $key (sort keys %fields) {
my $val = $fields{$key};
for my $kcheck (@$each_key) {
$kcheck = $convert->($kcheck);
push @deltas => $kcheck->run(
id => [HASHKEY => $key],
convert => $convert,
seen => $seen,
got => $key,
exists => 1,
);
}
for my $vcheck (@$each_val) {
$vcheck = $convert->($vcheck);
push @deltas => $vcheck->run(
id => [HASH => $key],
convert => $convert,
seen => $seen,
got => $val,
exists => 1,
);
}
# if items are left over, and ending is true, we have a problem!
if ($self->{+ENDING}) {
push @deltas => $self->delta_class->new(
dne => 'check',
verified => undef,
id => [HASH => $key],
got => $val,
check => undef,
$self->{+ENDING} eq 'implicit' ? (note => 'implicit end') : (),
);
}
}
}
return @deltas;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Hash - Representation of a hash in a deep comparison.
=head1 DESCRIPTION
In deep comparisons this class is used to represent a hash.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

100
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Isa.pm Normal file
View file

@ -0,0 +1,100 @@
package Test2::Compare::Isa;
use strict;
use warnings;
use Carp qw/confess/;
use Scalar::Util qw/blessed/;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/input/;
# Overloads '!' for us.
use Test2::Compare::Negatable;
sub init {
my $self = shift;
confess "input must be defined for 'Isa' check"
unless defined $self->{+INPUT};
$self->SUPER::init(@_);
}
sub name {
my $self = shift;
my $in = $self->{+INPUT};
return "$in";
}
sub operator {
my $self = shift;
return '!isa' if $self->{+NEGATE};
return 'isa';
}
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
return 0 unless $exists;
my $input = $self->{+INPUT};
my $negate = $self->{+NEGATE};
my $isa = blessed($got) && $got->isa($input);
return !$isa if $negate;
return $isa;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Isa - Check if the value is an instance of the class.
=head1 DESCRIPTION
This is used to check if the got value is an instance of the expected class.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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 TOYAMA Nao E<lt>nanto@moon.email.ne.jpE<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

183
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Meta.pm Normal file
View file

@ -0,0 +1,183 @@
package Test2::Compare::Meta;
use strict;
use warnings;
use Test2::Compare::Delta();
use Test2::Compare::Isa();
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/items/;
use Carp qw/croak confess/;
use Scalar::Util qw/reftype blessed/;
sub init {
my $self = shift;
$self->{+ITEMS} ||= [];
$self->SUPER::init();
}
sub name { '<META CHECKS>' }
sub verify {
my $self = shift;
my %params = @_;
return $params{exists} ? 1 : 0;
}
sub add_prop {
my $self = shift;
my ($name, $check) = @_;
croak "prop name is required"
unless defined $name;
croak "check is required"
unless defined $check;
my $meth = "get_prop_$name";
croak "'$name' is not a known property"
unless $self->can($meth);
if ($name eq 'isa') {
if (blessed($check) && $check->isa('Test2::Compare::Wildcard')) {
# Carry forward file and lines that are set in Test2::Tools::Compare::prop.
$check = Test2::Compare::Isa->new(
input => $check->expect,
file => $check->file,
lines => $check->lines,
);
} else {
$check = Test2::Compare::Isa->new(input => $check);
}
}
push @{$self->{+ITEMS}} => [$meth, $check, $name];
}
sub deltas {
my $self = shift;
my %params = @_;
my ($got, $convert, $seen) = @params{qw/got convert seen/};
my @deltas;
my $items = $self->{+ITEMS};
for my $set (@$items) {
my ($meth, $check, $name) = @$set;
$check = $convert->($check);
my $val = $self->$meth($got);
push @deltas => $check->run(
id => [META => $name],
got => $val,
convert => $convert,
seen => $seen,
);
}
return @deltas;
}
sub get_prop_blessed { blessed($_[1]) }
sub get_prop_reftype { reftype($_[1]) }
sub get_prop_isa { $_[1] }
sub get_prop_this { $_[1] }
sub get_prop_size {
my $self = shift;
my ($it) = @_;
my $type = reftype($it) || '';
return scalar @$it if $type eq 'ARRAY';
return scalar keys %$it if $type eq 'HASH';
return undef;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Meta - Check library for meta-checks
=head1 DESCRIPTION
Sometimes in a deep comparison you want to run extra checks against an item
down the chain. This library allows you to write a check that verifies several
attributes of an item.
=head1 DEFINED CHECKS
=over 4
=item blessed
Lets you check that an item is blessed, and that it is blessed into the
expected class.
=item reftype
Lets you check the reftype of the item.
=item isa
Lets you check if the item is an instance of the expected class.
=item this
Lets you check the item itself.
=item size
Lets you check the size of the item. For an arrayref this is the number of
elements. For a hashref this is the number of keys. For everything else this is
undef.
=back
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

121
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Negatable.pm Normal file
View file

@ -0,0 +1,121 @@
package Test2::Compare::Negatable;
use strict;
use warnings;
our $VERSION = '0.000162';
require overload;
require Test2::Util::HashBase;
sub import {
my ($pkg, $file, $line) = caller;
my $sub = eval <<" EOT" or die $@;
package $pkg;
#line $line "$file"
sub { overload->import('!' => 'clone_negate', fallback => 1); Test2::Util::HashBase->import('negate')}
EOT
$sub->();
no strict 'refs';
*{"$pkg\::clone_negate"} = \&clone_negate;
*{"$pkg\::toggle_negate"} = \&toggle_negate;
}
sub clone_negate {
my $self = shift;
my $clone = $self->clone;
$clone->toggle_negate;
return $clone;
}
sub toggle_negate {
my $self = shift;
$self->set_negate($self->negate ? 0 : 1);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Negatable - Poor mans 'role' for compare objects that can be negated.
=head1 DESCRIPTION
Using this package inside an L<Test2::Compare::Base> subclass will overload
C<!$obj> and import C<clone_negate()> and C<toggle_negate()>.
=head1 WHY?
Until perl 5.18 the 'fallback' parameter to L<overload> would not be inherited,
so we cannot use inheritance for the behavior we actually want. This module
works around the problem by emulating the C<use overload> call we want for each
consumer class.
=head1 ATTRIBUTES
=over 4
=item $bool = $obj->negate
=item $obj->set_negate($bool)
=item $attr = NEGATE()
The NEGATE attribute will be added via L<Test2::Util::HashBase>.
=back
=head1 METHODS
=over 4
=item $clone = $obj->clone_negate()
Create a shallow copy of the object, and call C<toggle_negate> on it.
=item $obj->toggle_negate()
Toggle the negate attribute. If the attribute was on it will now be off, if it
was off it will now be on.
=back
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

152
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Number.pm Normal file
View file

@ -0,0 +1,152 @@
package Test2::Compare::Number;
use strict;
use warnings;
use Carp qw/confess/;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/input mode/;
# Overloads '!' for us.
use Test2::Compare::Negatable;
sub init {
my $self = shift;
my $input = $self->{+INPUT};
confess "input must be defined for 'Number' check"
unless defined $input;
# Check for ''
confess "input must be a number for 'Number' check"
unless length($input) && $input =~ m/\S/;
defined $self->{+MODE} or $self->{+MODE} = '==';
$self->SUPER::init(@_);
}
sub name {
my $self = shift;
my $in = $self->{+INPUT};
return $in;
}
my %NEGATED = (
'==' => '!=',
'!=' => '==',
'<' => '>=',
'<=' => '>',
'>=' => '<',
'>' => '<=',
);
sub operator {
my $self = shift;
return '' unless @_;
my ($got) = @_;
return '' unless defined($got);
return '' unless length($got) && $got =~ m/\S/;
return $NEGATED{ $self->{+MODE} } if $self->{+NEGATE};
return $self->{+MODE};
}
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
return 0 unless $exists;
return 0 unless defined $got;
return 0 if ref $got;
return 0 unless length($got) && $got =~ m/\S/;
my $want = $self->{+INPUT};
my $mode = $self->{+MODE};
my $negate = $self->{+NEGATE};
my @warnings;
my $out;
{
local $SIG{__WARN__} = sub { push @warnings => @_ };
$out = $mode eq '==' ? ($got == $want) :
$mode eq '!=' ? ($got != $want) :
$mode eq '<' ? ($got < $want) :
$mode eq '<=' ? ($got <= $want) :
$mode eq '>=' ? ($got >= $want) :
$mode eq '>' ? ($got > $want) :
die "Unrecognised MODE";
$out ^= 1 if $negate;
}
for my $warn (@warnings) {
if ($warn =~ m/numeric/) {
$out = 0;
next; # This warning won't help anyone.
}
warn $warn;
}
return $out;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Number - Compare two values as numbers
=head1 DESCRIPTION
This is used to compare two numbers. You can also check that two numbers are not
the same.
B<Note>: This will fail if the received value is undefined. It must be a number.
B<Note>: This will fail if the comparison generates a non-numeric value warning
(which will not be shown). This is because it must get a number. The warning is
not shown as it will report to a useless line and filename. However, the test
diagnostics show both values.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

256
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Object.pm Normal file
View file

@ -0,0 +1,256 @@
package Test2::Compare::Object;
use strict;
use warnings;
use Test2::Util qw/try/;
use Test2::Compare::Meta();
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/calls meta refcheck ending/;
use Carp qw/croak confess/;
use Scalar::Util qw/reftype blessed/;
sub init {
my $self = shift;
$self->{+CALLS} ||= [];
$self->SUPER::init();
}
sub name { '<OBJECT>' }
sub meta_class { 'Test2::Compare::Meta' }
sub object_base { 'UNIVERSAL' }
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
return 0 unless $exists;
return 0 unless defined $got;
return 0 unless ref($got);
return 0 unless blessed($got);
return 0 unless $got->isa($self->object_base);
return 1;
}
sub add_prop {
my $self = shift;
$self->{+META} = $self->meta_class->new unless defined $self->{+META};
$self->{+META}->add_prop(@_);
}
sub add_field {
my $self = shift;
$self->{+REFCHECK} = Test2::Compare::Hash->new unless defined $self->{+REFCHECK};
croak "Underlying reference does not have fields"
unless $self->{+REFCHECK}->can('add_field');
$self->{+REFCHECK}->add_field(@_);
}
sub add_item {
my $self = shift;
$self->{+REFCHECK} = Test2::Compare::Array->new unless defined $self->{+REFCHECK};
croak "Underlying reference does not have items"
unless $self->{+REFCHECK}->can('add_item');
$self->{+REFCHECK}->add_item(@_);
}
sub add_call {
my $self = shift;
my ($meth, $check, $name, $context) = @_;
$name ||= ref $meth eq 'ARRAY' ? $meth->[0]
: ref $meth eq 'CODE' ? '\&CODE'
: $meth;
push @{$self->{+CALLS}} => [$meth, $check, $name, $context || 'scalar'];
}
sub deltas {
my $self = shift;
my %params = @_;
my ($got, $convert, $seen) = @params{qw/got convert seen/};
my @deltas;
my $meta = $self->{+META};
my $refcheck = $self->{+REFCHECK};
push @deltas => $meta->deltas(%params) if defined $meta;
for my $call (@{$self->{+CALLS}}) {
my ($meth, $check, $name, $context)= @$call;
$context ||= 'scalar';
$check = $convert->($check);
my @args;
if (ref($meth) eq 'ARRAY') {
($meth,@args) = @{$meth};
}
my $exists = ref($meth) || $got->can($meth);
my $val;
my ($ok, $err) = try {
$val = $exists
? ( $context eq 'list' ? [ $got->$meth(@args) ] :
$context eq 'hash' ? { $got->$meth(@args) } :
$got->$meth(@args)
)
: undef;
};
if (!$ok) {
push @deltas => $self->delta_class->new(
verified => undef,
id => [METHOD => $name],
got => undef,
check => $check,
exception => $err,
);
}
else {
push @deltas => $check->run(
id => [METHOD => $name],
convert => $convert,
seen => $seen,
exists => $exists,
$exists ? (got => $val) : (),
);
}
}
return @deltas unless defined $refcheck;
$refcheck->set_ending($self->{+ENDING});
if ($refcheck->verify(%params)) {
push @deltas => $refcheck->deltas(%params);
}
else {
push @deltas => $self->delta_class->new(
verified => undef,
id => [META => 'Object Ref'],
got => $got,
check => $refcheck,
);
}
return @deltas;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Object - Representation of an object during deep
comparison.
=head1 DESCRIPTION
This class lets you specify an expected object in a deep comparison. You can
check the fields/elements of the underlying reference, call methods to verify
results, and do meta checks for object type and ref type.
=head1 METHODS
=over 4
=item $class = $obj->meta_class
The meta-class to be used when checking the object type. This is mainly listed
because it is useful to override for specialized object subclasses.
This normally just returns L<Test2::Compare::Meta>.
=item $class = $obj->object_base
The base-class to be expected when checking the object type. This is mainly
listed because it is useful to override for specialized object subclasses.
This normally just returns 'UNIVERSAL'.
=item $obj->add_prop(...)
Add a meta-property to check, see L<Test2::Compare::Meta>. This method
just delegates.
=item $obj->add_field(...)
Add a hash-field to check, see L<Test2::Compare::Hash>. This method
just delegates.
=item $obj->add_item(...)
Add an array item to check, see L<Test2::Compare::Array>. This method
just delegates.
=item $obj->add_call($method, $check)
=item $obj->add_call($method, $check, $name)
=item $obj->add_call($method, $check, $name, $context)
Add a method call check. This will call the specified method on your object and
verify the result. C<$method> may be a method name, an array ref, or a coderef.
If it's an arrayref, the first element must be the method name, and
the rest are arguments that will be passed to it.
In the case of a coderef it can be helpful to provide an alternate
name. When no name is provided the name is either C<$method> or the
string '\&CODE'.
If C<$context> is C<'list'>, the method will be invoked in list
context, and the result will be an arrayref.
If C<$context> is C<'hash'>, the method will be invoked in list
context, and the result will be a hashref (this will warn if the
method returns an odd number of values).
=back
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

175
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/OrderedSubset.pm Normal file
View file

@ -0,0 +1,175 @@
package Test2::Compare::OrderedSubset;
use strict;
use warnings;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/inref items/;
use Carp qw/croak/;
use Scalar::Util qw/reftype/;
sub init {
my $self = shift;
if(my $ref = $self->{+INREF}) {
croak "Cannot specify both 'inref' and 'items'" if $self->{+ITEMS};
croak "'inref' must be an array reference, got '$ref'" unless reftype($ref) eq 'ARRAY';
$self->{+ITEMS} = [@{$self->{+INREF}}];
}
$self->{+ITEMS} ||= [];
$self->SUPER::init();
}
sub name { '<ORDERED SUBSET>' }
sub verify {
my $self = shift;
my %params = @_;
return 0 unless $params{exists};
defined( my $got = $params{got} ) || return 0;
return 0 unless ref($got);
return 0 unless reftype($got) eq 'ARRAY';
return 1;
}
sub add_item {
my $self = shift;
my $check = pop;
push @{$self->{+ITEMS}} => $check;
}
sub deltas {
my $self = shift;
my %params = @_;
my ($got, $convert, $seen) = @params{qw/got convert seen/};
my @deltas;
my $state = 0;
my $items = $self->{+ITEMS};
my $idx = 0;
for my $item (@$items) {
my $check = $convert->($item);
my $i = $idx;
my $found;
while($i < @$got) {
my $val = $got->[$i++];
next if $check->run(
id => [ARRAY => $i],
convert => $convert,
seen => $seen,
exists => 1,
got => $val,
);
$idx = $i;
$found++;
last;
}
next if $found;
push @deltas => Test2::Compare::Delta->new(
verified => 0,
id => ['ARRAY', '?'],
check => $check,
dne => 'got',
);
}
return @deltas;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::OrderedSubset - Internal representation of an ordered subset.
=head1 DESCRIPTION
This module is used to ensure an array has all the expected items int he
expected order. It ignores any unexpected items mixed into the array. It only
cares that all the expected values are present, and in order, everything else
is noise.
=head1 METHODS
=over 4
=item $ref = $arr->inref()
If the instance was constructed from an actual array, this will have the
reference to that array.
=item $arrayref = $arr->items()
=item $arr->set_items($arrayref)
All the expected items, in order.
=item $name = $arr->name()
Always returns the string C<< "<ORDERED SUBSET>" >>.
=item $bool = $arr->verify(got => $got, exists => $bool)
Check if C<$got> is an array reference or not.
=item $arr->add_item($item)
Add an item to the list of values to check.
=item @deltas = $arr->deltas(got => $got, convert => \&convert, seen => \%seen)
Find the differences between the expected array values and those in the C<$got>
arrayref.
=back
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

93
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Pattern.pm Normal file
View file

@ -0,0 +1,93 @@
package Test2::Compare::Pattern;
use strict;
use warnings;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/pattern stringify_got/;
# Overloads '!' for us.
use Test2::Compare::Negatable;
use Carp qw/croak/;
sub init {
my $self = shift;
croak "'pattern' is a required attribute" unless $self->{+PATTERN};
$self->{+STRINGIFY_GOT} ||= 0;
$self->SUPER::init();
}
sub name { shift->{+PATTERN} . "" }
sub operator { shift->{+NEGATE} ? '!~' : '=~' }
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
return 0 unless $exists;
return 0 unless defined($got);
return 0 if ref $got && !$self->stringify_got;
return $got !~ $self->{+PATTERN}
if $self->{+NEGATE};
return $got =~ $self->{+PATTERN};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Pattern - Use a pattern to validate values in a deep
comparison.
=head1 DESCRIPTION
This allows you to use a regex to validate a value in a deep comparison.
Sometimes a value just needs to look right, it may not need to be exact. An
example is a memory address that might change from run to run.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

109
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Ref.pm Normal file
View file

@ -0,0 +1,109 @@
package Test2::Compare::Ref;
use strict;
use warnings;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/input/;
use Test2::Util::Ref qw/render_ref rtype/;
use Scalar::Util qw/refaddr/;
use Carp qw/croak/;
sub init {
my $self = shift;
croak "'input' is a required attribute"
unless $self->{+INPUT};
croak "'input' must be a reference, got '" . $self->{+INPUT} . "'"
unless ref $self->{+INPUT};
$self->SUPER::init();
}
sub operator { '==' }
sub name { render_ref($_[0]->{+INPUT}) }
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
return 0 unless $exists;
my $in = $self->{+INPUT};
return 0 unless ref $in;
return 0 unless ref $got;
my $in_type = rtype($in);
my $got_type = rtype($got);
return 0 unless $in_type eq $got_type;
# Don't let overloading mess with us.
return refaddr($in) == refaddr($got);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Ref - Ref comparison
=head1 DESCRIPTION
Used to compare two refs in a deep comparison.
=head1 SYNOPSIS
my $ref = {};
my $check = Test2::Compare::Ref->new(input => $ref);
# Passes
is( [$ref], [$check], "The array contains the exact ref we want" );
# Fails, they both may be empty hashes, but we are looking for a specific
# reference.
is( [{}], [$check], "This will fail");
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

93
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Regex.pm Normal file
View file

@ -0,0 +1,93 @@
package Test2::Compare::Regex;
use strict;
use warnings;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/input/;
use Test2::Util::Ref qw/render_ref rtype/;
use Carp qw/croak/;
sub init {
my $self = shift;
croak "'input' is a required attribute"
unless $self->{+INPUT};
croak "'input' must be a regex , got '" . $self->{+INPUT} . "'"
unless rtype($self->{+INPUT}) eq 'REGEXP';
$self->SUPER::init();
}
sub stringify_got { 1 }
sub operator { 'eq' }
sub name { "" . $_[0]->{+INPUT} }
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
return 0 unless $exists;
my $in = $self->{+INPUT};
my $got_type = rtype($got) or return 0;
return 0 unless $got_type eq 'REGEXP';
return "$in" eq "$got";
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Regex - Regex direct comparison
=head1 DESCRIPTION
Used to compare two regexes. This compares the stringified form of each regex.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

111
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Scalar.pm Normal file
View file

@ -0,0 +1,111 @@
package Test2::Compare::Scalar;
use strict;
use warnings;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/item/;
use Carp qw/croak confess/;
use Scalar::Util qw/reftype blessed/;
sub init {
my $self = shift;
croak "'item' is a required attribute"
unless defined $self->{+ITEM};
$self->SUPER::init();
}
sub name { '<SCALAR>' }
sub operator { '${...}' }
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
return 0 unless $exists;
return 0 unless defined $got;
return 0 unless ref($got);
return 0 unless reftype($got) eq 'SCALAR' || reftype($got) eq 'VSTRING';
return 1;
}
sub deltas {
my $self = shift;
my %params = @_;
my ($got, $convert, $seen) = @params{qw/got convert seen/};
my $item = $self->{+ITEM};
my $check = $convert->($item);
return (
$check->run(
id => ['SCALAR' => '$*'],
got => $$got,
convert => $convert,
seen => $seen,
exists => 1,
),
);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Scalar - Representation of a Scalar Ref in deep
comparisons
=head1 DESCRIPTION
This is used in deep comparisons to represent a scalar reference.
=head1 SYNOPSIS
my $sr = Test2::Compare::Scalar->new(item => 'foo');
is([\'foo'], $sr, "pass");
is([\'bar'], $sr, "fail, different value");
is(['foo'], $sr, "fail, not a ref");
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

153
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Set.pm Normal file
View file

@ -0,0 +1,153 @@
package Test2::Compare::Set;
use strict;
use warnings;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/checks _reduction/;
use Test2::Compare::Delta();
use Carp qw/croak confess/;
use Scalar::Util qw/reftype/;
sub init {
my $self = shift;
my $reduction = delete $self->{reduction} || 'any';
$self->{+CHECKS} ||= [];
$self->set_reduction($reduction);
$self->SUPER::init();
}
sub name { '<CHECK-SET>' }
sub operator { $_[0]->{+_REDUCTION} }
sub reduction { $_[0]->{+_REDUCTION} }
my %VALID = (any => 1, all => 1, none => 1);
sub set_reduction {
my $self = shift;
my ($redu) = @_;
croak "'$redu' is not a valid set reduction"
unless $VALID{$redu};
$self->{+_REDUCTION} = $redu;
}
sub verify {
my $self = shift;
my %params = @_;
return 1;
}
sub add_check {
my $self = shift;
push @{$self->{+CHECKS}} => @_;
}
sub deltas {
my $self = shift;
my %params = @_;
my $checks = $self->{+CHECKS};
my $reduction = $self->{+_REDUCTION};
my $convert = $params{convert};
unless ($checks && @$checks) {
my $file = $self->file;
my $lines = $self->lines;
my $extra = "";
if ($file and $lines and @$lines) {
my $lns = (@$lines > 1 ? 'lines ' : 'line ' ) . join ', ', @$lines;
$extra = " (Set defined in $file $lns)";
}
die "No checks defined for set$extra\n";
}
my @deltas;
my $i = 0;
for my $check (@$checks) {
my $c = $convert->($check);
my $id = [META => "Check " . $i++];
my @d = $c->run(%params, id => $id);
if ($reduction eq 'any') {
return () unless @d;
push @deltas => @d;
}
elsif ($reduction eq 'all') {
push @deltas => @d;
}
elsif ($reduction eq 'none') {
push @deltas => Test2::Compare::Delta->new(
verified => 0,
id => $id,
got => $params{got},
check => $c,
) unless @d;
}
else {
die "Invalid reduction: $reduction\n";
}
}
return @deltas;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Set - Allows a field to be matched against a set of
checks.
=head1 DESCRIPTION
This module is used by the C<check_set> function in the
L<Test2::Tools::Compare> plugin.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

108
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/String.pm Normal file
View file

@ -0,0 +1,108 @@
package Test2::Compare::String;
use strict;
use warnings;
use Carp qw/confess/;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/input/;
# Overloads '!' for us.
use Test2::Compare::Negatable;
sub stringify_got { 1 }
sub init {
my $self = shift;
confess "input must be defined for 'String' check"
unless defined $self->{+INPUT};
$self->SUPER::init(@_);
}
sub name {
my $self = shift;
my $in = $self->{+INPUT};
return "$in";
}
sub operator {
my $self = shift;
return '' unless @_;
my ($got) = @_;
return '' unless defined($got);
return 'ne' if $self->{+NEGATE};
return 'eq';
}
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
return 0 unless $exists;
return 0 unless defined $got;
my $input = $self->{+INPUT};
my $negate = $self->{+NEGATE};
return "$input" ne "$got" if $negate;
return "$input" eq "$got";
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::String - Compare two values as strings
=head1 DESCRIPTION
This is used to compare two items after they are stringified. You can also check
that two strings are not equal.
B<Note>: This will fail if the received value is undefined, it must be defined.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

83
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Undef.pm Normal file
View file

@ -0,0 +1,83 @@
package Test2::Compare::Undef;
use strict;
use warnings;
use Carp qw/confess/;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase;
# Overloads '!' for us.
use Test2::Compare::Negatable;
sub name { '<UNDEF>' }
sub operator {
my $self = shift;
return 'IS NOT' if $self->{+NEGATE};
return 'IS';
}
sub verify {
my $self = shift;
my %params = @_;
my ($got, $exists) = @params{qw/got exists/};
return 0 unless $exists;
return !defined($got) unless $self->{+NEGATE};
return defined($got);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Undef - Check that something is undefined
=head1 DESCRIPTION
Make sure something is undefined in a comparison. You can also check that
something is defined.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

69
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Compare/Wildcard.pm Normal file
View file

@ -0,0 +1,69 @@
package Test2::Compare::Wildcard;
use strict;
use warnings;
use base 'Test2::Compare::Base';
our $VERSION = '0.000162';
use Test2::Util::HashBase qw/expect/;
use Carp qw/croak/;
sub init {
my $self = shift;
croak "'expect' is a require attribute"
unless exists $self->{+EXPECT};
$self->SUPER::init();
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Compare::Wildcard - Placeholder check.
=head1 DESCRIPTION
This module is used as a temporary placeholder for values that still need to be
converted. This is necessary to carry forward the filename and line number which
would be lost in the conversion otherwise.
=head1 SOURCE
The source code repository for Test2-Suite can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

778
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event.pm Normal file
View file

@ -0,0 +1,778 @@
package Test2::Event;
use strict;
use warnings;
our $VERSION = '1.302199';
use Scalar::Util qw/blessed reftype/;
use Carp qw/croak/;
use Test2::Util::HashBase qw/trace -amnesty uuid -_eid -hubs/;
use Test2::Util::ExternalMeta qw/meta get_meta set_meta delete_meta/;
use Test2::Util qw/pkg_to_file gen_uid/;
use Test2::EventFacet::About();
use Test2::EventFacet::Amnesty();
use Test2::EventFacet::Assert();
use Test2::EventFacet::Control();
use Test2::EventFacet::Error();
use Test2::EventFacet::Info();
use Test2::EventFacet::Meta();
use Test2::EventFacet::Parent();
use Test2::EventFacet::Plan();
use Test2::EventFacet::Trace();
use Test2::EventFacet::Hub();
# Legacy tools will expect this to be loaded now
require Test2::Util::Trace;
my %LOADED_FACETS = (
'about' => 'Test2::EventFacet::About',
'amnesty' => 'Test2::EventFacet::Amnesty',
'assert' => 'Test2::EventFacet::Assert',
'control' => 'Test2::EventFacet::Control',
'errors' => 'Test2::EventFacet::Error',
'info' => 'Test2::EventFacet::Info',
'meta' => 'Test2::EventFacet::Meta',
'parent' => 'Test2::EventFacet::Parent',
'plan' => 'Test2::EventFacet::Plan',
'trace' => 'Test2::EventFacet::Trace',
'hubs' => 'Test2::EventFacet::Hub',
);
sub FACET_TYPES { sort values %LOADED_FACETS }
sub load_facet {
my $class = shift;
my ($facet) = @_;
return $LOADED_FACETS{$facet} if exists $LOADED_FACETS{$facet};
my @check = ($facet);
if ('s' eq substr($facet, -1, 1)) {
push @check => substr($facet, 0, -1);
}
else {
push @check => $facet . 's';
}
my $found;
for my $check (@check) {
my $mod = "Test2::EventFacet::" . ucfirst($facet);
my $file = pkg_to_file($mod);
next unless eval { require $file; 1 };
$found = $mod;
last;
}
return undef unless $found;
$LOADED_FACETS{$facet} = $found;
}
sub causes_fail { 0 }
sub increments_count { 0 }
sub diagnostics { 0 }
sub no_display { 0 }
sub subtest_id { undef }
sub callback { }
sub terminate { () }
sub global { () }
sub sets_plan { () }
sub summary { ref($_[0]) }
sub related {
my $self = shift;
my ($event) = @_;
my $tracea = $self->trace or return undef;
my $traceb = $event->trace or return undef;
my $uuida = $tracea->uuid;
my $uuidb = $traceb->uuid;
if ($uuida && $uuidb) {
return 1 if $uuida eq $uuidb;
return 0;
}
my $siga = $tracea->signature or return undef;
my $sigb = $traceb->signature or return undef;
return 1 if $siga eq $sigb;
return 0;
}
sub add_hub {
my $self = shift;
unshift @{$self->{+HUBS}} => @_;
}
sub add_amnesty {
my $self = shift;
for my $am (@_) {
$am = {%$am} if ref($am) ne 'ARRAY';
$am = Test2::EventFacet::Amnesty->new($am);
push @{$self->{+AMNESTY}} => $am;
}
}
sub eid { $_[0]->{+_EID} ||= gen_uid() }
sub common_facet_data {
my $self = shift;
my %out;
$out{about} = {package => ref($self) || undef};
if (my $uuid = $self->uuid) {
$out{about}->{uuid} = $uuid;
}
$out{about}->{eid} = $self->{+_EID} || $self->eid;
if (my $trace = $self->trace) {
$out{trace} = { %$trace };
}
if (my $hubs = $self->hubs) {
$out{hubs} = $hubs;
}
$out{amnesty} = [map {{ %{$_} }} @{$self->{+AMNESTY}}]
if $self->{+AMNESTY};
if (my $meta = $self->meta_facet_data) {
$out{meta} = $meta;
}
return \%out;
}
sub meta_facet_data {
my $self = shift;
my $key = Test2::Util::ExternalMeta::META_KEY();
my $hash = $self->{$key} or return undef;
return {%$hash};
}
sub facet_data {
my $self = shift;
my $out = $self->common_facet_data;
$out->{about}->{details} = $self->summary || undef;
$out->{about}->{no_display} = $self->no_display || undef;
# Might be undef, we want to preserve that
my $terminate = $self->terminate;
$out->{control} = {
global => $self->global || 0,
terminate => $terminate,
has_callback => $self->can('callback') == \&callback ? 0 : 1,
};
$out->{assert} = {
no_debug => 1, # Legacy behavior
pass => $self->causes_fail ? 0 : 1,
details => $self->summary,
} if $self->increments_count;
$out->{parent} = {hid => $self->subtest_id} if $self->subtest_id;
if (my @plan = $self->sets_plan) {
$out->{plan} = {};
$out->{plan}->{count} = $plan[0] if defined $plan[0];
$out->{plan}->{details} = $plan[2] if defined $plan[2];
if ($plan[1]) {
$out->{plan}->{skip} = 1 if $plan[1] eq 'SKIP';
$out->{plan}->{none} = 1 if $plan[1] eq 'NO PLAN';
}
$out->{control}->{terminate} ||= 0 if $out->{plan}->{skip};
}
if ($self->causes_fail && !$out->{assert}) {
$out->{errors} = [
{
tag => 'FAIL',
fail => 1,
details => $self->summary,
}
];
}
my %IGNORE = (trace => 1, about => 1, control => 1);
my $do_info = !grep { !$IGNORE{$_} } keys %$out;
if ($do_info && !$self->no_display && $self->diagnostics) {
$out->{info} = [
{
tag => 'DIAG',
debug => 1,
details => $self->summary,
}
];
}
return $out;
}
sub facets {
my $self = shift;
my %out;
my $data = $self->facet_data;
my @errors = $self->validate_facet_data($data);
die join "\n" => @errors if @errors;
for my $facet (keys %$data) {
my $class = $self->load_facet($facet);
my $val = $data->{$facet};
unless($class) {
$out{$facet} = $val;
next;
}
my $is_list = reftype($val) eq 'ARRAY' ? 1 : 0;
if ($is_list) {
$out{$facet} = [map { $class->new($_) } @$val];
}
else {
$out{$facet} = $class->new($val);
}
}
return \%out;
}
sub validate_facet_data {
my $class_or_self = shift;
my ($f, %params);
$f = shift if @_ && (reftype($_[0]) || '') eq 'HASH';
%params = @_;
$f ||= $class_or_self->facet_data if blessed($class_or_self);
croak "No facet data" unless $f;
my @errors;
for my $k (sort keys %$f) {
my $fclass = $class_or_self->load_facet($k);
push @errors => "Could not find a facet class for facet '$k'"
if $params{require_facet_class} && !$fclass;
next unless $fclass;
my $v = $f->{$k};
next unless defined($v); # undef is always fine
my $is_list = $fclass->is_list();
my $got_list = reftype($v) eq 'ARRAY' ? 1 : 0;
push @errors => "Facet '$k' should be a list, but got a single item ($v)"
if $is_list && !$got_list;
push @errors => "Facet '$k' should not be a list, but got a a list ($v)"
if $got_list && !$is_list;
}
return @errors;
}
sub nested {
my $self = shift;
Carp::cluck("Use of Test2::Event->nested() is deprecated, use Test2::Event->trace->nested instead")
if $ENV{AUTHOR_TESTING};
if (my $hubs = $self->{+HUBS}) {
return $hubs->[0]->{nested} if @$hubs;
}
my $trace = $self->{+TRACE} or return undef;
return $trace->{nested};
}
sub in_subtest {
my $self = shift;
Carp::cluck("Use of Test2::Event->in_subtest() is deprecated, use Test2::Event->trace->hid instead")
if $ENV{AUTHOR_TESTING};
my $hubs = $self->{+HUBS};
if ($hubs && @$hubs) {
return undef unless $hubs->[0]->{nested};
return $hubs->[0]->{hid}
}
my $trace = $self->{+TRACE} or return undef;
return undef unless $trace->{nested};
return $trace->{hid};
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Event - Base class for events
=head1 DESCRIPTION
Base class for all event objects that get passed through
L<Test2>.
=head1 SYNOPSIS
package Test2::Event::MyEvent;
use strict;
use warnings;
# This will make our class an event subclass (required)
use base 'Test2::Event';
# Add some accessors (optional)
# You are not obligated to use HashBase, you can use any object tool you
# want, or roll your own accessors.
use Test2::Util::HashBase qw/foo bar baz/;
# Use this if you want the legacy API to be written for you, for this to
# work you will need to implement a facet_data() method.
use Test2::Util::Facets2Legacy;
# Chance to initialize some defaults
sub init {
my $self = shift;
# no other args in @_
$self->set_foo('xxx') unless defined $self->foo;
...
}
# This is the new way for events to convey data to the Test2 system
sub facet_data {
my $self = shift;
# Get common facets such as 'about', 'trace' 'amnesty', and 'meta'
my $facet_data = $self->common_facet_data();
# Are you making an assertion?
$facet_data->{assert} = {pass => 1, details => 'my assertion'};
...
return $facet_data;
}
1;
=head1 METHODS
=head2 GENERAL
=over 4
=item $trace = $e->trace
Get a snapshot of the L<Test2::EventFacet::Trace> as it was when this event was
generated
=item $bool_or_undef = $e->related($e2)
Check if 2 events are related. In this case related means their traces share a
signature meaning they were created with the same context (or at the very least
by contexts which share an id, which is the same thing unless someone is doing
something very bad).
This can be used to reliably link multiple events created by the same tool. For
instance a failing test like C<ok(0, "fail"> will generate 2 events, one being
a L<Test2::Event::Ok>, the other being a L<Test2::Event::Diag>, both of these
events are related having been created under the same context and by the same
initial tool (though multiple tools may have been nested under the initial
one).
This will return C<undef> if the relationship cannot be checked, which happens
if either event has an incomplete or missing trace. This will return C<0> if
the traces are complete, but do not match. C<1> will be returned if there is a
match.
=item $e->add_amnesty({tag => $TAG, details => $DETAILS});
This can be used to add amnesty to this event. Amnesty only effects failing
assertions in most cases, but some formatters may display them for passing
assertions, or even non-assertions as well.
Amnesty will prevent a failed assertion from causing the overall test to fail.
In other words it marks a failure as expected and allowed.
B<Note:> This is how 'TODO' is implemented under the hood. TODO is essentially
amnesty with the 'TODO' tag. The details are the reason for the TODO.
=item $uuid = $e->uuid
If UUID tagging is enabled (See L<Test::API>) then any event that has made its
way through a hub will be tagged with a UUID. A newly created event will not
yet be tagged in most cases.
=item $class = $e->load_facet($name)
This method is used to load a facet by name (or key). It will attempt to load
the facet class, if it succeeds it will return the class it loaded. If it fails
it will return C<undef>. This caches the result at the class level so that
future calls will be faster.
The C<$name> variable should be the key used to access the facet in a facets
hashref. For instance the assertion facet has the key 'assert', the information
facet has the 'info' key, and the error facet has the key 'errors'. You may
include or omit the 's' at the end of the name, the method is smart enough to
try both the 's' and no-'s' forms, it will check what you provided first, and
if that is not found it will add or strip the 's and try again.
=item @classes = $e->FACET_TYPES()
=item @classes = Test2::Event->FACET_TYPES()
This returns a list of all facets that have been loaded using the
C<load_facet()> method. This will not return any classes that have not been
loaded, or have been loaded directly without a call to C<load_facet()>.
B<Note:> The core facet types are automatically loaded and populated in this
list.
=back
=head2 NEW API
=over 4
=item $hashref = $e->common_facet_data();
This can be used by subclasses to generate a starting facet data hashref. This
will populate the hashref with the trace, meta, amnesty, and about facets.
These facets are nearly always produced the same way for all events.
=item $hashref = $e->facet_data()
If you do not override this then the default implementation will attempt to
generate facets from the legacy API. This generation is limited only to what
the legacy API can provide. It is recommended that you override this method and
write out explicit facet data.
=item $hashref = $e->facets()
This takes the hashref from C<facet_data()> and blesses each facet into the
proper C<Test2::EventFacet::*> subclass. If no class can be found for any given
facet it will be passed along unchanged.
=item @errors = $e->validate_facet_data();
=item @errors = $e->validate_facet_data(%params);
=item @errors = $e->validate_facet_data(\%facets, %params);
=item @errors = Test2::Event->validate_facet_data(%params);
=item @errors = Test2::Event->validate_facet_data(\%facets, %params);
This method will validate facet data and return a list of errors. If no errors
are found this will return an empty list.
This can be called as an object method with no arguments, in which case the
C<facet_data()> method will be called to get the facet data to be validated.
When used as an object method the C<\%facet_data> argument may be omitted.
When used as a class method the C<\%facet_data> argument is required.
Remaining arguments will be slurped into a C<%params> hash.
Currently only 1 parameter is defined:
=over 4
=item require_facet_class => $BOOL
When set to true (default is false) this will reject any facets where a facet
class cannot be found. Normally facets without classes are assumed to be custom
and are ignored.
=back
=back
=head3 WHAT ARE FACETS?
Facets are how events convey their purpose to the Test2 internals and
formatters. An event without facets will have no intentional effect on the
overall test state, and will not be displayed at all by most formatters, except
perhaps to say that an event of an unknown type was seen.
Facets are produced by the C<facet_data()> subroutine, which you should
nearly-always override. C<facet_data()> is expected to return a hashref where
each key is the facet type, and the value is either a hashref with the data for
that facet, or an array of hashrefs. Some facets must be defined as single
hashrefs, some must be defined as an array of hashrefs, No facets allow both.
C<facet_data()> B<MUST NOT> bless the data it returns, the main hashref, and
nested facet hashrefs B<MUST> be bare, though items contained within each
facet may be blessed. The data returned by this method B<should> also be copies
of the internal data in order to prevent accidental state modification.
C<facets()> takes the data from C<facet_data()> and blesses it into the
C<Test2::EventFacet::*> packages. This is rarely used however, the EventFacet
packages are primarily for convenience and documentation. The EventFacet
classes are not used at all internally, instead the raw data is used.
Here is a list of facet types by package. The packages are not used internally,
but are where the documentation for each type is kept.
B<Note:> Every single facet type has the C<'details'> field. This field is
always intended for human consumption, and when provided, should explain the
'why' for the facet. All other fields are facet specific.
=over 4
=item about => {...}
L<Test2::EventFacet::About>
This contains information about the event itself such as the event package
name. The C<details> field for this facet is an overall summary of the event.
=item assert => {...}
L<Test2::EventFacet::Assert>
This facet is used if an assertion was made. The C<details> field of this facet
is the description of the assertion.
=item control => {...}
L<Test2::EventFacet::Control>
This facet is used to tell the L<Test2::Event::Hub> about special actions the
event causes. Things like halting all testing, terminating the current test,
etc. In this facet the C<details> field explains why any special action was
taken.
B<Note:> This is how bail-out is implemented.
=item meta => {...}
L<Test2::EventFacet::Meta>
The meta facet contains all the meta-data attached to the event. In this case
the C<details> field has no special meaning, but may be present if something
sets the 'details' meta-key on the event.
=item parent => {...}
L<Test2::EventFacet::Parent>
This facet contains nested events and similar details for subtests. In this
facet the C<details> field will typically be the name of the subtest.
=item plan => {...}
L<Test2::EventFacet::Plan>
This facet tells the system that a plan has been set. The C<details> field of
this is usually left empty, but when present explains why the plan is what it
is, this is most useful if the plan is to skip-all.
=item trace => {...}
L<Test2::EventFacet::Trace>
This facet contains information related to when and where the event was
generated. This is how the test file and line number of a failure is known.
This facet can also help you to tell if tests are related.
In this facet the C<details> field overrides the "failed at test_file.t line
42." message provided on assertion failure.
=item amnesty => [{...}, ...]
L<Test2::EventFacet::Amnesty>
The amnesty facet is a list instead of a single item, this is important as
amnesty can come from multiple places at once.
For each instance of amnesty the C<details> field explains why amnesty was
granted.
B<Note:> Outside of formatters amnesty only acts to forgive a failing
assertion.
=item errors => [{...}, ...]
L<Test2::EventFacet::Error>
The errors facet is a list instead of a single item, any number of errors can
be listed. In this facet C<details> describes the error, or may contain the raw
error message itself (such as an exception). In perl exception may be blessed
objects, as such the raw data for this facet may contain nested items which are
blessed.
Not all errors are considered fatal, there is a C<fail> field that must be set
for an error to cause the test to fail.
B<Note:> This facet is unique in that the field name is 'errors' while the
package is 'Error'. This is because this is the only facet type that is both a
list, and has a name where the plural is not the same as the singular. This may
cause some confusion, but I feel it will be less confusing than the
alternative.
=item info => [{...}, ...]
L<Test2::EventFacet::Info>
The 'info' facet is a list instead of a single item, any quantity of extra
information can be attached to an event. Some information may be critical
diagnostics, others may be simply commentary in nature, this is determined by
the C<debug> flag.
For this facet the C<details> flag is the info itself. This info may be a
string, or it may be a data structure to display. This is one of the few facet
types that may contain blessed items.
=back
=head2 LEGACY API
=over 4
=item $bool = $e->causes_fail
Returns true if this event should result in a test failure. In general this
should be false.
=item $bool = $e->increments_count
Should be true if this event should result in a test count increment.
=item $e->callback($hub)
If your event needs to have extra effects on the L<Test2::Hub> you can override
this method.
This is called B<BEFORE> your event is passed to the formatter.
=item $num = $e->nested
If this event is nested inside of other events, this should be the depth of
nesting. (This is mainly for subtests)
=item $bool = $e->global
Set this to true if your event is global, that is ALL threads and processes
should see it no matter when or where it is generated. This is not a common
thing to want, it is used by bail-out and skip_all to end testing.
=item $code = $e->terminate
This is called B<AFTER> your event has been passed to the formatter. This
should normally return undef, only change this if your event should cause the
test to exit immediately.
If you want this event to cause the test to exit you should return the exit
code here. Exit code of 0 means exit success, any other integer means exit with
failure.
This is used by L<Test2::Event::Plan> to exit 0 when the plan is
'skip_all'. This is also used by L<Test2::Event:Bail> to force the test
to exit with a failure.
This is called after the event has been sent to the formatter in order to
ensure the event is seen and understood.
=item $msg = $e->summary
This is intended to be a human readable summary of the event. This should
ideally only be one line long, but you can use multiple lines if necessary. This
is intended for human consumption. You do not need to make it easy for machines
to understand.
The default is to simply return the event package name.
=item ($count, $directive, $reason) = $e->sets_plan()
Check if this event sets the testing plan. It will return an empty list if it
does not. If it does set the plan it will return a list of 1 to 3 items in
order: Expected Test Count, Test Directive, Reason for directive.
=item $bool = $e->diagnostics
True if the event contains diagnostics info. This is useful because a
non-verbose harness may choose to hide events that are not in this category.
Some formatters may choose to send these to STDERR instead of STDOUT to ensure
they are seen.
=item $bool = $e->no_display
False by default. This will return true on events that should not be displayed
by formatters.
=item $id = $e->in_subtest
If the event is inside a subtest this should have the subtest ID.
=item $id = $e->subtest_id
If the event is a final subtest event, this should contain the subtest ID.
=back
=head1 THIRD PARTY META-DATA
This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
way for you to attach meta-data to instances of this class. This is useful for
tools, plugins, and other extensions.
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

109
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/Bail.pm Normal file
View file

@ -0,0 +1,109 @@
package Test2::Event::Bail;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

99
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/Diag.pm Normal file
View file

@ -0,0 +1,99 @@
package Test2::Event::Diag;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

97
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/Encoding.pm Normal file
View file

@ -0,0 +1,97 @@
package Test2::Event::Encoding;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

113
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/Exception.pm Normal file
View file

@ -0,0 +1,113 @@
package Test2::Event::Exception;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

118
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/Fail.pm Normal file
View file

@ -0,0 +1,118 @@
package Test2::Event::Fail;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

280
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/Generic.pm Normal file
View file

@ -0,0 +1,280 @@
package Test2::Event::Generic;
use strict;
use warnings;
use Carp qw/croak/;
use Scalar::Util qw/reftype/;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

97
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/Note.pm Normal file
View file

@ -0,0 +1,97 @@
package Test2::Event::Note;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

169
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/Ok.pm Normal file
View file

@ -0,0 +1,169 @@
package Test2::Event::Ok;
use strict;
use warnings;
our $VERSION = '1.302199';
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 @extra_amnesty = $self->extra_amnesty) {
my %seen;
# It is possible the extra amnesty can be a duplicate, so filter it.
$out->{amnesty} = [
grep { !$seen{defined($_->{tag}) ? $_->{tag} : ''}->{defined($_->{details}) ? $_->{details} : ''}++ }
@extra_amnesty,
@{$out->{amnesty}},
];
}
return $out;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Event::Ok - Ok event type
=head1 DESCRIPTION
Ok events are generated whenever you run a test that produces a result.
Examples are C<ok()>, and C<is()>.
=head1 SYNOPSIS
use Test2::API qw/context/;
use Test2::Event::Ok;
my $ctx = context();
my $event = $ctx->ok($bool, $name, \@diag);
or:
my $ctx = context();
my $event = $ctx->send_event(
'Ok',
pass => $bool,
name => $name,
);
=head1 ACCESSORS
=over 4
=item $rb = $e->pass
The original true/false value of whatever was passed into the event (but
reduced down to 1 or 0).
=item $name = $e->name
Name of the test.
=item $b = $e->effective_pass
This is the true/false value of the test after TODO and similar modifiers are
taken into account.
=back
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

114
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/Pass.pm Normal file
View file

@ -0,0 +1,114 @@
package Test2::Event::Pass;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

169
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/Plan.pm Normal file
View file

@ -0,0 +1,169 @@
package Test2::Event::Plan;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

127
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/Skip.pm Normal file
View file

@ -0,0 +1,127 @@
package Test2::Event::Skip;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

165
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/Subtest.pm Normal file
View file

@ -0,0 +1,165 @@
package Test2::Event::Subtest;
use strict;
use warnings;
our $VERSION = '1.302199';
BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
use Test2::Util::HashBase qw{subevents buffered subtest_id subtest_uuid start_stamp stop_stamp};
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();
my $start = $self->start_stamp;
my $stop = $self->stop_stamp;
$out->{parent} = {
hid => $self->subtest_id,
children => [map {$_->facet_data} @{$self->{+SUBEVENTS}}],
buffered => $self->{+BUFFERED},
$start ? (start_stamp => $start) : (),
$stop ? (stop_stamp => $stop) : (),
};
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

101
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/TAP/Version.pm Normal file
View file

@ -0,0 +1,101 @@
package Test2::Event::TAP::Version;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

239
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/V2.pm Normal file
View file

@ -0,0 +1,239 @@
package Test2::Event::V2;
use strict;
use warnings;
our $VERSION = '1.302199';
use Scalar::Util qw/reftype/;
use Carp qw/croak/;
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use Test2::Util::Facets2Legacy qw{
causes_fail diagnostics global increments_count no_display sets_plan
subtest_id summary terminate
};
use Test2::Util::HashBase qw/-about/;
sub non_facet_keys {
return (
+UUID,
Test2::Util::ExternalMeta::META_KEY(),
);
}
sub init {
my $self = shift;
my $uuid;
if ($uuid = $self->{+UUID}) {
croak "uuid '$uuid' passed to constructor, but uuid '$self->{+ABOUT}->{uuid}' is already set in the 'about' facet"
if $self->{+ABOUT}->{uuid} && $self->{+ABOUT}->{uuid} ne $uuid;
$self->{+ABOUT}->{uuid} = $uuid;
}
elsif ($self->{+ABOUT} && $self->{+ABOUT}->{uuid}) {
$uuid = $self->{+ABOUT}->{uuid};
$self->SUPER::set_uuid($uuid);
}
# Clone the trace, make sure it is blessed
if (my $trace = $self->{+TRACE}) {
$self->{+TRACE} = Test2::EventFacet::Trace->new(%$trace);
}
}
sub set_uuid {
my $self = shift;
my ($uuid) = @_;
$self->{+ABOUT}->{uuid} = $uuid;
$self->SUPER::set_uuid($uuid);
}
sub facet_data {
my $self = shift;
my $f = { %{$self} };
delete $f->{$_} for $self->non_facet_keys;
my %out;
for my $k (keys %$f) {
next if substr($k, 0, 1) eq '_';
my $data = $f->{$k} or next; # Key is there, but no facet
my $is_list = 'ARRAY' eq (reftype($data) || '');
$out{$k} = $is_list ? [ map { {%{$_}} } @$data ] : {%$data};
}
if (my $meta = $self->meta_facet_data) {
$out{meta} = {%$meta, %{$out{meta} || {}}};
}
return \%out;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Event::V2 - Second generation event.
=head1 DESCRIPTION
This is the event type that should be used instead of L<Test2::Event> or its
legacy subclasses.
=head1 SYNOPSIS
=head2 USING A CONTEXT
use Test2::API qw/context/;
sub my_tool {
my $ctx = context();
my $event = $ctx->send_ev2(info => [{tag => 'NOTE', details => "This is a note"}]);
$ctx->release;
return $event;
}
=head2 USING THE CONSTRUCTOR
use Test2::Event::V2;
my $e = Test2::Event::V2->new(
trace => {frame => [$PKG, $FILE, $LINE, $SUBNAME]},
info => [{tag => 'NOTE', details => "This is a note"}],
);
=head1 METHODS
This class inherits from L<Test2::Event>.
=over 4
=item $fd = $e->facet_data()
This will return a hashref of facet data. Each facet hash will be a shallow
copy of the original.
=item $about = $e->about()
This will return the 'about' facet hashref.
B<NOTE:> This will return the internal hashref, not a copy.
=item $trace = $e->trace()
This will return the 'trace' facet, normally blessed (but this is not enforced
when the trace is set using C<set_trace()>.
B<NOTE:> This will return the internal trace, not a copy.
=back
=head2 MUTATION
=over 4
=item $e->add_amnesty({...})
Inherited from L<Test2::Event>. This can be used to add 'amnesty' facets to an
existing event. Each new item is added to the B<END> of the list.
B<NOTE:> Items B<ARE> blessed when added.
=item $e->add_hub({...})
Inherited from L<Test2::Event>. This is used by hubs to stamp events as they
pass through. New items are added to the B<START> of the list.
B<NOTE:> Items B<ARE NOT> blessed when added.
=item $e->set_uuid($UUID)
Inherited from L<Test2::Event>, overridden to also vivify/mutate the 'about'
facet.
=item $e->set_trace($trace)
Inherited from L<Test2::Event> which allows you to change the trace.
B<Note:> This method does not bless/clone the trace for you. Many things will
expect the trace to be blessed, so you should probably do that.
=back
=head2 LEGACY SUPPORT METHODS
These are all imported from L<Test2::Util::Facets2Legacy>, see that module or
L<Test2::Event> for documentation on what they do.
=over 4
=item causes_fail
=item diagnostics
=item global
=item increments_count
=item no_display
=item sets_plan
=item subtest_id
=item summary
=item terminate
=back
=head1 THIRD PARTY META-DATA
This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
way for you to attach meta-data to instances of this class. This is useful for
tools, plugins, and other extensions.
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

76
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Event/Waiting.pm Normal file
View file

@ -0,0 +1,76 @@
package Test2::Event::Waiting;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

93
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet.pm Normal file
View file

@ -0,0 +1,93 @@
package Test2::EventFacet;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

92
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet/About.pm Normal file
View file

@ -0,0 +1,92 @@
package Test2::EventFacet::About;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

91
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet/Amnesty.pm Normal file
View file

@ -0,0 +1,91 @@
package Test2::EventFacet::Amnesty;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

93
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet/Assert.pm Normal file
View file

@ -0,0 +1,93 @@
package Test2::EventFacet::Assert;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

107
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet/Control.pm Normal file
View file

@ -0,0 +1,107 @@
package Test2::EventFacet::Control;
use strict;
use warnings;
our $VERSION = '1.302199';
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{ -global -terminate -halt -has_callback -encoding -phase };
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::EventFacet::Control - Facet for hub actions and behaviors.
=head1 DESCRIPTION
This facet is used when the event needs to give instructions to the Test2
internals.
=head1 FIELDS
=over 4
=item $string = $control->{details}
=item $string = $control->details()
Human readable explanation for the special behavior.
=item $bool = $control->{global}
=item $bool = $control->global()
True if the event is global in nature and should be seen by all hubs.
=item $exit = $control->{terminate}
=item $exit = $control->terminate()
Defined if the test should immediately exit, the value is the exit code and may
be C<0>.
=item $bool = $control->{halt}
=item $bool = $control->halt()
True if all testing should be halted immediately.
=item $bool = $control->{has_callback}
=item $bool = $control->has_callback()
True if the C<callback($hub)> method on the event should be called.
=item $encoding = $control->{encoding}
=item $encoding = $control->encoding()
This can be used to change the encoding from this event onward.
=item $phase = $control->{phase}
=item $phase = $control->phase()
Used to signal that a phase change has occurred. Currently only the perl END
phase is signaled.
=back
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

93
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet/Error.pm Normal file
View file

@ -0,0 +1,93 @@
package Test2::EventFacet::Error;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

109
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet/Hub.pm Normal file
View file

@ -0,0 +1,109 @@
package Test2::EventFacet::Hub;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

132
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet/Info.pm Normal file
View file

@ -0,0 +1,132 @@
package Test2::EventFacet::Info;
use strict;
use warnings;
our $VERSION = '1.302199';
sub is_list { 1 }
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{-tag -debug -important -table};
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::EventFacet::Info - Facet for information a developer might care about.
=head1 DESCRIPTION
This facet represents messages intended for humans that will help them either
understand a result, or diagnose a failure.
=head1 NOTES
This facet appears in a list instead of being a single item.
=head1 FIELDS
=over 4
=item $string_or_structure = $info->{details}
=item $string_or_structure = $info->details()
Human readable string or data structure, this is the information to display.
Formatters are free to render the structures however they please. This may
contain a blessed object.
If the C<table> attribute (see below) is set then a renderer may choose to
display the table instead of the details.
=item $structure = $info->{table}
=item $structure = $info->table()
If the data the C<info> facet needs to convey can be represented as a table
then the data may be placed in this attribute in a more raw form for better
display. The data must also be represented in the C<details> attribute for
renderers which do not support rendering tables directly.
The table structure:
my %table = {
header => [ 'column 1 header', 'column 2 header', ... ], # Optional
rows => [
['row 1 column 1', 'row 1, column 2', ... ],
['row 2 column 1', 'row 2, column 2', ... ],
...
],
# Allow the renderer to hide empty columns when true, Optional
collapse => $BOOL,
# List by name or number columns that should never be collapsed
no_collapse => \@LIST,
}
=item $short_string = $info->{tag}
=item $short_string = $info->tag()
Short tag to categorize the info. This is usually 10 characters or less,
formatters may truncate longer tags.
=item $bool = $info->{debug}
=item $bool = $info->debug()
Set this to true if the message is critical, or explains a failure. This is
info that should be displayed by formatters even in less-verbose modes.
When false the information is not considered critical and may not be rendered
in less-verbose modes.
=item $bool = $info->{important}
=item $bool = $info->important
This should be set for non debug messages that are still important enough to
show when a formatter is in quiet mode. A formatter should send these to STDOUT
not STDERR, but should show them even in non-verbose mode.
=back
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

144
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet/Info/Table.pm Normal file
View file

@ -0,0 +1,144 @@
package Test2::EventFacet::Info::Table;
use strict;
use warnings;
our $VERSION = '1.302199';
use Carp qw/confess/;
use Test2::Util::HashBase qw{-header -rows -collapse -no_collapse -as_string};
sub init {
my $self = shift;
confess "Table may not be empty" unless ref($self->{+ROWS}) eq 'ARRAY' && @{$self->{+ROWS}};
$self->{+AS_STRING} ||= '<TABLE NOT DISPLAYED>';
}
sub as_hash { my $out = +{%{$_[0]}}; delete $out->{as_string}; $out }
sub info_args {
my $self = shift;
my $hash = $self->as_hash;
my $desc = $self->as_string;
return (table => $hash, details => $desc);
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::EventFacet::Info::Table - Intermediary representation of a table.
=head1 DESCRIPTION
Intermediary representation of a table for use in specialized
L<Test::API::Context> methods which generate L<Test2::EventFacet::Info> facets.
=head1 SYNOPSIS
use Test2::EventFacet::Info::Table;
use Test2::API qw/context/;
sub my_tool {
my $ctx = context();
...
$ctx->fail(
$name,
"failure diag message",
Test2::EventFacet::Info::Table->new(
# Required
rows => [['a', 'b'], ['c', 'd'], ...],
# Strongly Recommended
as_string => "... string to print when table cannot be rendered ...",
# Optional
header => ['col1', 'col2'],
collapse => $bool,
no_collapse => ['col1', ...],
),
);
...
$ctx->release;
}
my_tool();
=head1 ATTRIBUTES
=over 4
=item $header_aref = $t->header()
=item $rows_aref = $t->rows()
=item $bool = $t->collapse()
=item $aref = $t->no_collapse()
The above are all directly tied to the table hashref structure described in
L<Test2::EventFacet::Info>.
=item $str = $t->as_string()
This returns the string form of the table if it was set, otherwise it returns
the string C<< "<TABLE NOT DISPLAYED>" >>.
=item $href = $t->as_hash()
This returns the data structure used for tables by L<Test2::EventFacet::Info>.
=item %args = $t->info_args()
This returns the arguments that should be used to construct the proper
L<Test2::EventFacet::Info> structure.
return (table => $t->as_hash(), details => $t->as_string());
=back
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

104
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet/Meta.pm Normal file
View file

@ -0,0 +1,104 @@
package Test2::EventFacet::Meta;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

98
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet/Parent.pm Normal file
View file

@ -0,0 +1,98 @@
package Test2::EventFacet::Parent;
use strict;
use warnings;
our $VERSION = '1.302199';
use Carp qw/confess/;
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util::HashBase qw{-hid -children -buffered -start_stamp -stop_stamp};
sub init {
confess "Attribute 'hid' must be set"
unless defined $_[0]->{+HID};
$_[0]->{+CHILDREN} ||= [];
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::EventFacet::Parent - Facet for events contains other events
=head1 DESCRIPTION
This facet is used when an event contains other events, such as a subtest.
=head1 FIELDS
=over 4
=item $string = $parent->{details}
=item $string = $parent->details()
Human readable description of the event.
=item $hid = $parent->{hid}
=item $hid = $parent->hid()
Hub ID of the hub that is represented in the parent-child relationship.
=item $arrayref = $parent->{children}
=item $arrayref = $parent->children()
Arrayref containing the facet-data hashes of events nested under this one.
I<To get the actual events you need to get them from the parent event directly>
=item $bool = $parent->{buffered}
=item $bool = $parent->buffered()
True if the subtest is buffered (meaning the formatter has probably not seen
them yet).
=back
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

94
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet/Plan.pm Normal file
View file

@ -0,0 +1,94 @@
package Test2::EventFacet::Plan;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

106
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet/Render.pm Normal file
View file

@ -0,0 +1,106 @@
package Test2::EventFacet::Render;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

307
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/EventFacet/Trace.pm Normal file
View file

@ -0,0 +1,307 @@
package Test2::EventFacet::Trace;
use strict;
use warnings;
our $VERSION = '1.302199';
BEGIN { require Test2::EventFacet; our @ISA = qw(Test2::EventFacet) }
use Test2::Util qw/get_tid pkg_to_file gen_uid/;
use Time::HiRes qw/time/;
use Carp qw/confess/;
use Test2::Util::HashBase qw{^frame ^pid ^tid ^cid -hid -nested details -buffered -uuid -huuid <full_caller <stamp};
{
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 full_call { @{$_[0]->{+FULL_CALLER}} }
sub package { $_[0]->{+FRAME}->[0] }
sub file { $_[0]->{+FRAME}->[1] }
sub line { $_[0]->{+FRAME}->[2] }
sub subname { $_[0]->{+FRAME}->[3] }
sub warning_bits { $_[0]->{+FULL_CALLER} ? $_[0]->{+FULL_CALLER}->[9] : undef }
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.
[$package, $file, $line, $subname]
=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)
=item ($pkg, $file, $line, $subname) = $trace->call
Get the basic call info as a list.
=item @caller = $trace->full_call
Get the full caller(N) results.
=item $warning_bits = $trace->warning_bits
Get index 9 from the full caller info. This is the warnings_bits field.
The value of this is not portable across perl versions or even processes.
However it can be used in the process that generated it to reproduce the
warnings settings in a new scope.
eval <<EOT;
BEGIN { ${^WARNING_BITS} = $trace->warning_bits };
... context's warning settings apply here ...
EOT
=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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

158
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Formatter.pm Normal file
View file

@ -0,0 +1,158 @@
package Test2::Formatter;
use strict;
use warnings;
our $VERSION = '1.302199';
my %ADDED;
sub import {
my $class = shift;
return if $class eq __PACKAGE__;
return if $ADDED{$class}++;
require Test2::API;
Test2::API::test2_formatter_add($class);
}
sub new_root {
my $class = shift;
return $class->new(@_);
}
sub supports_tables { 0 }
sub hide_buffered { 1 }
sub terminate { }
sub finalize { }
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Formatter - Namespace for formatters.
=head1 DESCRIPTION
This is the namespace for formatters. This is an empty package.
=head1 CREATING FORMATTERS
A formatter is any package or object with a C<write($event, $num)> method.
package Test2::Formatter::Foo;
use strict;
use warnings;
sub write {
my $self_or_class = shift;
my ($event, $assert_num) = @_;
...
}
sub hide_buffered { 1 }
sub terminate { }
sub finalize { }
sub supports_tables { return $BOOL }
sub new_root {
my $class = shift;
...
$class->new(@_);
}
1;
The C<write> method is a method, so it either gets a class or instance. The two
arguments are the C<$event> object it should record, and the C<$assert_num>
which is the number of the current assertion (ok), or the last assertion if
this event is not itself an assertion. The assertion number may be any integer 0
or greater, and may be undefined in some cases.
The C<hide_buffered()> method must return a boolean. This is used to tell
buffered subtests whether or not to send it events as they are being buffered.
See L<Test2::API/"run_subtest(...)"> for more information.
The C<terminate> and C<finalize> methods are optional methods called that you
can implement if the format you're generating needs to handle these cases, for
example if you are generating XML and need close open tags.
The C<terminate> method is called when an event's C<terminate> method returns
true, for example when a L<Test2::Event::Plan> has a C<'skip_all'> plan, or
when a L<Test2::Event::Bail> event is sent. The C<terminate> method is passed
a single argument, the L<Test2::Event> object which triggered the terminate.
The C<finalize> method is always the last thing called on the formatter, I<<
except when C<terminate> is called for a Bail event >>. It is passed the
following arguments:
The C<supports_tables> method should be true if the formatter supports directly
rendering table data from the C<info> facets. This is a newer feature and many
older formatters may not support it. When not supported the formatter falls
back to rendering C<detail> instead of the C<table> data.
The C<new_root> method is used when constructing a root formatter. The default
is to just delegate to the regular C<new()> method, most formatters can ignore
this.
=over 4
=item * The number of tests that were planned
=item * The number of tests actually seen
=item * The number of tests which failed
=item * A boolean indicating whether or not the test suite passed
=item * A boolean indicating whether or not this call is for a subtest
=back
The C<new_root> method is called when C<Test2::API::Stack> Initializes the root
hub for the first time. Most formatters will simply have this call C<<
$class->new >>, which is the default behavior. Some formatters however may want
to take extra action during construction of the root formatter, this is where
they can do that.
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

528
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Formatter/TAP.pm Normal file
View file

@ -0,0 +1,528 @@
package Test2::Formatter::TAP;
use strict;
use warnings;
our $VERSION = '1.302199';
use Test2::Util qw/clone_io/;
use Test2::Util::HashBase qw{
no_numbers handles _encoding _last_fh
-made_assertion
};
sub OUT_STD() { 0 }
sub OUT_ERR() { 1 }
BEGIN { require Test2::Formatter; our @ISA = qw(Test2::Formatter) }
my $supports_tables;
sub supports_tables {
if (!defined $supports_tables) {
local $SIG{__DIE__} = 'DEFAULT';
local $@;
$supports_tables
= ($INC{'Term/Table.pm'} && $INC{'Term/Table/Util.pm'})
|| eval { require Term::Table; require Term::Table::Util; 1 }
|| 0;
}
return $supports_tables;
}
sub _autoflush {
my($fh) = pop;
my $old_fh = select $fh;
$| = 1;
select $old_fh;
}
_autoflush(\*STDOUT);
_autoflush(\*STDERR);
sub hide_buffered { 1 }
sub init {
my $self = shift;
$self->{+HANDLES} ||= $self->_open_handles;
if(my $enc = delete $self->{encoding}) {
$self->encoding($enc);
}
}
sub _open_handles {
my $self = shift;
require Test2::API;
my $out = clone_io(Test2::API::test2_stdout());
my $err = clone_io(Test2::API::test2_stderr());
_autoflush($out);
_autoflush($err);
return [$out, $err];
}
sub encoding {
my $self = shift;
if ($] ge "5.007003" and @_) {
my ($enc) = @_;
my $handles = $self->{+HANDLES};
# https://rt.perl.org/Public/Bug/Display.html?id=31923
# If utf8 is requested we use ':utf8' instead of ':encoding(utf8)' in
# order to avoid the thread segfault.
if ($enc =~ m/^utf-?8$/i) {
binmode($_, ":utf8") for @$handles;
}
else {
binmode($_, ":encoding($enc)") for @$handles;
}
$self->{+_ENCODING} = $enc;
}
return $self->{+_ENCODING};
}
if ($^C) {
no warnings 'redefine';
*write = sub {};
}
sub write {
my ($self, $e, $num, $f) = @_;
# The most common case, a pass event with no amnesty and a normal name.
return if $self->print_optimal_pass($e, $num);
$f ||= $e->facet_data;
$self->encoding($f->{control}->{encoding}) if $f->{control}->{encoding};
my @tap = $self->event_tap($f, $num) or return;
$self->{+MADE_ASSERTION} = 1 if $f->{assert};
my $nesting = $f->{trace}->{nested} || 0;
my $handles = $self->{+HANDLES};
my $indent = ' ' x $nesting;
# Local is expensive! Only do it if we really need to.
local($\, $,) = (undef, '') if $\ || $,;
for my $set (@tap) {
no warnings 'uninitialized';
my ($hid, $msg) = @$set;
next unless $msg;
my $io = $handles->[$hid] or next;
print $io "\n"
if $ENV{HARNESS_ACTIVE}
&& $hid == OUT_ERR
&& $self->{+_LAST_FH} != $io
&& $msg =~ m/^#\s*Failed( \(TODO\))? test /;
$msg =~ s/^/$indent/mg if $nesting;
print $io $msg;
$self->{+_LAST_FH} = $io;
}
}
sub print_optimal_pass {
my ($self, $e, $num) = @_;
my $type = ref($e);
# Only optimal if this is a Pass or a passing Ok
return unless $type eq 'Test2::Event::Pass' || ($type eq 'Test2::Event::Ok' && $e->{pass});
# Amnesty requires further processing (todo is a form of amnesty)
return if ($e->{amnesty} && @{$e->{amnesty}}) || defined($e->{todo});
# A name with a newline or hash symbol needs extra processing
return if defined($e->{name}) && (-1 != index($e->{name}, "\n") || -1 != index($e->{name}, '#'));
my $ok = 'ok';
$ok .= " $num" if $num && !$self->{+NO_NUMBERS};
$ok .= defined($e->{name}) ? " - $e->{name}\n" : "\n";
if (my $nesting = $e->{trace}->{nested}) {
my $indent = ' ' x $nesting;
$ok = "$indent$ok";
}
my $io = $self->{+HANDLES}->[OUT_STD];
local($\, $,) = (undef, '') if $\ || $,;
print $io $ok;
$self->{+_LAST_FH} = $io;
return 1;
}
sub event_tap {
my ($self, $f, $num) = @_;
my @tap;
# If this IS the first event the plan should come first
# (plan must be before or after assertions, not in the middle)
push @tap => $self->plan_tap($f) if $f->{plan} && !$self->{+MADE_ASSERTION};
# The assertion is most important, if present.
if ($f->{assert}) {
push @tap => $self->assert_tap($f, $num);
push @tap => $self->debug_tap($f, $num) unless $f->{assert}->{no_debug} || $f->{assert}->{pass};
}
# Almost as important as an assertion
push @tap => $self->error_tap($f) if $f->{errors};
# Now lets see the diagnostics messages
push @tap => $self->info_tap($f) if $f->{info};
# If this IS NOT the first event the plan should come last
# (plan must be before or after assertions, not in the middle)
push @tap => $self->plan_tap($f) if $self->{+MADE_ASSERTION} && $f->{plan};
# Bail out
push @tap => $self->halt_tap($f) if $f->{control}->{halt};
return @tap if @tap;
return @tap if $f->{control}->{halt};
return @tap if grep { $f->{$_} } qw/assert plan info errors/;
# Use the summary as a fallback if nothing else is usable.
return $self->summary_tap($f, $num);
}
sub error_tap {
my $self = shift;
my ($f) = @_;
my $IO = ($f->{amnesty} && @{$f->{amnesty}}) ? OUT_STD : OUT_ERR;
return map {
my $details = $_->{details};
my $msg;
if (ref($details)) {
require Data::Dumper;
my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1);
chomp($msg = $dumper->Dump);
}
else {
chomp($msg = $details);
$msg =~ s/^/# /;
$msg =~ s/\n/\n# /g;
}
[$IO, "$msg\n"];
} @{$f->{errors}};
}
sub plan_tap {
my $self = shift;
my ($f) = @_;
my $plan = $f->{plan} or return;
return if $plan->{none};
if ($plan->{skip}) {
my $reason = $plan->{details} or return [OUT_STD, "1..0 # SKIP\n"];
chomp($reason);
return [OUT_STD, '1..0 # SKIP ' . $reason . "\n"];
}
return [OUT_STD, "1.." . $plan->{count} . "\n"];
}
sub no_subtest_space { 0 }
sub assert_tap {
my $self = shift;
my ($f, $num) = @_;
my $assert = $f->{assert} or return;
my $pass = $assert->{pass};
my $name = $assert->{details};
my $ok = $pass ? 'ok' : 'not ok';
$ok .= " $num" if $num && !$self->{+NO_NUMBERS};
# The regex form is ~250ms, the index form is ~50ms
my @extra;
defined($name) && (
(index($name, "\n") != -1 && (($name, @extra) = split(/\n\r?/, $name, -1))),
((index($name, "#" ) != -1 || substr($name, -1) eq '\\') && (($name =~ s|\\|\\\\|g), ($name =~ s|#|\\#|g)))
);
my $extra_space = @extra ? ' ' x (length($ok) + 2) : '';
my $extra_indent = '';
my ($directives, $reason, $is_skip);
if ($f->{amnesty}) {
my %directives;
for my $am (@{$f->{amnesty}}) {
next if $am->{inherited};
my $tag = $am->{tag} or next;
$is_skip = 1 if $tag eq 'skip';
$directives{$tag} ||= $am->{details};
}
my %seen;
# Sort so that TODO comes before skip even on systems where lc sorts
# before uc, as other code depends on that ordering.
my @order = grep { !$seen{$_}++ } sort { lc $b cmp lc $a } keys %directives;
$directives = ' # ' . join ' & ' => @order;
for my $tag ('skip', @order) {
next unless defined($directives{$tag}) && length($directives{$tag});
$reason = $directives{$tag};
last;
}
}
$ok .= " - $name" if defined $name && !($is_skip && !$name);
my @subtap;
if ($f->{parent} && $f->{parent}->{buffered}) {
$ok .= ' {';
# In a verbose harness we indent the extra since they will appear
# inside the subtest braces. This helps readability. In a non-verbose
# harness we do not do this because it is less readable.
if ($ENV{HARNESS_IS_VERBOSE} || !$ENV{HARNESS_ACTIVE}) {
$extra_indent = " ";
$extra_space = ' ';
}
# Render the sub-events, we use our own counter for these.
my $count = 0;
@subtap = map {
my $f2 = $_;
# Bump the count for any event that should bump it.
$count++ if $f2->{assert};
# This indents all output lines generated for the sub-events.
# index 0 is the filehandle, index 1 is the message we want to indent.
map { $_->[1] =~ s/^(.*\S.*)$/ $1/mg; $_ } $self->event_tap($f2, $count);
} @{$f->{parent}->{children}};
push @subtap => [OUT_STD, "}\n"];
}
if ($directives) {
$directives = ' # TODO & SKIP' if $directives eq ' # TODO & skip';
$ok .= $directives;
$ok .= " $reason" if defined($reason);
}
$extra_space = ' ' if $self->no_subtest_space;
my @out = ([OUT_STD, "$ok\n"]);
push @out => map {[OUT_STD, "${extra_indent}#${extra_space}$_\n"]} @extra if @extra;
push @out => @subtap;
return @out;
}
sub debug_tap {
my ($self, $f, $num) = @_;
# Figure out the debug info, this is typically the file name and line
# number, but can also be a custom message. If no trace object is provided
# then we have nothing useful to display.
my $name = $f->{assert}->{details};
my $trace = $f->{trace};
my $debug = "[No trace info available]";
if ($trace->{details}) {
$debug = $trace->{details};
}
elsif ($trace->{frame}) {
my ($pkg, $file, $line) = @{$trace->{frame}};
$debug = "at $file line $line." if $file && $line;
}
my $amnesty = $f->{amnesty} && @{$f->{amnesty}}
? ' (with amnesty)'
: '';
# Create the initial diagnostics. If the test has a name we put the debug
# info on a second line, this behavior is inherited from Test::Builder.
my $msg = defined($name)
? qq[# Failed test${amnesty} '$name'\n# $debug\n]
: qq[# Failed test${amnesty} $debug\n];
my $IO = $f->{amnesty} && @{$f->{amnesty}} ? OUT_STD : OUT_ERR;
return [$IO, $msg];
}
sub halt_tap {
my ($self, $f) = @_;
return if $f->{trace}->{nested} && !$f->{trace}->{buffered};
my $details = $f->{control}->{details};
return [OUT_STD, "Bail out!\n"] unless defined($details) && length($details);
return [OUT_STD, "Bail out! $details\n"];
}
sub info_tap {
my ($self, $f) = @_;
return map {
my $details = $_->{details};
my $table = $_->{table};
my $IO = $_->{debug} && !($f->{amnesty} && @{$f->{amnesty}}) ? OUT_ERR : OUT_STD;
my $msg;
if ($table && $self->supports_tables) {
$msg = join "\n" => map { "# $_" } Term::Table->new(
header => $table->{header},
rows => $table->{rows},
collapse => $table->{collapse},
no_collapse => $table->{no_collapse},
sanitize => 1,
mark_tail => 1,
max_width => $self->calc_table_size($f),
)->render();
}
elsif (ref($details)) {
require Data::Dumper;
my $dumper = Data::Dumper->new([$details])->Indent(2)->Terse(1)->Pad('# ')->Useqq(1)->Sortkeys(1);
chomp($msg = $dumper->Dump);
}
else {
chomp($msg = $details);
$msg =~ s/^/# /;
$msg =~ s/\n/\n# /g;
}
[$IO, "$msg\n"];
} @{$f->{info}};
}
sub summary_tap {
my ($self, $f, $num) = @_;
return if $f->{about}->{no_display};
my $summary = $f->{about}->{details} or return;
chomp($summary);
$summary =~ s/^/# /smg;
return [OUT_STD, "$summary\n"];
}
sub calc_table_size {
my $self = shift;
my ($f) = @_;
my $term = Term::Table::Util::term_size();
my $nesting = 2 + (($f->{trace}->{nested} || 0) * 4); # 4 spaces per level, also '# ' prefix
my $total = $term - $nesting;
# Sane minimum width, any smaller and we are asking for pain
return 50 if $total < 50;
return $total;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Formatter::TAP - Standard TAP formatter
=head1 DESCRIPTION
This is what takes events and turns them into TAP.
=head1 SYNOPSIS
use Test2::Formatter::TAP;
my $tap = Test2::Formatter::TAP->new();
# Switch to utf8
$tap->encoding('utf8');
$tap->write($event, $number); # Output an event
=head1 METHODS
=over 4
=item $bool = $tap->no_numbers
=item $tap->set_no_numbers($bool)
Use to turn numbers on and off.
=item $arrayref = $tap->handles
=item $tap->set_handles(\@handles);
Can be used to get/set the filehandles. Indexes are identified by the
C<OUT_STD> and C<OUT_ERR> constants.
=item $encoding = $tap->encoding
=item $tap->encoding($encoding)
Get or set the encoding. By default no encoding is set, the original settings
of STDOUT and STDERR are used.
This directly modifies the stored filehandles, it does not create new ones.
=item $tap->write($e, $num)
Write an event to the console.
=back
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=item Kent Fredric E<lt>kentnl@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

909
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Hub.pm Normal file
View file

@ -0,0 +1,909 @@
package Test2::Hub;
use strict;
use warnings;
our $VERSION = '1.302199';
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} ? $f->{control}->{terminate} : undef;
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} && $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} && $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 ((defined($plan) && $plan eq 'NO PLAN') || ($do_plan && !defined($plan))) {
$self->send(
Test2::Event::Plan->new(
trace => $trace,
max => $count,
)
);
}
$plan = $self->{+_PLAN};
}
my $frame = $trace->frame;
if($self->{+ENDED}) {
my (undef, $ffile, $fline) = @{$self->{+ENDED}};
my (undef, $sfile, $sline) = @$frame;
die <<" EOT"
Test already ended!
First End: $ffile line $fline
Second End: $sfile line $sline
EOT
}
$self->{+ENDED} = $frame;
my $pass = $self->is_passing(); # Generate the final boolean.
$self->{+_FORMATTER}->finalize($plan, $count, $failed, $pass, $self->is_subtest) if $self->{+_FORMATTER};
return $pass;
}
sub is_passing {
my $self = shift;
($self->{+_PASSING}) = @_ if @_;
# If we already failed just return 0.
my $pass = $self->{+_PASSING} or return 0;
return $self->{+_PASSING} = 0 if $self->{+FAILED};
my $count = $self->{+COUNT};
my $ended = $self->{+ENDED};
my $plan = $self->{+_PLAN};
return $pass if !$count && $plan && $plan =~ m/^SKIP$/;
return $self->{+_PASSING} = 0
if $ended && (!$count || !$plan);
return $pass unless $plan && $plan =~ m/^\d+$/;
if ($ended) {
return $self->{+_PASSING} = 0 if $count != $plan;
}
else {
return $self->{+_PASSING} = 0 if $count > $plan;
}
return $pass;
}
sub plan {
my $self = shift;
return $self->{+_PLAN} unless @_;
my ($plan) = @_;
confess "You cannot unset the plan"
unless defined $plan;
confess "You cannot change the plan"
if $self->{+_PLAN} && $self->{+_PLAN} !~ m/^NO PLAN$/;
confess "'$plan' is not a valid plan! Plan must be an integer greater than 0, 'NO PLAN', or 'SKIP'"
unless $plan =~ m/^(\d+|NO PLAN|SKIP)$/;
$self->{+_PLAN} = $plan;
}
sub check_plan {
my $self = shift;
return undef unless $self->{+ENDED};
my $plan = $self->{+_PLAN} || return undef;
return 1 if $plan !~ m/^\d+$/;
return 1 if $plan == $self->{+COUNT};
return 0;
}
sub DESTROY {
my $self = shift;
my $ipc = $self->{+IPC} || return;
return unless $$ == $self->{+PID};
return unless get_tid() == $self->{+TID};
$ipc->drop_hub($self->{+HID});
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::Hub - The conduit through which all events flow.
=head1 SYNOPSIS
use Test2::Hub;
my $hub = Test2::Hub->new();
$hub->send(...);
=head1 DESCRIPTION
The hub is the place where all events get processed and handed off to the
formatter. The hub also tracks test state, and provides several hooks into the
event pipeline.
=head1 COMMON TASKS
=head2 SENDING EVENTS
$hub->send($event)
The C<send()> method is used to issue an event to the hub. This method will
handle thread/fork sync, filters, listeners, TAP output, etc.
=head2 ALTERING OR REMOVING EVENTS
You can use either C<filter()> or C<pre_filter()>, depending on your
needs. Both have identical syntax, so only C<filter()> is shown here.
$hub->filter(sub {
my ($hub, $event) = @_;
my $action = get_action($event);
# No action should be taken
return $event if $action eq 'none';
# You want your filter to remove the event
return undef if $action eq 'delete';
if ($action eq 'do_it') {
my $new_event = copy_event($event);
... Change your copy of the event ...
return $new_event;
}
die "Should not happen";
});
By default, filters are not inherited by child hubs. That means if you start a
subtest, the subtest will not inherit the filter. You can change this behavior
with the C<inherit> parameter:
$hub->filter(sub { ... }, inherit => 1);
=head2 LISTENING FOR EVENTS
$hub->listen(sub {
my ($hub, $event, $number) = @_;
... do whatever you want with the event ...
# return is ignored
});
By default listeners are not inherited by child hubs. That means if you start a
subtest, the subtest will not inherit the listener. You can change this behavior
with the C<inherit> parameter:
$hub->listen(sub { ... }, inherit => 1);
=head2 POST-TEST BEHAVIORS
$hub->follow_up(sub {
my ($trace, $hub) = @_;
... do whatever you need to ...
# Return is ignored
});
follow_up subs are called only once, either when done_testing is called, or in
an END block.
=head2 SETTING THE FORMATTER
By default an instance of L<Test2::Formatter::TAP> is created and used.
my $old = $hub->format(My::Formatter->new);
Setting the formatter will REPLACE any existing formatter. You may set the
formatter to undef to prevent output. The old formatter will be returned if one
was already set. Only one formatter is allowed at a time.
=head1 METHODS
=over 4
=item $hub->send($event)
This is where all events enter the hub for processing.
=item $hub->process($event)
This is called by send after it does any IPC handling. You can use this to
bypass the IPC process, but in general you should avoid using this.
=item $old = $hub->format($formatter)
Replace the existing formatter instance with a new one. Formatters must be
objects that implement a C<< $formatter->write($event) >> method.
=item $sub = $hub->listen(sub { ... }, %optional_params)
You can use this to record all events AFTER they have been sent to the
formatter. No changes made here will be meaningful, except possibly to other
listeners.
$hub->listen(sub {
my ($hub, $event, $number) = @_;
... do whatever you want with the event ...
# return is ignored
});
Normally listeners are not inherited by child hubs such as subtests. You can
add the C<< inherit => 1 >> parameter to allow a listener to be inherited.
=item $hub->unlisten($sub)
You can use this to remove a listen callback. You must pass in the coderef
returned by the C<listen()> method.
=item $sub = $hub->filter(sub { ... }, %optional_params)
=item $sub = $hub->pre_filter(sub { ... }, %optional_params)
These can be used to add filters. Filters can modify, replace, or remove events
before anything else can see them.
$hub->filter(
sub {
my ($hub, $event) = @_;
return $event; # No Changes
return; # Remove the event
# Or you can modify an event before returning it.
$event->modify;
return $event;
}
);
If you are not using threads, forking, or IPC then the only difference between
a C<filter> and a C<pre_filter> is that C<pre_filter> subs run first. When you
are using threads, forking, or IPC, pre_filters happen to events before they
are sent to their destination proc/thread, ordinary filters happen only in the
destination hub/thread.
You cannot add a regular filter to a hub if the hub was created in another
process or thread. You can always add a pre_filter.
=item $hub->unfilter($sub)
=item $hub->pre_unfilter($sub)
These can be used to remove filters and pre_filters. The C<$sub> argument is
the reference returned by C<filter()> or C<pre_filter()>.
=item $hub->follow_op(sub { ... })
Use this to add behaviors that are called just before the hub is finalized. The
only argument to your codeblock will be a L<Test2::EventFacet::Trace> instance.
$hub->follow_up(sub {
my ($trace, $hub) = @_;
... do whatever you need to ...
# Return is ignored
});
follow_up subs are called only once, ether when done_testing is called, or in
an END block.
=item $sub = $hub->add_context_acquire(sub { ... });
Add a callback that will be called every time someone tries to acquire a
context. It gets a single argument, a reference of the hash of parameters
being used the construct the context. This is your chance to change the
parameters by directly altering the hash.
test2_add_callback_context_acquire(sub {
my $params = shift;
$params->{level}++;
});
This is a very scary API function. Please do not use this unless you need to.
This is here for L<Test::Builder> and backwards compatibility. This has you
directly manipulate the hash instead of returning a new one for performance
reasons.
B<Note> Using this hook could have a huge performance impact.
The coderef you provide is returned and can be used to remove the hook later.
=item $hub->remove_context_acquire($sub);
This can be used to remove a context acquire hook.
=item $sub = $hub->add_context_init(sub { ... });
This allows you to add callbacks that will trigger every time a new context is
created for the hub. The only argument to the sub will be the
L<Test2::API::Context> instance that was created.
B<Note> Using this hook could have a huge performance impact.
The coderef you provide is returned and can be used to remove the hook later.
=item $hub->remove_context_init($sub);
This can be used to remove a context init hook.
=item $sub = $hub->add_context_release(sub { ... });
This allows you to add callbacks that will trigger every time a context for
this hub is released. The only argument to the sub will be the
L<Test2::API::Context> instance that was released. These will run in reverse
order.
B<Note> Using this hook could have a huge performance impact.
The coderef you provide is returned and can be used to remove the hook later.
=item $hub->remove_context_release($sub);
This can be used to remove a context release hook.
=item $hub->cull()
Cull any IPC events (and process them).
=item $pid = $hub->pid()
Get the process id under which the hub was created.
=item $tid = $hub->tid()
Get the thread id under which the hub was created.
=item $hud = $hub->hid()
Get the identifier string of the hub.
=item $uuid = $hub->uuid()
If UUID tagging is enabled (see L<Test2::API>) then the hub will have a UUID.
=item $ipc = $hub->ipc()
Get the IPC object used by the hub.
=item $hub->set_no_ending($bool)
=item $bool = $hub->no_ending
This can be used to disable auto-ending behavior for a hub. The auto-ending
behavior is triggered by an end block and is used to cull IPC events, and
output the final plan if the plan was 'NO PLAN'.
=item $bool = $hub->active
=item $hub->set_active($bool)
These are used to get/set the 'active' attribute. When true this attribute will
force C<< hub->finalize() >> to take action even if there is no plan, and no
tests have been run. This flag is useful for plugins that add follow-up
behaviors that need to run even if no events are seen.
=back
=head2 STATE METHODS
=over 4
=item $hub->reset_state()
Reset all state to the start. This sets the test count to 0, clears the plan,
removes the failures, etc.
=item $num = $hub->count
Get the number of tests that have been run.
=item $num = $hub->failed
Get the number of failures (Not all failures come from a test fail, so this
number can be larger than the count).
=item $bool = $hub->ended
True if the testing has ended. This MAY return the stack frame of the tool that
ended the test, but that is not guaranteed.
=item $bool = $hub->is_passing
=item $hub->is_passing($bool)
Check if the overall test run is a failure. Can also be used to set the
pass/fail status.
=item $hub->plan($plan)
=item $plan = $hub->plan
Get or set the plan. The plan must be an integer larger than 0, the string
'NO PLAN', or the string 'SKIP'.
=item $bool = $hub->check_plan
Check if the plan and counts match, but only if the tests have ended. If tests
have not ended this will return undef, otherwise it will be a true/false.
=back
=head1 THIRD PARTY META-DATA
This object consumes L<Test2::Util::ExternalMeta> which provides a consistent
way for you to attach meta-data to instances of this class. This is useful for
tools, plugins, and other extensions.
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

144
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Hub/Interceptor.pm Normal file
View file

@ -0,0 +1,144 @@
package Test2::Hub::Interceptor;
use strict;
use warnings;
our $VERSION = '1.302199';
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});
}
if (my $ls = $from->{+_LISTENERS}) {
push @{$self->{+_LISTENERS}} => grep { $_->{intercept_inherit} } @$ls;
}
if (my $pfs = $from->{+_PRE_FILTERS}) {
push @{$self->{+_PRE_FILTERS}} => grep { $_->{intercept_inherit} } @$pfs;
}
if (my $fs = $from->{+_FILTERS}) {
push @{$self->{+_FILTERS}} => grep { $_->{intercept_inherit} } @$fs;
}
}
sub clean_inherited {
my $self = shift;
my %params = @_;
my @sets = (
$self->{+_LISTENERS},
$self->{+_PRE_FILTERS},
$self->{+_FILTERS},
);
for my $set (@sets) {
next unless $set;
for my $i (@$set) {
my $cbs = $i->{intercept_inherit} or next;
next unless ref($cbs) eq 'HASH';
my $cb = $cbs->{clean} or next;
$cb->(%params);
}
}
}
sub restore_inherited {
my $self = shift;
my %params = @_;
my @sets = (
$self->{+_FILTERS},
$self->{+_PRE_FILTERS},
$self->{+_LISTENERS},
);
for my $set (@sets) {
next unless $set;
for my $i (@$set) {
my $cbs = $i->{intercept_inherit} or next;
next unless ref($cbs) eq 'HASH';
my $cb = $cbs->{restore} or next;
$cb->(%params);
}
}
}
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

51
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Hub/Interceptor/Terminator.pm Normal file
View file

@ -0,0 +1,51 @@
package Test2::Hub::Interceptor::Terminator;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

136
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Hub/Subtest.pm Normal file
View file

@ -0,0 +1,136 @@
package Test2::Hub::Subtest;
use strict;
use warnings;
our $VERSION = '1.302199';
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
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

160
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/IPC.pm Normal file
View file

@ -0,0 +1,160 @@
package Test2::IPC;
use strict;
use warnings;
our $VERSION = '1.302199';
use Test2::API::Instance;
use Test2::Util qw/get_tid/;
use Test2::API qw{
test2_in_preload
test2_init_done
test2_ipc
test2_has_ipc
test2_ipc_enable_polling
test2_pid
test2_stack
test2_tid
context
};
# Make sure stuff is finalized before anyone tried to fork or start a new thread.
{
# Avoid warnings if things are loaded at run-time
no warnings 'void';
INIT {
use warnings 'void';
context()->release() unless test2_in_preload();
}
}
use Carp qw/confess/;
our @EXPORT_OK = qw/cull/;
BEGIN { require Exporter; our @ISA = qw(Exporter) }
sub unimport { Test2::API::test2_ipc_disable() }
sub import {
goto &Exporter::import if test2_has_ipc || !test2_init_done();
confess "IPC is disabled" if Test2::API::test2_ipc_disabled();
confess "Cannot add IPC in a child process (" . test2_pid() . " vs $$)" if test2_pid() != $$;
confess "Cannot add IPC in a child thread (" . test2_tid() . " vs " . get_tid() . ")" if test2_tid() != get_tid();
Test2::API::_set_ipc(_make_ipc());
apply_ipc(test2_stack());
goto &Exporter::import;
}
sub _make_ipc {
# Find a driver
my ($driver) = Test2::API::test2_ipc_drivers();
unless ($driver) {
require Test2::IPC::Driver::Files;
$driver = 'Test2::IPC::Driver::Files';
}
return $driver->new();
}
sub apply_ipc {
my $stack = shift;
my ($root) = @$stack;
return unless $root;
confess "Cannot add IPC in a child process" if $root->pid != $$;
confess "Cannot add IPC in a child thread" if $root->tid != get_tid();
my $ipc = $root->ipc || test2_ipc() || _make_ipc();
# Add the IPC to all hubs
for my $hub (@$stack) {
my $has = $hub->ipc;
confess "IPC Mismatch!" if $has && $has != $ipc;
next if $has;
$hub->set_ipc($ipc);
$ipc->add_hub($hub->hid);
}
test2_ipc_enable_polling();
return $ipc;
}
sub cull {
my $ctx = context();
$ctx->hub->cull;
$ctx->release;
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::IPC - Turn on IPC for threading or forking support.
=head1 SYNOPSIS
You should C<use Test2::IPC;> as early as possible in your test file. If you
import this module after API initialization it will attempt to retrofit IPC
onto the existing hubs.
=head2 DISABLING IT
You can use C<no Test2::IPC;> to disable IPC for good. You can also use the
T2_NO_IPC env var.
=head1 EXPORTS
All exports are optional.
=over 4
=item cull()
Cull allows you to collect results from other processes or threads on demand.
=back
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

287
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/IPC/Driver.pm Normal file
View file

@ -0,0 +1,287 @@
package Test2::IPC::Driver;
use strict;
use warnings;
our $VERSION = '1.302199';
use Carp qw/confess/;
use Test2::Util::HashBase qw{no_fatal no_bail};
use Test2::API qw/test2_ipc_add_driver/;
my %ADDED;
sub import {
my $class = shift;
return if $class eq __PACKAGE__;
return if $ADDED{$class}++;
test2_ipc_add_driver($class);
}
sub pending { -1 }
sub set_pending { -1 }
for my $meth (qw/send cull add_hub drop_hub waiting is_viable/) {
no strict 'refs';
*$meth = sub {
my $thing = shift;
confess "'$thing' did not define the required method '$meth'."
};
}
# Print the error and call exit. We are not using 'die' cause this is a
# catastrophic error that should never be caught. If we get here it
# means some serious shit has happened in a child process, the only way
# to inform the parent may be to exit false.
sub abort {
my $self = shift;
chomp(my ($msg) = @_);
$self->driver_abort($msg) if $self->can('driver_abort');
print STDERR "IPC Fatal Error: $msg\n";
print STDOUT "Bail out! IPC Fatal Error: $msg\n" unless $self->no_bail;
CORE::exit(255) unless $self->no_fatal;
}
sub abort_trace {
my $self = shift;
my ($msg) = @_;
# Older versions of Carp do not export longmess() function, so it needs to be called with package name
$self->abort(Carp::longmess($msg));
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::IPC::Driver - Base class for Test2 IPC drivers.
=head1 SYNOPSIS
package Test2::IPC::Driver::MyDriver;
use base 'Test2::IPC::Driver';
...
=head1 METHODS
=over 4
=item $self->abort($msg)
If an IPC encounters a fatal error it should use this. This will print the
message to STDERR with C<'IPC Fatal Error: '> prefixed to it, then it will
forcefully exit 255. IPC errors may occur in threads or processes other than
the main one, this method provides the best chance of the harness noticing the
error.
=item $self->abort_trace($msg)
This is the same as C<< $ipc->abort($msg) >> except that it uses
C<Carp::longmess> to add a stack trace to the message.
=back
=head1 LOADING DRIVERS
Test2::IPC::Driver has an C<import()> method. All drivers inherit this import
method. This import method registers the driver.
In most cases you just need to load the desired IPC driver to make it work. You
should load this driver as early as possible. A warning will be issued if you
load it too late for it to be effective.
use Test2::IPC::Driver::MyDriver;
...
=head1 WRITING DRIVERS
package Test2::IPC::Driver::MyDriver;
use strict;
use warnings;
use base 'Test2::IPC::Driver';
sub is_viable {
return 0 if $^O eq 'win32'; # Will not work on windows.
return 1;
}
sub add_hub {
my $self = shift;
my ($hid) = @_;
... # Make it possible to contact the hub
}
sub drop_hub {
my $self = shift;
my ($hid) = @_;
... # Nothing should try to reach the hub anymore.
}
sub send {
my $self = shift;
my ($hid, $e, $global) = @_;
... # Send the event to the proper hub.
# This may notify other procs/threads that there is a pending event.
Test2::API::test2_ipc_set_pending($uniq_val);
}
sub cull {
my $self = shift;
my ($hid) = @_;
my @events = ...; # Here is where you get the events for the hub
return @events;
}
sub waiting {
my $self = shift;
... # Notify all listening procs and threads that the main
... # process/thread is waiting for them to finish.
}
1;
=head2 METHODS SUBCLASSES MUST IMPLEMENT
=over 4
=item $ipc->is_viable
This should return true if the driver works in the current environment. This
should return false if it does not. This is a CLASS method.
=item $ipc->add_hub($hid)
This is used to alert the driver that a new hub is expecting events. The driver
should keep track of the process and thread ids, the hub should only be dropped
by the proc+thread that started it.
sub add_hub {
my $self = shift;
my ($hid) = @_;
... # Make it possible to contact the hub
}
=item $ipc->drop_hub($hid)
This is used to alert the driver that a hub is no longer accepting events. The
driver should keep track of the process and thread ids, the hub should only be
dropped by the proc+thread that started it (This is the drivers responsibility
to enforce).
sub drop_hub {
my $self = shift;
my ($hid) = @_;
... # Nothing should try to reach the hub anymore.
}
=item $ipc->send($hid, $event);
=item $ipc->send($hid, $event, $global);
Used to send events from the current process/thread to the specified hub in its
process+thread.
sub send {
my $self = shift;
my ($hid, $e) = @_;
... # Send the event to the proper hub.
# This may notify other procs/threads that there is a pending event.
Test2::API::test2_ipc_set_pending($uniq_val);
}
If C<$global> is true then the driver should send the event to all hubs in all
processes and threads.
=item @events = $ipc->cull($hid)
Used to collect events that have been sent to the specified hub.
sub cull {
my $self = shift;
my ($hid) = @_;
my @events = ...; # Here is where you get the events for the hub
return @events;
}
=item $ipc->waiting()
This is called in the parent process when it is complete and waiting for all
child processes and threads to complete.
sub waiting {
my $self = shift;
... # Notify all listening procs and threads that the main
... # process/thread is waiting for them to finish.
}
=back
=head2 METHODS SUBCLASSES MAY IMPLEMENT OR OVERRIDE
=over 4
=item $ipc->driver_abort($msg)
This is a hook called by C<< Test2::IPC::Driver->abort() >>. This is your
chance to cleanup when an abort happens. You cannot prevent the abort, but you
can gracefully except it.
=back
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

503
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/IPC/Driver/Files.pm Normal file
View file

@ -0,0 +1,503 @@
package Test2::IPC::Driver::Files;
use strict;
use warnings;
our $VERSION = '1.302199';
BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) }
use Test2::Util::HashBase qw{tempdir event_ids read_ids timeouts tid pid globals};
use Scalar::Util qw/blessed/;
use File::Temp();
use Storable();
use File::Spec();
use POSIX();
use Test2::Util qw/try get_tid pkg_to_file IS_WIN32 ipc_separator do_rename do_unlink try_sig_mask/;
use Test2::API qw/test2_ipc_set_pending/;
sub is_viable { 1 }
sub init {
my $self = shift;
my $tmpdir = File::Temp::tempdir(
$ENV{T2_TEMPDIR_TEMPLATE} || "test2" . ipc_separator . $$ . ipc_separator . "XXXXXX",
CLEANUP => 0,
TMPDIR => 1,
);
$self->abort_trace("Could not get a temp dir") unless $tmpdir;
$self->{+TEMPDIR} = File::Spec->canonpath($tmpdir);
print STDERR "\nIPC Temp Dir: $tmpdir\n\n"
if $ENV{T2_KEEP_TEMPDIR};
$self->{+EVENT_IDS} = {};
$self->{+READ_IDS} = {};
$self->{+TIMEOUTS} = {};
$self->{+TID} = get_tid();
$self->{+PID} = $$;
$self->{+GLOBALS} = {};
return $self;
}
sub hub_file {
my $self = shift;
my ($hid) = @_;
my $tdir = $self->{+TEMPDIR};
return File::Spec->catfile($tdir, "HUB" . ipc_separator . $hid);
}
sub event_file {
my $self = shift;
my ($hid, $e) = @_;
my $tempdir = $self->{+TEMPDIR};
my $type = blessed($e) or $self->abort("'$e' is not a blessed object!");
$self->abort("'$e' is not an event object!")
unless $type->isa('Test2::Event');
my $tid = get_tid();
my $eid = $self->{+EVENT_IDS}->{$hid}->{$$}->{$tid} += 1;
my @type = split '::', $type;
my $name = join(ipc_separator, $hid, $$, $tid, $eid, @type);
return File::Spec->catfile($tempdir, $name);
}
sub add_hub {
my $self = shift;
my ($hid) = @_;
my $hfile = $self->hub_file($hid);
$self->abort_trace("File for hub '$hid' already exists")
if -e $hfile;
open(my $fh, '>', $hfile) or $self->abort_trace("Could not create hub file '$hid': $!");
print $fh "$$\n" . get_tid() . "\n";
close($fh);
}
sub drop_hub {
my $self = shift;
my ($hid) = @_;
my $tdir = $self->{+TEMPDIR};
my $hfile = $self->hub_file($hid);
$self->abort_trace("File for hub '$hid' does not exist")
unless -e $hfile;
open(my $fh, '<', $hfile) or $self->abort_trace("Could not open hub file '$hid': $!");
my ($pid, $tid) = <$fh>;
close($fh);
$self->abort_trace("A hub file can only be closed by the process that started it\nExpected $pid, got $$")
unless $pid == $$;
$self->abort_trace("A hub file can only be closed by the thread that started it\nExpected $tid, got " . get_tid())
unless get_tid() == $tid;
if ($ENV{T2_KEEP_TEMPDIR}) {
my ($ok, $err) = do_rename($hfile, File::Spec->canonpath("$hfile.complete"));
$self->abort_trace("Could not rename file '$hfile' -> '$hfile.complete': $err") unless $ok
}
else {
my ($ok, $err) = do_unlink($hfile);
$self->abort_trace("Could not remove file for hub '$hid': $err") unless $ok
}
opendir(my $dh, $tdir) or $self->abort_trace("Could not open temp dir!");
my %bad;
for my $file (readdir($dh)) {
next if $file =~ m{\.complete$};
next unless $file =~ m{^$hid};
eval { $bad{$file} = $self->read_event_file(File::Spec->catfile($tdir, $file)); 1 } or $bad{$file} = $@ || "Unknown error reading file";
}
closedir($dh);
return unless keys %bad;
my $data;
my $ok = eval {
require JSON::PP;
local *UNIVERSAL::TO_JSON = sub { +{ %{$_[0]} } };
my $json = JSON::PP->new->ascii->pretty->canonical->allow_unknown->allow_blessed->convert_blessed;
$data = $json->encode(\%bad);
1;
};
$ok ||= eval {
require Data::Dumper;
local $Data::Dumper::Sortkeys = 1;
$data = Data::Dumper::Dumper(\%bad);
1;
};
$data = "Could not dump data... sorry." unless defined $data;
$self->abort_trace("Not all files from hub '$hid' have been collected!\nHere is the leftover data:\n========================\n$data\n===================\n");
}
sub send {
my $self = shift;
my ($hid, $e, $global) = @_;
my $tempdir = $self->{+TEMPDIR};
my $hfile = $self->hub_file($hid);
my $dest = $global ? 'GLOBAL' : $hid;
$self->abort(<<" EOT") unless $global || -f $hfile;
hub '$hid' is not available, failed to send event!
There was an attempt to send an event to a hub in a parent process or thread,
but that hub appears to be gone. This can happen if you fork, or start a new
thread from inside subtest, and the parent finishes the subtest before the
child returns.
This can also happen if the parent process is done testing before the child
finishes. Test2 normally waits automatically in the root process, but will not
do so if Test::Builder is loaded for legacy reasons.
EOT
my $file = $self->event_file($dest, $e);
my $ready = File::Spec->canonpath("$file.ready");
if ($global) {
my $name = $ready;
$name =~ s{^.*(GLOBAL)}{GLOBAL};
$self->{+GLOBALS}->{$hid}->{$name}++;
}
# Write and rename the file.
my ($ren_ok, $ren_err);
my ($ok, $err) = try_sig_mask(sub {
Storable::store($e, $file);
($ren_ok, $ren_err) = do_rename("$file", $ready);
});
if ($ok) {
$self->abort("Could not rename file '$file' -> '$ready': $ren_err") unless $ren_ok;
test2_ipc_set_pending($file);
}
else {
my $src_file = __FILE__;
$err =~ s{ at \Q$src_file\E.*$}{};
chomp($err);
my $tid = get_tid();
my $trace = $e->trace->debug;
my $type = blessed($e);
$self->abort(<<" EOT");
*******************************************************************************
There was an error writing an event:
Destination: $dest
Origin PID: $$
Origin TID: $tid
Event Type: $type
Event Trace: $trace
File Name: $file
Ready Name: $ready
Error: $err
*******************************************************************************
EOT
}
return 1;
}
sub driver_abort {
my $self = shift;
my ($msg) = @_;
local ($@, $!, $?, $^E);
eval {
my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
open(my $fh, '>>', $abort) or die "Could not open abort file: $!";
print $fh $msg, "\n";
close($fh) or die "Could not close abort file: $!";
1;
} or warn $@;
}
sub cull {
my $self = shift;
my ($hid) = @_;
my $tempdir = $self->{+TEMPDIR};
opendir(my $dh, $tempdir) or $self->abort("could not open IPC temp dir ($tempdir)!");
my $read = $self->{+READ_IDS};
my $timeouts = $self->{+TIMEOUTS};
my @out;
for my $info (sort cmp_events map { $self->should_read_event($hid, $_) } readdir($dh)) {
unless ($info->{global}) {
my $next = $self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} ||= 1;
$timeouts->{$info->{file}} ||= time;
if ($next != $info->{eid}) {
# Wait up to N seconds for missing events
next unless 5 < time - $timeouts->{$info->{file}};
$self->abort("Missing event HID: $info->{hid}, PID: $info->{pid}, TID: $info->{tid}, EID: $info->{eid}.");
}
$self->{+READ_IDS}->{$info->{hid}}->{$info->{pid}}->{$info->{tid}} = $info->{eid} + 1;
}
my $full = $info->{full_path};
my $obj = $self->read_event_file($full);
push @out => $obj;
# Do not remove global events
next if $info->{global};
if ($ENV{T2_KEEP_TEMPDIR}) {
my $complete = File::Spec->canonpath("$full.complete");
my ($ok, $err) = do_rename($full, $complete);
$self->abort("Could not rename IPC file '$full', '$complete': $err") unless $ok;
}
else {
my ($ok, $err) = do_unlink("$full");
$self->abort("Could not unlink IPC file '$full': $err") unless $ok;
}
}
closedir($dh);
return @out;
}
sub parse_event_filename {
my $self = shift;
my ($file) = @_;
# The || is to force 0 in false
my $complete = substr($file, -9, 9) eq '.complete' || 0 and substr($file, -9, 9, "");
my $ready = substr($file, -6, 6) eq '.ready' || 0 and substr($file, -6, 6, "");
my @parts = split ipc_separator, $file;
my ($global, $hid) = $parts[0] eq 'GLOBAL' ? (1, shift @parts) : (0, join ipc_separator, splice(@parts, 0, 4));
my ($pid, $tid, $eid) = splice(@parts, 0, 3);
my $type = join '::' => @parts;
return {
file => $file,
ready => !!$ready,
complete => !!$complete,
global => $global,
type => $type,
hid => $hid,
pid => $pid,
tid => $tid,
eid => $eid,
};
}
sub should_read_event {
my $self = shift;
my ($hid, $file) = @_;
return if substr($file, 0, 1) eq '.';
return if substr($file, 0, 3) eq 'HUB';
CORE::exit(255) if $file eq 'ABORT';
my $parsed = $self->parse_event_filename($file);
return if $parsed->{complete};
return unless $parsed->{ready};
return unless $parsed->{global} || $parsed->{hid} eq $hid;
return if $parsed->{global} && $self->{+GLOBALS}->{$hid}->{$file}++;
# Untaint the path.
my $full = File::Spec->catfile($self->{+TEMPDIR}, $file);
($full) = ($full =~ m/^(.*)$/gs) if ${^TAINT};
$parsed->{full_path} = $full;
return $parsed;
}
sub cmp_events {
# Globals first
return -1 if $a->{global} && !$b->{global};
return 1 if $b->{global} && !$a->{global};
return $a->{pid} <=> $b->{pid}
|| $a->{tid} <=> $b->{tid}
|| $a->{eid} <=> $b->{eid};
}
sub read_event_file {
my $self = shift;
my ($file) = @_;
my $obj = Storable::retrieve($file);
$self->abort("Got an unblessed object: '$obj'")
unless blessed($obj);
unless ($obj->isa('Test2::Event')) {
my $pkg = blessed($obj);
my $mod_file = pkg_to_file($pkg);
my ($ok, $err) = try { require $mod_file };
$self->abort("Event has unknown type ($pkg), tried to load '$mod_file' but failed: $err")
unless $ok;
$self->abort("'$obj' is not a 'Test2::Event' object")
unless $obj->isa('Test2::Event');
}
return $obj;
}
sub waiting {
my $self = shift;
require Test2::Event::Waiting;
$self->send(
GLOBAL => Test2::Event::Waiting->new(
trace => Test2::EventFacet::Trace->new(frame => [caller()]),
),
'GLOBAL'
);
return;
}
sub DESTROY {
my $self = shift;
return unless defined $self->pid;
return unless defined $self->tid;
return unless $$ == $self->pid;
return unless get_tid() == $self->tid;
my $tempdir = $self->{+TEMPDIR};
my $aborted = 0;
my $abort_file = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
if (-e $abort_file) {
$aborted = 1;
my ($ok, $err) = do_unlink($abort_file);
warn $err unless $ok;
}
opendir(my $dh, $tempdir) or $self->abort("Could not open temp dir! ($tempdir)");
while(my $file = readdir($dh)) {
next if $file =~ m/^\.+$/;
next if $file =~ m/\.complete$/;
my $full = File::Spec->catfile($tempdir, $file);
my $sep = ipc_separator;
if ($aborted || $file =~ m/^(GLOBAL|HUB$sep)/) {
$full =~ m/^(.*)$/;
$full = $1; # Untaint it
next if $ENV{T2_KEEP_TEMPDIR};
my ($ok, $err) = do_unlink($full);
$self->abort("Could not unlink IPC file '$full': $err") unless $ok;
next;
}
$self->abort("Leftover files in the directory ($full)!\n");
}
closedir($dh);
if ($ENV{T2_KEEP_TEMPDIR}) {
print STDERR "# Not removing temp dir: $tempdir\n";
return;
}
my $abort = File::Spec->catfile($self->{+TEMPDIR}, "ABORT");
unlink($abort) if -e $abort;
rmdir($tempdir) or warn "Could not remove IPC temp dir ($tempdir)";
}
1;
__END__
=pod
=encoding UTF-8
=head1 NAME
Test2::IPC::Driver::Files - Temp dir + Files concurrency model.
=head1 DESCRIPTION
This is the default, and fallback concurrency model for L<Test2>. This
sends events between processes and threads using serialized files in a
temporary directory. This is not particularly fast, but it works everywhere.
=head1 SYNOPSIS
use Test2::IPC::Driver::Files;
# IPC is now enabled
=head1 ENVIRONMENT VARIABLES
=over 4
=item T2_KEEP_TEMPDIR=0
When true, the tempdir used by the IPC driver will not be deleted when the test
is done.
=item T2_TEMPDIR_TEMPLATE='test2-XXXXXX'
This can be used to set the template for the IPC temp dir. The template should
follow template specifications from L<File::Temp>.
=back
=head1 SEE ALSO
See L<Test2::IPC::Driver> for methods.
=head1 SOURCE
The source code repository for Test2 can be found at
L<https://github.com/Test-More/test-more/>.
=head1 MAINTAINERS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 AUTHORS
=over 4
=item Chad Granum E<lt>exodist@cpan.orgE<gt>
=back
=head1 COPYRIGHT
Copyright 2020 Chad Granum E<lt>exodist@cpan.orgE<gt>.
This program is free software; you can redistribute it and/or
modify it under the same terms as Perl itself.
See L<https://dev.perl.org/licenses/>
=cut

80
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual.pm Normal file
View file

@ -0,0 +1,80 @@
package Test2::Manual;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual - Documentation hub for Test2 and Test2-Suite.
=head1 DESCRIPTION
This is the hub for L<Test2> and L<Test2::Suite> documentation.
=head1 WRITING TESTS
The L<Test2::Manual::Testing> POD is the hub for documentation related to
writing tests.
=head1 WRITING TOOLS
The L<Test2::Manual::Tooling> POD is the hub for documentation related to
writing new tools.
=head1 GUTS AND INNER WORKINGS
The L<Test2::Manual::Anatomy> POD is the hub for documentation of the inner
workings of Test2 components.
=head1 A NOTE ON CONCURRENCY (SUPPORT FOR FORKING AND THREADING)
The L<Test2::Manual::Concurrency> POD documents the concurrency support policy
for L<Test2>.
=head1 CONTRIBUTING
The L<Test2::Manual::Contributing> POD is for people who want to contribute to
L<Test2> or L<Test2::Suite> directly.
=head1 SEE ALSO
L<Test2> - Test2 itself.
L<Test2::Suite> - Initial tools built using L<Test2>.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

88
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Anatomy.pm Normal file
View file

@ -0,0 +1,88 @@
package Test2::Manual::Anatomy;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::Anatomy - The hub for documentation of the inner workings of
Test2 components.
=head1 DESCRIPTION
This section covers internals of the Test2 architecture. This is useful
information for toolbuilder, but is essential information for maintainers of
Test2 itself.
=head1 END TO END
The L<Test2::Manual::Anatomy::EndToEnd> document is an overview of Test2 from load to finish.
=head1 EVENTS
The L<Test2::Manual::Anatomy::Event> document explains the internals of events.
=head1 THE CONTEXT
The L<Test2::Manual::Anatomy::Context> document explains how the
L<Test2::API::Context> object works.
=head1 THE API AND THE API INSTANCE
The L<Test2::Manual::Anatomy::API> document explains the inner workings of the
Test2 API.
=head1 HUBS
The L<Test2::Manual::Anatomy::Hubs> document explains the inner working of
the Test2 hub stack, and the hubs therein.
=head1 THE IPC SYSTEM
The L<Test2::Manual::Anatomy::IPC> document describes the IPC system.
=head1 INTERNAL UTILITIES
The L<Test2::Manual::Anatomy::Utilities> document describes various utilities
provided by the Test2 system.
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

78
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Anatomy/API.pm Normal file
View file

@ -0,0 +1,78 @@
package Test2::Manual::Anatomy::API;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::Anatomy::API - Internals documentation for the API.
=head1 DESCRIPTION
This document covers some of the internals of L<Test2::API>.
=head1 IMPLEMENTATION DETAILS
=head2 Test2::API
L<Test2::API> provides a functional interface to any test2 global state. This
API should be preserved regardless of internal details of how and where the
global state is stored.
This module itself does not store any state (with a few minor exceptions) but
instead relies on L<Test2::API::Instance> to store state. This module is really
intended to be the layer between the consumer and the implementation details.
Ideally the implementation details can change any way they like, and this
module can be updated to use the new details without breaking anything.
=head2 Test2::API::Instance
L<Test2::API::Instance> is where the global state is actually managed. This is
an implementation detail, and should not be relied upon. It is entirely
possible that L<Test2::API::Instance> could be removed completely, or changed
in incompatible ways. Really these details are free to change so long as
L<Test2::API> is not broken.
L<Test2::API::Instance> is fairly well documented, so no additionally
documentation is needed for this manual page.
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

114
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Anatomy/Context.pm Normal file
View file

@ -0,0 +1,114 @@
package Test2::Manual::Anatomy::Context;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::Anatomy::Context - Internals documentation for the Context
objects.
=head1 DESCRIPTION
This document explains how the L<Test2::API::Context> object works.
=head1 WHAT IS THE CONTEXT OBJECT?
The context object is one of the key components of Test2, and makes many
features possible that would otherwise be impossible. Every test tool starts by
getting a context, and ends by releasing the context. A test tool does all its
work between getting and releasing the context. The context instance is the
primary interface for sending events to the Test2 stack. Finally the context
system is responsible for tracking what file and line number a tool operates
on, which is critical for debugging.
=head2 PRIMARY INTERFACE FOR TEST TOOLS
Nearly every Test2 based tool should start by calling C<$ctx =
Test2::API::context()> in order to get a context object, and should end by
calling C<< $ctx->release() >>. Once a tool has its context object it can call
methods on the object to send events or have other effects. Nearly everything a
test tool needs to do should be done through the context object.
=head2 TRACK FILE AND LINE NUMBERS FOR ERROR REPORTING
When you call C<Test2::API::Context> a new context object will be returned. If
there is already a context object in effect (from a different point in the
stack) you will get a clone of the existing one. If there is not already a
current context then a completely new one will be generated. When a new context
is generated Test2 will determine the file name and line number for your test
code, these will be used when reporting any failures.
Typically the file and line number will be determined using C<caller()> to look
at your tools caller. The C<$Test::Builder::Level> will be respected if
detected, but is discouraged in favor of just using context objects at every
level.
When calling C<Test2::API::Context()> you can specify the
C<< level => $count >> arguments if you need to look at a deeper caller.
=head2 PRESERVE $?, $!, $^E AND $@
When you call C<Test2::API::context()> the current values of C<$?>, C<$!>,
C<$^E>, and C<$@> are stored in the context object itself. Whenever the context
is released the original values of these variables will be restored. This
protects the variables from any side effects caused by testing tools.
=head2 FINALIZE THE API STATE
L<Test2::API> works via a hidden singleton instance of L<Test2::API::Instance>.
The singleton has some state that is not set in stone until the last possible
minute. The last possible minute happens to be the first time a context is
acquired. State includes IPC instance, Formatter class, Root PID, etc.
=head2 FIND/CREATE THE CURRENT/ROOT HUB
L<Test2> has a stack of hubs, the stack can be accessed via
L<Test2::API::test2_stack>. When you get a context it will find the current
hub, if there is no current hub then the root one will be initialized.
=head2 PROVIDE HOOKS
There are hooks that run when contexts are created, found, and released. See
L<Test2::API> for details on these hooks and how to use them.
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

376
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Anatomy/EndToEnd.pm Normal file
View file

@ -0,0 +1,376 @@
package Test2::Manual::Anatomy::EndToEnd;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::EndToEnd - Overview of Test2 from load to finish.
=head1 DESCRIPTION
This is a high level overview of everything from loading Test2 through the end
of a test script.
=head1 WHAT HAPPENS WHEN I LOAD THE API?
use Test2::API qw/context/;
=over 4
=item A singleton instance of Test2::API::Instance is created.
You have no access to this, it is an implementation detail.
=item Several API functions are defined that use the singleton instance.
You can import these functions, or use them directly.
=item Then what?
It waits...
The API intentionally does as little as possible. At this point something can
still change the formatter, load L<Test2::IPC>, or have other global effects
that need to be done before the first L<Test2::API::Context> is created. Once
the first L<Test2::API::Context> is created the API will finish initialization.
See L</"WHAT HAPPENS WHEN I ACQUIRE A CONTEXT?"> for more information.
=back
=head1 WHAT HAPPENS WHEN I USE A TOOL?
This section covers the basic workflow all tools such as C<ok()> must follow.
sub ok($$) {
my ($bool, $name) = @_;
my $ctx = context();
my $event = $ctx->send_event('Ok', pass => $bool, name => $name);
...
$ctx->release;
return $bool;
}
ok(1, "1 is true");
=over 4
=item A tool function is run.
ok(1, "1 is true");
=item The tool acquires a context object.
my $ctx = context();
See L</"WHAT HAPPENS WHEN I ACQUIRE A CONTEXT?"> for more information.
=item The tool uses the context object to create, send, and return events.
See L</"WHAT HAPPENS WHEN I SEND AN EVENT?"> for more information.
my $event = $ctx->send_event('Ok', pass => $bool, name => $name);
=item When done the tool MUST release the context.
See L</"WHAT HAPPENS WHEN I RELEASE A CONTEXT?"> for more information.
$ctx->release();
=item The tool returns.
return $bool;
=back
=head1 WHAT HAPPENS WHEN I ACQUIRE A CONTEXT?
my $ctx = context();
These actions may not happen exactly in this order, but that is an
implementation detail. For the purposes of this document this order is used to
help the reader understand the flow.
=over 4
=item $!, $@, $? and $^E are captured and preserved.
Test2 makes a point to preserve the values of $!, $@, $? and $^E such that the test
tools do not modify these variables unexpectedly. They are captured first thing
so that they can be restored later.
=item The API state is changed to 'loaded'.
The 'loaded' state means that test tools have already started running. This is
important as some plugins need to take effect before any tests are run. This
state change only happens the first time a context is acquired, and may trigger
some hooks defined by plugins to run.
=item The current hub is found.
A context attaches itself to the current L<Test2::Hub>. If there is no current
hub then the root hub will be initialized. This will also initialize the hub
stack if necessary.
=item Context acquire hooks fire.
It is possible to create global, or hub-specific hooks that fire whenever a
context is acquired, these hooks will fire now. These hooks fire even if there
is an existing context.
=item Any existing context is found.
If the current hub already has a context then a clone of it will be used
instead of a completely new context. This is important because it allows nested
tools to inherit the context used by parent tools.
=item Stack depth is measured.
Test2 makes a point to catch mistakes in how the context is used. The stack
depth is used to accomplish this. If there is an existing context the depth
will be checked against the one found here. If the old context has the same
stack depth, or a shallower one, it means a tool is misbehaving and did not
clean up the context when it was done, in which case the old context will be
cleaned up, and a warning issued.
=item A new context is created (if no existing context was found)
If there is no existing context, a new one will be created using the data
collected so far.
=item Context init hooks fire (if no existing context was found)
If a new context was created, context-creation hooks will fire.
=item $!, $@, $?, and $^E are restored.
We make sure $!, $@, $?, and $^E are unchanged at this point so that changes we
made will not effect anything else. This is done in case something inside the
context construction accidentally changed these vars.
=item The context is returned.
You have a shiney new context object, or a clone of the existing context.
=back
=head1 WHAT HAPPENS WHEN I SEND AN EVENT?
my $event = $ctx->send_event('Ok', pass => $bool, name => $name);
=over 4
=item The Test2::Event::Ok module is loaded.
The C<send_event()> method will automatically load any Event package necessary.
Normally C<send_event()> will assume the first argument is an event class
without the C<Test2::Event::> prefix, which it will add for you. If you want to
use an event class that is in a different namespace you can prefix the class
name with a C<+> to tell the tool that you are giving a fully qualified class
name:
my $event = $ctx->send_event('+Fully::Qualified::Event', pass => $bool, name => $name);
=item A new instance of Test2::Event::Ok is created.
The event object is instantiated using the provided parameters.
=item The event object is sent to the hub.
The hub takes over from here.
=item The hub runs the event through any filters.
Filters are able to modify or remove events. Filters are run first, before the
event can modify global test state.
=item The global test state is updated to reflect the event.
If the event effects test count then the count will be incremented. If the
event causes failure then the failure count will be incremented. There are a
couple other ways the global state can be effected as well.
=item The event is sent to the formatter
After the state is changed the hub will send the event to the formatter for
rendering. This is where TAP is normally produced.
=item The event is sent to all listeners.
There can be any number of listeners that take action when events are
processed, this happens now.
=back
=head1 WHAT HAPPENS WHEN I RELEASE A CONTEXT?
$ctx->release;
=over 4
=item The current context clone is released.
If your tool is nested inside another, then releasing will simply destroy the
copy of the context, nothing else will happen.
=item If this was the canonical context, it will actually release
When a context is created it is considered 'canon'. Any context obtained by a
nested tool will be considered a child context linked to the canonical one.
Releasing child contexts does not do anything of note (but is still required).
=item Release hooks are called
Release hooks are the main motivation behind making the C<release()> method,
and making it a required action on the part of test tools. These are hooks that
we can have called when a tool is complete. This is how plugins like
L<Test2::Plugin::DieOnFail> are implemented. If we simply had a destructor call
the hooks then we would be unable to write this plugin as a C<die> inside of a
destructor is useless.
=item The context is cleared
The main context data is cleared allowing the next tool to create a new
context. This is important as the next tool very likely has a new line number.
=item $!, $@, $?, and $^E are restored
When a Test2 tool is complete it will restore $@, $!, $? and $^E to avoid action at
a distance.
=back
=head1 WHAT HAPPENS WHEN I USE done_testing()?
done_testing();
=over 4
=item Any pending IPC events will be culled.
If IPC is turned on, a final culling will take place.
=item Follow-up hooks are run
The follow-up hooks are a way to run actions when a hub is complete. This is
useful for adding cleanup tasks, or final tests to the end of a test.
=item The final plan event is generated and processed.
The final plan event will be produced using the current test count as the
number of tests planned.
=item The current hub is finalized.
This will mark the hub is complete, and will not allow new events to be
processed.
=back
=head1 WHAT HAPPENS WHEN A TEST SCRIPT IS DONE?
Test2 has some behaviors it runs in an C<END { ... }> block after tests are
done running. This end block does some final checks to warn you if something
went wrong. This end block also sets the exit value of the script.
=over 4
=item API Versions are checked.
A warning will be produced if L<Test::Builder> is loaded, but has a different
version compared to L<Test2::API>. This situation can happen if you downgrade
to an older Test-Simple distribution, and is a bad situation.
=item Any remaining context objects are cleaned up.
If there are leftover context objects they will need to be cleaned up. A
leftover context is never a good thing, and usually requires a warning. A
leftover context could also be the result of an exception being thrown which
terminates the script, L<Test2> is fairly good at noticing this and not warning
in these cases as the warning would simply be noise.
=item Child processes are sent a 'waiting' event.
If IPC is active, a waiting event is sent to all child processes.
=item The script will wait for all child processes and/or threads to complete.
This happens only when IPC is loaded, but Test::Builder is not. This behavior
is useful, but would break compatibility for legacy tests.
=item The hub stack is cleaned up.
All hubs are finalized starting from the top. Leftover hubs are usually a bad
thing, so a warning is produced if any are found.
=item The root hub is finalized.
This step is a no-op if C<done_testing()> was used. If needed this will mark
the root hub as finished.
=item Exit callbacks are called.
This is a chance for plugins to modify the final exit value of the script.
=item The scripts exit value ($?) is set.
If the test encountered any failures this will be set to a non-zero value. If
possible this will be set to the number of failures, or 255 if the number is
larger than 255 (the max value allowed).
=item Broken module diagnostics
Test2 is aware of many modules which were broken by Test2's release. At this
point the script will check if any known-broken modules were loaded, and warn
you if they were.
B<Note:> This only happens if there were test failures. No broken module
warnings are produced on a success.
=back
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

410
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Anatomy/Event.pm Normal file
View file

@ -0,0 +1,410 @@
package Test2::Manual::Anatomy::Event;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::Anatomy::Event - The internals of events
=head1 DESCRIPTION
Events are how tools effect global state, and pass information along to the
harness, or the human running the tests.
=head1 HISTORY
Before proceeding it is important that you know some history of events.
Initially there was an event API, and an event would implement the API to
produce an effect. This API proved to be lossy and inflexible. Recently the
'facet' system was introduced, and makes up for the shortcoming and
inflexibility of the old API.
All events must still implement the old API, but that can be largely automated
if you use the facet system effectively. Likewise essential facets can often be
deduced from events that only implement the old API, though their information
maybe less complete.
=head1 THE EVENT OBJECT
All event objects must subclass L<Test2::Event>. If you inherit from this base
class, and implement the old API properly, facets will be generated for you for
free. On the other hand you can inherit from this, and also import
L<Test2::Util::Facets2Legacy> which will instead rely on your facet data, and
deduce the old API from them.
All new events C<MUST> implement both APIs one way or the other. A common way
to do this is to simply implement both APIs directly in your event.
Here is a good template for a new event:
package Test2::Event::Mine;
use strict;
use warnings;
use parent 'Test2::Event';
use Test2::Util::Facets2Legacy ':ALL';
sub facet_data {
my $self = shift;
# Adds 'about', 'amnesty', and 'trace' facets
my $out = $self->common_facet_data;
# Add any additional facets to the $out hashref
...
return $out;
}
1;
=head1 THE FACET API
The new API is a single method: C<facet_data()>. This method must return a
hashref where each key is specific to a facet type, and the value is either a
facet hashref, or an array of hashrefs. Some facets C<MUST> be lone hashrefs,
others C<MUST> be hashrefs inside an arrayref.
The I<standard> facet types are as follows:
=over 4
=item assert => {details => $name, pass => $bool, no_debug => $bool, number => $maybe_int}
Documented in L<Test2::EventFacet::Assert>. An event may only have one.
The 'details' key is the name of the assertion.
The 'pass' key denotes a passing or failing assertion.
The 'no_debug' key tells any harness or formatter that diagnostics should not
be added automatically to a failing assertion (used when there are custom
diagnostics instead).
The 'number' key is for harness use, never set it yourself.
=item about => {details => $string, no_display => $bool, package => $pkg}
Documented in L<Test2::EventFacet::About>. An event may only have one.
'details' is a human readable string describing the overall event.
'no_display' means that a formatter/harness should hide the event.
'package' is the package of the event the facet describes (IE: L<Test2::Event::Ok>)
=item amnesty => [{details => $string, tag => $short_string, inherited => $bool}]
Documented in L<Test2::EventFacet::Amnesty>. An event may have multiple.
This event is how things like 'todo' are implemented. Amnesty prevents a
failing assertion from causing a global test failure.
'details' is a human readable description of why the failure is being granted
amnesty (IE The 'todo' reason)
'tag' is a short human readable string, or category for the amnesty. This is
typically 'TODO' or 'SKIP'.
'inherited' is true if the amnesty was applied in a parent context (true if
this test is run in a subtest that is marked todo).
=item control => {details => $string, global => $bool, terminate => $maybe_int, halt => $bool, has_callback => $bool, encoding => $enc}
Documented in L<Test2::EventFacet::Control>. An event may have one.
This facet is used to apply extra behavior when the event is processed.
'details' is a human readable explanation for the behavior.
'global' true if this event should be forwarded to, and processed by, all hubs
everywhere. (bail-out uses this)
'terminate' this should either be undef, or an integer. When defined this will
cause the test to exit with the specific exit code.
'halt' is used to signal any harness that no further test files should be run
(bail-out uses this).
'has_callback' is set to true if the event has a callback sub defined.
'encoding' used to tell the formatter what encoding to use.
=item errors => [{details => $string, tag => $short_string, fail => $bool}]
Documented in L<Test2::EventFacet::Error>. An event may have multiple.
'details' is a human readable explanation of the error.
'tag' is a short human readable category for the error.
'fail' is true if the error should cause test failure. If this is false the
error is simply informative, but not fatal.
=item info => [{details => $string, tag => $short_string, debug => $bool, important => $bool}]
Documented in L<Test2::EventFacet::Info>. An event may have multiple.
This is how diag and note are implemented.
'details' human readable message.
'tag' short category for the message, such as 'diag' or 'note'.
'debug' is true if the message is diagnostics in nature, this is the main
difference between a note and a diag.
'important' is true if the message is not diagnostics, but is important to have
it shown anyway. This is primarily used to communicate with a harness.
=item parent => {details => $string, hid => $hid, children => [...], buffered => 1}
Documented in L<Test2::EventFacet::Parent>. An event may have one.
This is used by subtests.
'details' human readable name of the subtest.
'hid' subtest hub id.
'children' an arrayref containing facet_data instances from all child events.
'buffered' true if it was a buffered subtest.
=item plan => {details => $string, count => $int, skip => $bool, none => $bool}
Documented in L<Test2::EventFacet::Plan>. An event may have one.
'details' is a human readable string describing the plan (for instance, why a
test is skipped)
'count' is the number of expected assertions (0 for skip)
'skip' is true if the plan is to skip the test.
'none' used for Test::More's 'no_plan' plan.
=item trace => {details => $string, frame => [$pkg, $file, $line, $sub], pid => $int, tid => $int, cid => $cid, hid => $hid, nested => $int, buffered => $bool}
Documented in L<Test2::EventFacet::Trace>. An event may have one.
This is how debugging information is tracked. This is taken from the context
object at event creation.
'details' human readable debug message (otherwise generated from frame)
'frame' first 4 fields returned by caller:
C<[$package, $file, $line, $subname]>.
'pid' the process id in which the event was created.
'tid' the thread is in which the event was created.
'cid' the id of the context used to create the event.
'hid' the id of the hub to which the event was sent.
'nest' subtest nesting depth of the event.
'buffered' is true if the event was generated inside a buffered subtest.
=back
Note that ALL facet types have a 'details' key that may have a string. This
string should always be human readable, and should be an explanation for the
facet. For an assertion this is the test name. For a plan this is the reason
for the plan (such as skip reason). For info it is the human readable
diagnostics message.
=head2 CUSTOM FACETS
You can write custom facet types as well, simply add a new key to the hash and
populated it. The general rule is that any code looking at the facets should
ignore any it does not understand.
Optionally you can also create a package to document your custom facet. The
package should be proper object, and may have additional methods to help work
with your facet.
package Test2::EventFacet::MyFacet;
use parent 'Test2::EventFacet';
sub facet_key { 'myfacet' }
sub is_list { 0 }
1;
Your facet package should always be under the Test2::EventFacet:: namespace if
you want any tools to automatically find it. The last part of the namespace
should be the non-plural name of your facet with only the first word
capitalized.
=over 4
=item $string = $facet_class->facet_key
The key for your facet should be the same as the last section of
the namespace, but all lowercase. You I<may> append 's' to the key if your
facet is a list type.
=item $bool = $facet_class->is_list
True if an event should put these facets in a list:
{ myfacet => [{}, {}] }
False if an event may only have one of this type of facet at a time:
{ myfacet => {} }
=back
=head3 EXAMPLES
The assert facet is not a list type, so its implementation would look like this:
package Test2::EventFacet::Assert;
sub facet_key { 'assert' }
sub is_list { 0 }
The amnesty facet is a list type, but amnesty does not need 's' appended to
make it plural:
package Test2::EventFacet::Amnesty;
sub facet_key { 'amnesty' }
sub is_list { 1 }
The error facet is a list type, and appending 's' makes error plural as errors.
This means the package name is '::Error', but the key is 'errors'.
package Test2::EventFacet::Error;
sub facet_key { 'errors' }
sub is_list { 1 }
B<Note2:> In practice most tools completely ignore the facet packages, and work
with the facet data directly in its raw structure. This is by design and
recommended. The facet data is intended to be serialized frequently and passed
around. When facets are concerned, data is important, classes and methods are
not.
=head1 THE OLD API
The old API was simply a set of methods you were required to implement:
=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.
=back
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

120
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Anatomy/Hubs.pm Normal file
View file

@ -0,0 +1,120 @@
package Test2::Manual::Anatomy::Hubs;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::Anatomy::Hubs - Internals documentation for the hub stack, and
hubs.
=head1 DESCRIPTION
This document describes the hub stack, and the hubs it contains. It explains
why we have a stack, and when to add/remove hubs from it.
=head1 WHAT IS A HUB?
Test2 is an event system, tools generate events, those events are then
processed to modify the testing state (number of tests, number of failures,
etc). The hub is responsible for receiving and processing events to record the
change in state. All events should eventually reach a destination hub.
The base hub is L<Test2::Hub>. All hub classes should inherit from the base hub
class. The base hub class provides several hooks that allow you to monitor or
modify events. Hubs are also responsible for forwarding events to the output
formatter.
=head1 WHY DO WE HAVE A HUB STACK?
There are cases where it makes sense to have more than one hub:
=over 4
=item subtests
In Test2 subtests are implemented using the hub stack. When you start a subtest
a new L<Test2::Hub::Subtest> instance is created and pushed to the stack. Once
this is done all calls to C<Test2::API::context> will find the new hub and send
all events to it. When the subtest tool is complete it will remove the new hub,
and send a final subtest event to the parent hub.
=item testing your test tools
C<Test2::API::intercept()> is implemented using the hub stack. The
C<Test2::API::intercept()> function will add an L<Test2::Hub::Interceptor>
instance to the stack, any calls to L<Test2::API::context()> will find the new
hub, and send it all events. The intercept hub is special in that is has no
connection to the parent hub, and usually does not have a formatter.
=back
=head1 WHEN SHOULD I ADD A HUB TO THE STACK?
Any time you want to intercept or block events from effecting the test state.
Adding a new hub is essentially a way to create a sandbox where you have
absolute control over what events do. Adding a new hub insures that the main
test state will not be effected.
=head1 WHERE IS THE STACK?
The stack is an instance of L<Test2::API::Stack>. You can access the global hub
stack using C<Test2::API::test2_stack>.
=head1 WHAT ABOUT THE ROOT HUB?
The root hub is created automatically as needed. A call to
C<< Test2::API::test2_stack->top() >> will create the root hub if it does not
already exist.
=head1 HOW DO HUBS HANDLE IPC?
If the IPC system (L<Test2::IPC>) was not loaded, then IPC is not handled at
all. Forking or creating new threads without the IPC system can cause
unexpected problems.
All hubs track the PID and Thread ID that was current when they were created.
If an event is sent to a hub in a new process/thread the hub will detect this
and try to forward the event along to the correct process/thread. This is
accomplished using the IPC system.
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

90
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Anatomy/IPC.pm Normal file
View file

@ -0,0 +1,90 @@
package Test2::Manual::Anatomy::IPC;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::Anatomy::IPC - Manual for the IPC system.
=head1 DESCRIPTION
This document describes the IPC system.
=head1 WHAT IS THE IPC SYSTEM
The IPC system is activated by loading L<Test2::IPC>. This makes hubs
process/thread aware, and makes them forward events along to the parent
process/thread as necessary.
=head1 HOW DOES THE IPC SYSTEM EFFECT EVERYTHING?
L<Test2::API> and L<Test2::API::Instance> have some behaviors that trigger if
L<Test2::IPC> is loaded before the global state is initialized. Mainly an IPC
driver will be initiated and stored in the global state.
If an IPC driver is initialized then all hubs will be initialized with a
reference to the driver instance. If a hub has an IPC driver instance it will
use it to forward events to parent processes and threads.
=head1 WHAT DOES AN IPC DRIVER DO?
An L<Test2::IPC::Driver> provides a way to send event data to a destination
process+thread+hub (or to all globally). The driver must also provide a way for
a process/thread/hub to read in any pending events that have been sent to it.
=head1 HOW DOES THE DEFAULT IPC DRIVER WORK?
The default IPC driver is L<Test2::API::Driver::Files>. This default driver,
when initialized, starts by creating a temporary directory. Any time an event
needs to be sent to another process/thread/hub, the event will be written to a
file using L<Storable>. The file is written with the destination process,
thread, and hub as part of the filename. All hubs will regularly check for
pending IPC events and will process them.
This driver is further optimized using a small chunk of SHM. Any time a new
event is sent via IPC the shm is updated to have a new value. Hubs will not
bother checking for new IPC events unless the shm value has changed since their
last poll. A result of this is that the IPC system is surprisingly fast, and
does not waste time polling the hard drive when there are no pending events.
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

76
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Anatomy/Utilities.pm Normal file
View file

@ -0,0 +1,76 @@
package Test2::Manual::Anatomy::Utilities;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::Anatomy::Utilities - Overview of utilities for Test2.
=head1 DESCRIPTION
This is a brief overview of the utilities provided by Test2.
=head1 Test2::Util
L<Test2::Util> provides functions to help you find out about the current
system, or to run generic tasks that tend to be Test2 specific.
This utility provides things like an internal C<try {...}> implementation, and
constants for things like threading and forking support.
=head1 Test2::Util::ExternalMeta
L<Test2::Util::ExternalMeta> allows you to quickly and easily attach meta-data
to an object class.
=head1 Test2::Util::Facets2Legacy
L<Test2::Util::Facets2Legacy> is a set of functions you can import into a more
recent event class to provide the classic event API.
=head1 Test2::Util::HashBase
L<Test2::Util::HashBase> is a local copy of L<Object::HashBase>. All object
classes provided by L<Test2> use this to generate methods and accessors.
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

143
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Concurrency.pm Normal file
View file

@ -0,0 +1,143 @@
package Test2::Manual::Concurrency;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::Concurrency - Documentation for Concurrency support.
=head1 FORKING
=head2 Test2
Test2 supports forking. For forking to work you need to load L<Test2::IPC>.
=head2 Test::Builder
L<Test::Builder> Did not used to support forking, but now that it is based on
L<Test2> it does. L<Test2::IPC> must be loaded just as with L<Test2>.
=head2 Test2::Suite
L<Test2::Suite> tools should all work fine with I<true> forking unless
otherwise noted. Pseudo-fork via threads (Windows and a few others) is not
supported, but may work.
Patches will be accepted to repair any pseudo-fork issues, but for these to be
used or tested they must be requested. Fork tests should not run on pseudo-fork
systems unless they are requested with an environment var, or the
AUTHOR_TESTING var. Pseudo-fork is fragile, and we do not want to block install
due to a pseudo-fork flaw.
=head2 Test::SharedFork
L<Test::SharedFork> is currently support and maintained, though it is no longer
necessary thanks to L<Test2::IPC>. If usage ever drops off then the module may
be deprecated, but for now the policy is to not let it break. Currently it
simply loads L<Test2::IPC> if it can, and falls back to the old methods on
legacy installs.
=head2 Others
Individual authors are free to support or not support forking as they see fit.
=head1 THREADING
B<Note> This only applies to ithreads.
=head2 Test2
The core of Test2 supports threading so long as L<Test2::IPC> is loaded. Basic
threading support (making sure events make it to the parent thread) is fully
supported, and must not be broken.
Some times perl installs have broken threads (Some 5.10 versions compiled on
newer gcc's will segv by simply starting a thread). This is beyond Test2's
control, and not solvable in Test2. That said we strive for basic threading
support on perl 5.8.1+.
If Test2 fails for threads on any perl 5.8 or above, and it is reasonably
possible for Test2 to work around the issue, it should. (Patches and bug
reports welcome).
=head2 Test::Builder
L<Test::Builder> has had thread support for a long time. With Test2 the
mechanism for thread support was switched to L<Test2::IPC>. L<Test::Builder>
should still support threads as much as it did before the switch to Test2.
Support includes auto-enabling thread support if L<threads> is loaded before
Test::Builder.
If there is a deviation between the new and old threading behavior then it is a
bug (unless the old behavior itself can be classified as a bug.) Please report
(or patch!) any such threading issues.
=head2 Test2::Suite
Tools in L<Test2::Suite> have minimal threading support. Most of these tools do
not care/notice threading and simply work because L<Test2::IPC> handles it.
Feel free to report any thread related bugs in Test2::Suite. Be aware though
that these tools are not legacy, and have no pre-existing thread support, we
reserve the right to refuse adding thread support to them.
=head3 Test2::Workflow
L<Test2::Workflow> has been merged into L<Test2::Suite>, so it gets addressed
by this policy.
L<Test2::Workflow> has thread support, but you must ask for it. Thread tests
for Test2::Workflow do not event run without setting either the AUTHOR_TESTING
env var, or the T2_DO_THREAD_TESTS env var.
To use threads with Test2::Workflow you must set the T2_WORKFLOW_USE_THREADS
env var.
If you do rely on threads with Test2::Workflow and find a bug please report it,
but it will be given an ultra-low priority. Merging patches that fix threading
issues will be given normal priority.
=head1 SEE ALSO
L<Test2> - Test2 itself.
L<Test2::Suite> - Initial tools built using L<Test2>.
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

115
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Contributing.pm Normal file
View file

@ -0,0 +1,115 @@
package Test2::Manual::Contributing;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::Contributing - How to contribute to the Test2 project.
=head1 DESCRIPTION
This is a short manual page dedicated to helping people who wish to contribute
to the Test2 project.
=head1 WAYS TO HELP
=head2 REPORT BUGS
The easiest way to help is to report bugs when you find them. Bugs are a fact
of life when writing or using software. If you use Test2 long enough you are
likely to find a bug. When you find such a bug it would help us out if you
would submit a ticket.
=head3 BUG TRACKERS
Always try to find the preferred bug tracker for the module that has the bug.
Here are the big 3 for the main Test2 project:
=over 4
=item Test2/Test-Builder/Test-More
L<https://github.com/Test-More/test-more/issues>
=item Test2-Suite
L<https://github.com/Test-More/Test2-Suite/issues>
=item Test2-Harness
L<https://github.com/Test-More/Test2-Harness/issues>
=back
=head2 SUBMIT PATCHES
You are welcome to fix bugs you find, or from the tracker. We also often accept
patches that add new features or update documentation. The preferred method of
submitting patches is a github pull request, that said we also accept patches
via email.
=head2 ADD/UPDATE DOCUMENTATION
Documentation can be flawed just like code can be. Documentation can also
become outdated. If you see some incorrect documentation, or documentation that
is missing, we would love to get a patch to fix it!
=head2 ANSWER QUESTIONS ON IRC/SLACK
We are always hanging out on L<irc://irc.perl.org>, the #perl-qa and #toolchain
channels are a good place to find us.
There is also a Test2 slack channel: L<https://perl-test2.slack.com>.
=head2 WRITE NEW TOOLS USING TEST2
Writing a new tool using Test2 is always a good way to contribute. When you
write a tool that you think is useful, it is nice to share it by putting it on
CPAN.
=head2 PORT OLD TOOLS TO TEST2
The C<Test::*> namespace has been around for a long time, and has a LOT of
tools. The C<Test2::Tools::*> namespace is fairly young, and has less tools.
Finding a useful old tool with no modern equivalent, and writing a port is a
very good use of your time.
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

245
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Testing.pm Normal file
View file

@ -0,0 +1,245 @@
package Test2::Manual::Testing;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::Testing - Hub for documentation about writing tests with Test2.
=head1 DESCRIPTION
This document outlines all the tutorials and POD that cover writing tests. This
section does not cover any Test2 internals, nor does it cover how to write new
tools, for that see L<Test2::Manual::Tooling>.
=head1 NAMESPACE MAP
When writing tests there are a couple namespaces to focus on:
=over 4
=item Test2::Tools::*
This is where toolsets can be found. A toolset exports functions that help you
make assertions about your code. Toolsets will only export functions, they
should not ever have extra/global effects.
=item Test2::Plugins::*
This is where plugins live. Plugins should not export anything, but instead
will introduce or alter behaviors for Test2 in general. These behaviors may be
lexically scoped, or they may be global.
=item Test2::Bundle::*
Bundles combine toolsets and plugins together to reduce your boilerplate. First
time test writers are encouraged to start with the L<Test2::V0> bundle (which
is an exception to the namespace rule as it does not live under
C<Test2::Bundle::>). If you find yourself loading several plugins and toolsets
over and over again you could benefit from writing your own bundle.
=item Test2::Require::*
This namespace contains modules that will cause a test to skip if specific
conditions are not met. Use this if you have tests that only run on specific
perl versions, or require external libraries that may not always be available.
=back
=head1 LISTING DEPENDENCIES
When you use L<Test2>, specifically things included in L<Test2::Suite> you need
to list them in your modules test dependencies. It is important to note that
you should list the tools/plugins/bundles you need, you should not simply list
L<Test2::Suite> as your dependency. L<Test2::Suite> is a living distribution
intended to represent the "current" best practices. As tools, plugins, and
bundles evolve, old ones will become discouraged and potentially be moved from
L<Test2::Suite> into their own distributions.
One goal of L<Test2::Suite> is to avoid breaking backwards compatibility.
Another goal is to always improve by replacing bad designs with better ones.
When necessary L<Test2::Suite> will break old modules out into separate dists
and define new ones, typically with a new bundle. In short, if we feel the need
to break something we will do so by creating a new bundle, and discouraging the
old one, but we will not break the old one.
So for example, if you use L<Test2::V0>, and L<Dist::Zilla> you
should have this in your config:
[Prereqs / TestRequires]
Test2::V0 = 0.000060
You B<SHOULD NOT> do this:
[Prereqs / TestRequires]
Test2::Suite = 0.000060
Because L<Test2::V0> might not always be part of L<Test2::Suite>.
When writing new tests you should often check L<Test2::Suite> to see what the
current recommended bundle is.
=head3 Dist::Zilla
[Prereqs / TestRequires]
Test2::V0 = 0.000060
=head3 ExtUtils::MakeMaker
my %WriteMakefileArgs = (
...,
"TEST_REQUIRES" => {
"Test2::V0" => "0.000060"
},
...
);
=head3 Module::Install
test_requires 'Test2::V0' => '0.000060';
=head3 Module::Build
my $build = Module::Build->new(
...,
test_requires => {
"Test2::V0" => "0.000060",
},
...
);
=head1 TUTORIALS
=head2 SIMPLE/INTRODUCTION TUTORIAL
L<Test2::Manual::Testing::Introduction> is an introduction to writing tests
using the L<Test2> tools.
=head2 MIGRATING FROM TEST::BUILDER and TEST::MORE
L<Test2::Manual::Testing::Migrating> Is a tutorial for converting old tests
that use L<Test::Builder> or L<Test::More> to the newer L<Test2> way of doing
things.
=head2 ADVANCED PLANNING
L<Test2::Manual::Testing::Planning> is a tutorial on the many ways to set a
plan.
=head2 TODO TESTS
L<Test2::Manual::Testing::Todo> is a tutorial for markings tests as TODO.
=head2 SUBTESTS
COMING SOON.
=head2 COMPARISONS
COMING SOON.
=head3 SIMPLE COMPARISONS
COMING SOON.
=head3 ADVANCED COMPARISONS
COMING SOON.
=head2 TESTING EXPORTERS
COMING SOON.
=head2 TESTING CLASSES
COMING SOON.
=head2 TRAPPING
COMING SOON.
=head3 TRAPPING EXCEPTIONS
COMING SOON.
=head3 TRAPPING WARNINGS
COMING SOON.
=head2 DEFERRED TESTING
COMING SOON.
=head2 MANAGING ENCODINGS
COMING SOON.
=head2 AUTO-ABORT ON FAILURE
COMING SOON.
=head2 CONTROLLING RANDOM BEHAVIOR
COMING SOON.
=head2 WRITING YOUR OWN BUNDLE
COMING SOON.
=head1 TOOLSET DOCUMENTATION
COMING SOON.
=head1 PLUGIN DOCUMENTATION
COMING SOON.
=head1 BUNDLE DOCUMENTATION
COMING SOON.
=head1 REQUIRE DOCUMENTATION
COMING SOON.
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

293
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Testing/Introduction.pm Normal file
View file

@ -0,0 +1,293 @@
package Test2::Manual::Testing::Introduction;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::Testing::Introduction - Introduction to testing with Test2.
=head1 DESCRIPTION
This tutorial is a beginners introduction to testing. This will take you
through writing a test file, making assertions, and running your test.
=head1 BOILERPLATE
=head2 THE TEST FILE
Test files typically are placed inside the C<t/> directory, and end with the
C<.t> file extension.
C<t/example.t>:
use Test2::V0;
# Assertions will go here
done_testing;
This is all the boilerplate you need.
=over 4
=item use Test2::V0;
This loads a collection of testing tools that will be described later in the
tutorial. This will also turn on C<strict> and C<warnings> for you.
=item done_testing;
This should always be at the end of your test files. This tells L<Test2> that
you are done making assertions. This is important as C<test2> will assume the
test did not complete successfully without this, or some other form of test
"plan".
=back
=head2 DIST CONFIG
You should always list bundles and tools directly. You should not simply list
L<Test2::Suite> and call it done, bundles and tools may be moved out of
L<Test2::Suite> to their own dists at any time.
=head3 Dist::Zilla
[Prereqs / TestRequires]
Test2::V0 = 0.000060
=head3 ExtUtils::MakeMaker
my %WriteMakefileArgs = (
...,
"TEST_REQUIRES" => {
"Test2::V0" => "0.000060"
},
...
);
=head3 Module::Install
test_requires 'Test2::V0' => '0.000060';
=head3 Module::Build
my $build = Module::Build->new(
...,
test_requires => {
"Test2::V0" => "0.000060",
},
...
);
=head1 MAKING ASSERTIONS
The most simple tool for making assertions is C<ok()>. C<ok()> lets you assert
that a condition is true.
ok($CONDITION, "Description of the condition");
Here is a complete C<t/example.t>:
use Test2::V0;
ok(1, "1 is true, so this will pass");
done_testing;
=head1 RUNNING THE TEST
Test files are simply scripts. Just like any other script you can run the test
directly with perl. Another option is to use a test "harness" which runs the
test for you, and provides extra information and checks the scripts exit value
for you.
=head2 RUN DIRECTLY
$ perl -Ilib t/example.t
Which should produce output like this:
# Seeded srand with seed '20161028' from local date.
ok 1 - 1 is true, so this will pass
1..1
If the test had failed (C<ok(0, ...)>) it would look like this:
# Seeded srand with seed '20161028' from local date.
not ok 1 - 0 is false, so this will fail
1..1
Test2 will also set the exit value of the script, a successful run will have an
exit value of 0, a failed run will have a non-zero exit value.
=head2 USING YATH
The C<yath> command line tool is provided by L<Test2::Harness> which you may
need to install yourself from cpan. C<yath> is the harness written specifically
for L<Test2>.
$ yath -Ilib t/example.t
This will produce output similar to this:
( PASSED ) job 1 t/example.t
================================================================================
Run ID: 1508027909
All tests were successful!
You can also request verbose output with the C<-v> flag:
$ yath -Ilib -v t/example.t
Which produces:
( LAUNCH ) job 1 example.t
( NOTE ) job 1 Seeded srand with seed '20171014' from local date.
[ PASS ] job 1 + 1 is true, so this will pass
[ PLAN ] job 1 Expected asserions: 1
( PASSED ) job 1 example.t
================================================================================
Run ID: 1508028002
All tests were successful!
=head2 USING PROVE
The C<prove> command line tool is provided by the L<Test::Harness> module which
comes with most versions of perl. L<Test::Harness> is dual-life, which means
you can also install the latest version from cpan.
$ prove -Ilib t/example.t
This will produce output like this:
example.t .. ok
All tests successful.
Files=1, Tests=1, 0 wallclock secs ( 0.01 usr 0.00 sys + 0.05 cusr 0.00 csys = 0.06 CPU)
Result: PASS
You can also request verbose output with the C<-v> flag:
$ prove -Ilib -v t/example.t
The verbose output looks like this:
example.t ..
# Seeded srand with seed '20161028' from local date.
ok 1 - 1 is true, so this will pass
1..1
ok
All tests successful.
Files=1, Tests=1, 0 wallclock secs ( 0.02 usr 0.00 sys + 0.06 cusr 0.00 csys = 0.08 CPU)
Result: PASS
=head1 THE "PLAN"
All tests need a "plan". The job of a plan is to make sure you ran all the
tests you expected. The plan prevents a passing result from a test that exits
before all the tests are run.
There are 2 primary ways to set the plan:
=over 4
=item done_testing()
The most common, and recommended way to set a plan is to add C<done_testing> at
the end of your test file. This will automatically calculate the plan for you
at the end of the test. If the test were to exit early then C<done_testing>
would not run and no plan would be found, forcing a failure.
=item plan($COUNT)
The C<plan()> function allows you to specify an exact number of assertions you
want to run. If you run too many or too few assertions then the plan will not
match and it will be counted as a failure. The primary problem with this way of
planning is that you need to add up the number of assertions, and adjust the
count whenever you update the test file.
C<plan()> must be used before all assertions, or after all assertions, it
cannot be done in the middle of making assertions.
=back
=head1 ADDITIONAL ASSERTION TOOLS
The L<Test2::V0> bundle provides a lot more than C<ok()>,
C<plan()>, and C<done_testing()>. The biggest tools to note are:
=over 4
=item is($a, $b, $description)
C<is()> allows you to compare 2 structures and insure they are identical. You
can use it for simple string comparisons, or even deep data structure
comparisons.
is("foo", "foo", "Both strings are identical");
is(["foo", 1], ["foo", 1], "Both arrays contain the same elements");
=item like($a, $b, $description)
C<like()> is similar to C<is()> except that it only checks items listed on the
right, it ignores any extra values found on the left.
like([1, 2, 3, 4], [1, 2, 3], "Passes, the extra element on the left is ignored");
You can also used regular expressions on the right hand side:
like("foo bar baz", qr/bar/, "The string matches the regex, this passes");
You can also nest the regexes:
like([1, 2, 'foo bar baz', 3], [1, 2, qr/bar/], "This passes");
=back
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

431
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Testing/Migrating.pm Normal file
View file

@ -0,0 +1,431 @@
package Test2::Manual::Testing::Migrating;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
=head1 NAME
Test2::Manual::Testing::Migrating - How to migrate existing tests from
Test::More to Test2.
=head1 DESCRIPTION
This tutorial covers the conversion of an existing test. This tutorial assumes
you have a test written using L<Test::More>.
=head1 LEGACY TEST
This tutorial will be converting this example test one section at a time:
C<t/example.t>:
#####################
# Boilerplate
use strict;
use warnings;
use Test::More tests => 14;
use_ok 'Scalar::Util';
require_ok 'Exporter';
#####################
# Simple assertions (no changes)
ok(1, "pass");
is("apple", "apple", "Simple string compare");
like("foo bar baz", qr/bar/, "Regex match");
#####################
# Todo
{
local $TODO = "These are todo";
ok(0, "oops");
}
#####################
# Deep comparisons
is_deeply([1, 2, 3], [1, 2, 3], "Deep comparison");
#####################
# Comparing references
my $ref = [1];
is($ref, $ref, "Check that we have the same ref both times");
#####################
# Things that are gone
ok(eq_array([1], [1]), "array comparison");
ok(eq_hash({a => 1}, {a => 1}), "hash comparison");
ok(eq_set([1, 3, 2], [1, 2, 3]), "set comparison");
note explain([1, 2, 3]);
{
package THING;
sub new { bless({}, shift) }
}
my $thing = new_ok('THING');
#####################
# Tools that changed
isa_ok($thing, 'THING', '$thing');
can_ok(__PACKAGE__, qw/ok is/);
=head1 BOILERPLATE
BEFORE:
use strict;
use warnings;
use Test::More tests => 14;
use_ok 'Scalar::Util';
require_ok 'Exporter';
AFTER:
use Test2::V0;
plan(11);
use Scalar::Util;
require Exporter;
=over 4
=item Replace Test::More with Test2::V0
L<Test2::V0> is the recommended bundle. In a full migration you
will want to replace L<Test::More> with the L<Test2::V0> bundle.
B<Note:> You should always double check the latest L<Test2> to see if there is
a new recommended bundle. When writing a new test you should always use the
newest Test::V# module. Higher numbers are newer version.
=item NOTE: srand
When srand is on (default) it can cause problems with things like L<File::Temp>
which will end up attempting the same "random" filenames for every test process
started on a given day (or sharing the same seed).
If this is a problem for you then please disable srand when loading
L<Test2::V0>:
use Test2::V0 -no_srand => 1;
=item Stop using use_ok()
C<use_ok()> has been removed. a C<use MODULE> statement will throw an exception
on failure anyway preventing the test from passing.
If you I<REALLY> want/need to assert that the file loaded you can use the L<ok>
module:
use ok 'Scalar::Util';
The main difference here is that there is a space instead of an underscore.
=item Stop using require_ok()
C<require_ok> has been removed just like C<use_ok>. There is no L<ok> module
equivalent here. Just use C<require>.
=item Remove strict/warnings (optional)
The L<Test2::V0> bundle turns strict and warnings on for you.
=item Change where the plan is set
Test2 does not allow you to set the plan at import. In the old code you would
pass C<< tests => 11 >> as an import argument. In L<Test2> you either need to
use the C<plan()> function to set the plan, or use C<done_testing()> at the end
of the test.
If your test already uses C<done_testing()> you can keep that and no plan
changes are necessary.
B<Note:> We are also changing the plan from 14 to 11, that is because we
dropped C<use_ok>, C<require_ok>, and we will be dropping one more later on.
This is why C<done_testing()> is recommended over a set plan.
=back
=head1 SIMPLE ASSERTIONS
The vast majority of assertions will not need any changes:
#####################
# Simple assertions (no changes)
ok(1, "pass");
is("apple", "apple", "Simple string compare");
like("foo bar baz", qr/bar/, "Regex match");
=head1 TODO
{
local $TODO = "These are todo";
ok(0, "oops");
}
The C<$TODO> package variable is gone. You now have a C<todo()> function.
There are 2 ways this can be used:
=over 4
=item todo $reason => sub { ... }
todo "These are todo" => sub {
ok(0, "oops");
};
This is the cleanest way to do a todo. This will make all assertions inside the
codeblock into TODO assertions.
=item { my $TODO = todo $reason; ... }
{
my $TODO = todo "These are todo";
ok(0, "oops");
}
This is a system that emulates the old way. Instead of modifying a global
C<$TODO> variable you create a todo object with the C<todo()> function and
assign it to a lexical variable. Once the todo object falls out of scope the
TODO ends.
=back
=head1 DEEP COMPARISONS
is_deeply([1, 2, 3], [1, 2, 3], "Deep comparison");
Deep comparisons are easy, simply replace C<is_deeply()> with C<is()>.
is([1, 2, 3], [1, 2, 3], "Deep comparison");
=head1 COMPARING REFERENCES
my $ref = [1];
is($ref, $ref, "Check that we have the same ref both times");
The C<is()> function provided by L<Test::More> forces both arguments into
strings, which makes this a comparison of the reference addresses. L<Test2>'s
C<is()> function is a deep comparison, so this will still pass, but fails to
actually test what we want (that both references are the same exact ref, not
just identical structures.)
We now have the C<ref_is()> function that does what we really want, it ensures
both references are the same reference. This function does the job better than
the original, which could be thrown off by string overloading.
my $ref = [1];
ref_is($ref, $ref, "Check that we have the same ref both times");
=head1 TOOLS THAT ARE GONE
ok(eq_array([1], [1]), "array comparison");
ok(eq_hash({a => 1}, {a => 1}), "hash comparison");
ok(eq_set([1, 3, 2], [1, 2, 3]), "set comparison");
note explain([1, 2, 3]);
{
package THING;
sub new { bless({}, shift) }
}
my $thing = new_ok('THING');
C<eq_array>, C<eq_hash> and C<eq_set> have been considered deprecated for a
very long time, L<Test2> does not provide them at all. Instead you can just use
C<is()>:
is([1], [1], "array comparison");
is({a => 1}, {a => 1}, "hash comparison");
C<eq_set> is a tad more complicated, see L<Test2::Tools::Compare> for an
explanation:
is([1, 3, 2], bag { item 1; item 2; item 3; end }, "set comparison");
C<explain()> has a rocky history. There have been arguments about how it should
work. L<Test2> decided to simply not include C<explain()> to avoid the
arguments. You can instead directly use Data::Dumper:
use Data::Dumper;
note Dumper([1, 2, 3]);
C<new_ok()> is gone. The implementation was complicated, and did not add much
value:
{
package THING;
sub new { bless({}, shift) }
}
my $thing = THING->new;
ok($thing, "made a new thing");
The complete section after the conversion is:
is([1], [1], "array comparison");
is({a => 1}, {a => 1}, "hash comparison");
is([1, 3, 2], bag { item 1; item 2; item 3; end }, "set comparison");
use Data::Dumper;
note Dumper([1, 2, 3]);
{
package THING;
sub new { bless({}, shift) }
}
my $thing = THING->new;
ok($thing, "made a new thing");
=head1 TOOLS THAT HAVE CHANGED
isa_ok($thing, 'THING', '$thing');
can_ok(__PACKAGE__, qw/ok is/);
In L<Test::More> these functions are very confusing, and most people use them
wrong!
C<isa_ok()> from L<Test::More> takes a thing, a class/reftype to check, and
then uses the third argument as an alternative display name for the first
argument (NOT a test name!).
C<can_ok()> from L<Test::More> is not consistent with C<isa_ok> as all
arguments after the first are subroutine names.
L<Test2> fixes this by making both functions consistent and obvious:
isa_ok($thing, ['THING'], 'got a THING');
can_ok(__PACKAGE__, [qw/ok is/], "have expected subs");
You will note that both functions take a thing, an arrayref as the second
argument, then a test name as the third argument.
=head1 FINAL VERSION
#####################
# Boilerplate
use Test2::V0;
plan(11);
use Scalar::Util;
require Exporter;
#####################
# Simple assertions (no changes)
ok(1, "pass");
is("apple", "apple", "Simple string compare");
like("foo bar baz", qr/bar/, "Regex match");
#####################
# Todo
todo "These are todo" => sub {
ok(0, "oops");
};
#####################
# Deep comparisons
is([1, 2, 3], [1, 2, 3], "Deep comparison");
#####################
# Comparing references
my $ref = [1];
ref_is($ref, $ref, "Check that we have the same ref both times");
#####################
# Things that are gone
is([1], [1], "array comparison");
is({a => 1}, {a => 1}, "hash comparison");
is([1, 3, 2], bag { item 1; item 2; item 3; end }, "set comparison");
use Data::Dumper;
note Dumper([1, 2, 3]);
{
package THING;
sub new { bless({}, shift) }
}
my $thing = THING->new;
#####################
# Tools that changed
isa_ok($thing, ['THING'], 'got a THING');
can_ok(__PACKAGE__, [qw/ok is/], "have expected subs");
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

104
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Testing/Planning.pm Normal file
View file

@ -0,0 +1,104 @@
package Test2::Manual::Testing::Planning;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::Testing::Planning - The many ways to set a plan.
=head1 DESCRIPTION
This tutorial covers the many ways of setting a plan.
=head1 TEST COUNT
The C<plan()> function is provided by L<Test2::Tools::Basic>. This function lets
you specify an exact number of tests to run. This can be done at the start of
testing, or at the end. This cannot be done partway through testing.
use Test2::Tools::Basic;
plan(10); # 10 tests expected
...
=head1 DONE TESTING
The C<done_testing()> function is provided by L<Test2::Tools::Basic>. This
function will automatically set the plan to the number of tests that were run.
This must be used at the very end of testing.
use Test2::Tools::Basic;
...
done_testing();
=head1 SKIP ALL
The C<skip_all()> function is provided by L<Test2::Tools::Basic>. This function
will set the plan to C<0>, and exit the test immediately. You may provide a skip
reason that explains why the test should be skipped.
use Test2::Tools::Basic;
skip_all("This test will not run here") if ...;
...
=head1 CUSTOM PLAN EVENT
A plan is simply an L<Test2::Event::Plan> event that gets sent to the current
hub. You could always write your own tool to set the plan.
use Test2::API qw/context/;
sub set_plan {
my $count = @_;
my $ctx = context();
$ctx->send_event('Plan', max => $count);
$ctx->release;
return $count;
}
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

112
Agent-Windows/OGP64/usr/share/perl5/5.40/Test2/Manual/Testing/Todo.pm Normal file
View file

@ -0,0 +1,112 @@
package Test2::Manual::Testing::Todo;
use strict;
use warnings;
our $VERSION = '0.000162';
1;
__END__
=head1 NAME
Test2::Manual::Testing::Todo - Tutorial for marking tests as TODO.
=head1 DESCRIPTION
This tutorial covers the process of marking tests as TODO. It also describes
how TODO works under the hood.
=head1 THE TOOL
use Test2::Tools::Basic qw/todo/;
=head2 TODO BLOCK
This form is low-magic. All tests inside the block are marked as todo, tests
outside the block are not todo. You do not need to do any variable management.
The flaw with this form is that it adds a couple levels to the stack, which can
break some high-magic tests.
Overall this is the preferred form unless you have a special case that requires
the variable form.
todo "Reason for the todo" => sub {
ok(0, "fail but todo");
...
};
=head2 TODO VARIABLE
This form maintains the todo scope for the life of the variable. This is useful
for tests that are sensitive to scope changes. This closely emulates the
L<Test::More> style which localized the C<$TODO> package variable. Once the
variable is destroyed (set it to undef, scope end, etc) the TODO state ends.
my $todo = todo "Reason for the todo";
ok(0, "fail but todo");
...
$todo = undef;
=head1 MANUAL TODO EVENTS
use Test2::API qw/context/;
sub todo_ok {
my ($bool, $name, $todo) = @_;
my $ctx = context();
$ctx->send_event('Ok', pass => $bool, effective_pass => 1, todo => $todo);
$ctx->release;
return $bool;
}
The L<Test2::Event::Ok> event has a C<todo> field which should have the todo
reason. The event also has the C<pass> and C<effective_pass> fields. The
C<pass> field is the actual pass/fail value. The C<effective_pass> is used to
determine if the event is an actual failure (should always be set tot true with
todo).
=head1 HOW THE TODO TOOLS WORK UNDER THE HOOD
The L<Test2::Todo> library gets the current L<Test2::Hub> instance and adds a
filter. The filter that is added will set the todo and effective pass fields on
any L<Test2::Event::Ok> events that pass through the hub. The filter also
converts L<Test2::Event::Diag> events into L<Test2::Event::Note> events.
=head1 SEE ALSO
L<Test2::Manual> - Primary index of the manual.
=head1 SOURCE
The source code repository for Test2-Manual can be found at
F<https://github.com/Test-More/Test2-Suite/>.
=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

Some files were not shown because too many files have changed in this diff Show more