Initial Commit
This commit is contained in:
Riley Schneider
814
database/perl/vendor/lib/Test2/AsyncSubtest.pm
vendored
Normal file
814
database/perl/vendor/lib/Test2/AsyncSubtest.pm
vendored
Normal file
@@ -0,0 +1,814 @@
|
||||
package Test2::AsyncSubtest;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test2::IPC;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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 Scope::Guard();
|
||||
use Test2::API();
|
||||
use Test2::API::Context();
|
||||
use Test2::Util::Trace();
|
||||
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
|
||||
};
|
||||
|
||||
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->{+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];
|
||||
|
||||
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;
|
||||
|
||||
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},
|
||||
$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 Scope::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<Scope::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
database/perl/vendor/lib/Test2/AsyncSubtest/Event/Attach.pm
vendored
Normal file
90
database/perl/vendor/lib/Test2/AsyncSubtest/Event/Attach.pm
vendored
Normal file
@@ -0,0 +1,90 @@
|
||||
package Test2::AsyncSubtest::Event::Attach;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/AsyncSubtest/Event/Detach.pm
vendored
Normal file
90
database/perl/vendor/lib/Test2/AsyncSubtest/Event/Detach.pm
vendored
Normal file
@@ -0,0 +1,90 @@
|
||||
package Test2::AsyncSubtest::Event::Detach;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/AsyncSubtest/Formatter.pm
vendored
Normal file
9
database/perl/vendor/lib/Test2/AsyncSubtest/Formatter.pm
vendored
Normal file
@@ -0,0 +1,9 @@
|
||||
package Test2::AsyncSubtest::Formatter;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
die "Should not load this anymore";
|
||||
|
||||
1;
|
||||
98
database/perl/vendor/lib/Test2/AsyncSubtest/Hub.pm
vendored
Normal file
98
database/perl/vendor/lib/Test2/AsyncSubtest/Hub.pm
vendored
Normal file
@@ -0,0 +1,98 @@
|
||||
package Test2::AsyncSubtest::Hub;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use base 'Test2::Hub::Subtest';
|
||||
use Test2::Util::HashBase qw/ast_ids ast/;
|
||||
|
||||
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;
|
||||
}
|
||||
}
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Bundle.pm
vendored
Normal file
87
database/perl/vendor/lib/Test2/Bundle.pm
vendored
Normal file
@@ -0,0 +1,87 @@
|
||||
package Test2::Bundle;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
|
||||
481
database/perl/vendor/lib/Test2/Bundle/Extended.pm
vendored
Normal file
481
database/perl/vendor/lib/Test2/Bundle/Extended.pm
vendored
Normal file
@@ -0,0 +1,481 @@
|
||||
package Test2::Bundle::Extended;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test2::V0;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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 = DNE()
|
||||
|
||||
=item $check = FDNE()
|
||||
|
||||
=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
database/perl/vendor/lib/Test2/Bundle/More.pm
vendored
Normal file
241
database/perl/vendor/lib/Test2/Bundle/More.pm
vendored
Normal file
@@ -0,0 +1,241 @@
|
||||
package Test2::Bundle::More;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Bundle/Simple.pm
vendored
Normal file
120
database/perl/vendor/lib/Test2/Bundle/Simple.pm
vendored
Normal file
@@ -0,0 +1,120 @@
|
||||
package Test2::Bundle::Simple;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare.pm
vendored
Normal file
449
database/perl/vendor/lib/Test2/Compare.pm
vendored
Normal file
@@ -0,0 +1,449 @@
|
||||
package Test2::Compare;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
|
||||
328
database/perl/vendor/lib/Test2/Compare/Array.pm
vendored
Normal file
328
database/perl/vendor/lib/Test2/Compare/Array.pm
vendored
Normal file
@@ -0,0 +1,328 @@
|
||||
package Test2::Compare::Array;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Compare::Base';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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) {
|
||||
$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
database/perl/vendor/lib/Test2/Compare/Bag.pm
vendored
Normal file
244
database/perl/vendor/lib/Test2/Compare/Bag.pm
vendored
Normal file
@@ -0,0 +1,244 @@
|
||||
package Test2::Compare::Bag;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Compare::Base';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Base.pm
vendored
Normal file
252
database/perl/vendor/lib/Test2/Compare/Base.pm
vendored
Normal file
@@ -0,0 +1,252 @@
|
||||
package Test2::Compare::Base;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Carp qw/confess croak/;
|
||||
use Scalar::Util qw/blessed/;
|
||||
|
||||
use Sub::Info 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
database/perl/vendor/lib/Test2/Compare/Bool.pm
vendored
Normal file
111
database/perl/vendor/lib/Test2/Compare/Bool.pm
vendored
Normal 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.000139';
|
||||
|
||||
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
|
||||
173
database/perl/vendor/lib/Test2/Compare/Custom.pm
vendored
Normal file
173
database/perl/vendor/lib/Test2/Compare/Custom.pm
vendored
Normal file
@@ -0,0 +1,173 @@
|
||||
package Test2::Compare::Custom;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Compare::Base';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::Util::HashBase qw/code name operator/;
|
||||
|
||||
use Carp qw/croak/;
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
croak "'code' is required" unless $self->{+CODE};
|
||||
|
||||
$self->{+OPERATOR} ||= 'CODE(...)';
|
||||
$self->{+NAME} ||= '<Custom Code>';
|
||||
|
||||
$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(...)',
|
||||
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 $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>
|
||||
|
||||
=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
database/perl/vendor/lib/Test2/Compare/DeepRef.pm
vendored
Normal file
119
database/perl/vendor/lib/Test2/Compare/DeepRef.pm
vendored
Normal file
@@ -0,0 +1,119 @@
|
||||
package Test2::Compare::DeepRef;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Compare::Base';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Delta.pm
vendored
Normal file
558
database/perl/vendor/lib/Test2/Compare/Delta.pm
vendored
Normal file
@@ -0,0 +1,558 @@
|
||||
package Test2::Compare::Delta;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Event.pm
vendored
Normal file
81
database/perl/vendor/lib/Test2/Compare/Event.pm
vendored
Normal 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.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/EventMeta.pm
vendored
Normal file
100
database/perl/vendor/lib/Test2/Compare/EventMeta.pm
vendored
Normal file
@@ -0,0 +1,100 @@
|
||||
package Test2::Compare::EventMeta;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Compare::Meta';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Float.pm
vendored
Normal file
177
database/perl/vendor/lib/Test2/Compare/Float.pm
vendored
Normal 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.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Hash.pm
vendored
Normal file
238
database/perl/vendor/lib/Test2/Compare/Hash.pm
vendored
Normal file
@@ -0,0 +1,238 @@
|
||||
package Test2::Compare::Hash;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Compare::Base';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Isa.pm
vendored
Normal file
100
database/perl/vendor/lib/Test2/Compare/Isa.pm
vendored
Normal 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.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Meta.pm
vendored
Normal file
183
database/perl/vendor/lib/Test2/Compare/Meta.pm
vendored
Normal 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.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Negatable.pm
vendored
Normal file
121
database/perl/vendor/lib/Test2/Compare/Negatable.pm
vendored
Normal file
@@ -0,0 +1,121 @@
|
||||
package Test2::Compare::Negatable;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
|
||||
133
database/perl/vendor/lib/Test2/Compare/Number.pm
vendored
Normal file
133
database/perl/vendor/lib/Test2/Compare/Number.pm
vendored
Normal file
@@ -0,0 +1,133 @@
|
||||
package Test2::Compare::Number;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp qw/confess/;
|
||||
|
||||
use base 'Test2::Compare::Base';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::Util::HashBase qw/input/;
|
||||
|
||||
# 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/;
|
||||
|
||||
$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 '' unless length($got) && $got =~ m/\S/;
|
||||
|
||||
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 @warnings;
|
||||
my $out;
|
||||
{
|
||||
local $SIG{__WARN__} = sub { push @warnings => @_ };
|
||||
$out = $negate ? ($input != $got) : ($input == $got);
|
||||
}
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Object.pm
vendored
Normal file
256
database/perl/vendor/lib/Test2/Compare/Object.pm
vendored
Normal 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.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/OrderedSubset.pm
vendored
Normal file
175
database/perl/vendor/lib/Test2/Compare/OrderedSubset.pm
vendored
Normal file
@@ -0,0 +1,175 @@
|
||||
package Test2::Compare::OrderedSubset;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Compare::Base';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Pattern.pm
vendored
Normal file
93
database/perl/vendor/lib/Test2/Compare/Pattern.pm
vendored
Normal file
@@ -0,0 +1,93 @@
|
||||
package Test2::Compare::Pattern;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Compare::Base';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Ref.pm
vendored
Normal file
109
database/perl/vendor/lib/Test2/Compare/Ref.pm
vendored
Normal file
@@ -0,0 +1,109 @@
|
||||
package Test2::Compare::Ref;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Compare::Base';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Regex.pm
vendored
Normal file
93
database/perl/vendor/lib/Test2/Compare/Regex.pm
vendored
Normal file
@@ -0,0 +1,93 @@
|
||||
package Test2::Compare::Regex;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Compare::Base';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Scalar.pm
vendored
Normal file
111
database/perl/vendor/lib/Test2/Compare/Scalar.pm
vendored
Normal file
@@ -0,0 +1,111 @@
|
||||
package Test2::Compare::Scalar;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Compare::Base';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Set.pm
vendored
Normal file
153
database/perl/vendor/lib/Test2/Compare/Set.pm
vendored
Normal file
@@ -0,0 +1,153 @@
|
||||
package Test2::Compare::Set;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Compare::Base';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/String.pm
vendored
Normal file
108
database/perl/vendor/lib/Test2/Compare/String.pm
vendored
Normal 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.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Undef.pm
vendored
Normal file
83
database/perl/vendor/lib/Test2/Compare/Undef.pm
vendored
Normal 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.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Compare/Wildcard.pm
vendored
Normal file
69
database/perl/vendor/lib/Test2/Compare/Wildcard.pm
vendored
Normal file
@@ -0,0 +1,69 @@
|
||||
package Test2::Compare::Wildcard;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Compare::Base';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
|
||||
81
database/perl/vendor/lib/Test2/Event/Warning.pm
vendored
Normal file
81
database/perl/vendor/lib/Test2/Event/Warning.pm
vendored
Normal file
@@ -0,0 +1,81 @@
|
||||
package Test2::Event::Warning;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.09';
|
||||
|
||||
use parent 'Test2::Event';
|
||||
|
||||
use Test2::Util::HashBase qw( causes_fail warning );
|
||||
|
||||
sub init {
|
||||
$_[0]->{ +CAUSES_FAIL } = 1 unless exists $_[0]->{ +CAUSES_FAIL };
|
||||
$_[0]->{ +WARNING } = 'undef' unless defined $_[0]->{ +WARNING };
|
||||
}
|
||||
|
||||
sub summary { $_[0]->{ +WARNING } }
|
||||
|
||||
sub increments_count {1}
|
||||
sub diagnostics {1}
|
||||
|
||||
1;
|
||||
|
||||
# ABSTRACT: A Test2 event for warnings
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Event::Warning - A Test2 event for warnings
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.09
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
An event representing an unwanted warning. This is treated as a failure.
|
||||
|
||||
=for Pod::Coverage init
|
||||
|
||||
=head1 ACCESSORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $warning = $event->warning
|
||||
|
||||
Returns the warning that this event captured.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Bugs may be submitted at L<https://github.com/houseabsolute/Test2-Plugin-NoWarnings/issues>.
|
||||
|
||||
I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2-Plugin-NoWarnings can be found at L<https://github.com/houseabsolute/Test2-Plugin-NoWarnings>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Dave Rolsky <autarch@urth.org>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is Copyright (c) 2020 by Dave Rolsky.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The Artistic License 2.0 (GPL Compatible)
|
||||
|
||||
The full text of the license can be found in the
|
||||
F<LICENSE> file included with this distribution.
|
||||
|
||||
=cut
|
||||
80
database/perl/vendor/lib/Test2/Manual.pm
vendored
Normal file
80
database/perl/vendor/lib/Test2/Manual.pm
vendored
Normal file
@@ -0,0 +1,80 @@
|
||||
package Test2::Manual;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Manual/Anatomy.pm
vendored
Normal file
88
database/perl/vendor/lib/Test2/Manual/Anatomy.pm
vendored
Normal file
@@ -0,0 +1,88 @@
|
||||
package Test2::Manual::Anatomy;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Manual/Anatomy/API.pm
vendored
Normal file
78
database/perl/vendor/lib/Test2/Manual/Anatomy/API.pm
vendored
Normal file
@@ -0,0 +1,78 @@
|
||||
package Test2::Manual::Anatomy::API;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Manual/Anatomy/Context.pm
vendored
Normal file
114
database/perl/vendor/lib/Test2/Manual/Anatomy/Context.pm
vendored
Normal file
@@ -0,0 +1,114 @@
|
||||
package Test2::Manual::Anatomy::Context;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Manual/Anatomy/EndToEnd.pm
vendored
Normal file
376
database/perl/vendor/lib/Test2/Manual/Anatomy/EndToEnd.pm
vendored
Normal file
@@ -0,0 +1,376 @@
|
||||
package Test2::Manual::Anatomy::EndToEnd;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
|
||||
416
database/perl/vendor/lib/Test2/Manual/Anatomy/Event.pm
vendored
Normal file
416
database/perl/vendor/lib/Test2/Manual/Anatomy/Event.pm
vendored
Normal file
@@ -0,0 +1,416 @@
|
||||
package Test2::Manual::Anatomy::Event;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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<Note> Do not worry too much about getting the key/pluralization wrong. Most
|
||||
tools will use L<Module::Pluggable> to load all facet types and build a hash
|
||||
linking keys to packages and so on, working backwards. This means, in general,
|
||||
that even if you get it wrong any tool that NEEDS the package for the facet
|
||||
will find it.
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Manual/Anatomy/Hubs.pm
vendored
Normal file
120
database/perl/vendor/lib/Test2/Manual/Anatomy/Hubs.pm
vendored
Normal file
@@ -0,0 +1,120 @@
|
||||
package Test2::Manual::Anatomy::Hubs;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Manual/Anatomy/IPC.pm
vendored
Normal file
90
database/perl/vendor/lib/Test2/Manual/Anatomy/IPC.pm
vendored
Normal file
@@ -0,0 +1,90 @@
|
||||
package Test2::Manual::Anatomy::IPC;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Manual/Anatomy/Utilities.pm
vendored
Normal file
76
database/perl/vendor/lib/Test2/Manual/Anatomy/Utilities.pm
vendored
Normal file
@@ -0,0 +1,76 @@
|
||||
package Test2::Manual::Anatomy::Utilities;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Manual/Concurrency.pm
vendored
Normal file
143
database/perl/vendor/lib/Test2/Manual/Concurrency.pm
vendored
Normal file
@@ -0,0 +1,143 @@
|
||||
package Test2::Manual::Concurrency;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Manual/Contributing.pm
vendored
Normal file
115
database/perl/vendor/lib/Test2/Manual/Contributing.pm
vendored
Normal file
@@ -0,0 +1,115 @@
|
||||
package Test2::Manual::Contributing;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Manual/Testing.pm
vendored
Normal file
245
database/perl/vendor/lib/Test2/Manual/Testing.pm
vendored
Normal file
@@ -0,0 +1,245 @@
|
||||
package Test2::Manual::Testing;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Manual/Testing/Introduction.pm
vendored
Normal file
293
database/perl/vendor/lib/Test2/Manual/Testing/Introduction.pm
vendored
Normal file
@@ -0,0 +1,293 @@
|
||||
package Test2::Manual::Testing::Introduction;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
|
||||
420
database/perl/vendor/lib/Test2/Manual/Testing/Migrating.pm
vendored
Normal file
420
database/perl/vendor/lib/Test2/Manual/Testing/Migrating.pm
vendored
Normal file
@@ -0,0 +1,420 @@
|
||||
package Test2::Manual::Testing::Migrating;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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 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
database/perl/vendor/lib/Test2/Manual/Testing/Planning.pm
vendored
Normal file
104
database/perl/vendor/lib/Test2/Manual/Testing/Planning.pm
vendored
Normal file
@@ -0,0 +1,104 @@
|
||||
package Test2::Manual::Testing::Planning;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
database/perl/vendor/lib/Test2/Manual/Testing/Todo.pm
vendored
Normal file
112
database/perl/vendor/lib/Test2/Manual/Testing/Todo.pm
vendored
Normal file
@@ -0,0 +1,112 @@
|
||||
package Test2::Manual::Testing::Todo;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
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
|
||||
120
database/perl/vendor/lib/Test2/Manual/Tooling.pm
vendored
Normal file
120
database/perl/vendor/lib/Test2/Manual/Tooling.pm
vendored
Normal file
@@ -0,0 +1,120 @@
|
||||
package Test2::Manual::Tooling;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Manual::Tooling - Manual page for tool authors.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This section covers writing new tools, plugins, and other Test2 components.
|
||||
|
||||
=head1 TOOL TUTORIALS
|
||||
|
||||
=head2 FIRST TOOL
|
||||
|
||||
L<Test2::Manual::Tooling::FirstTool> - Introduction to writing tools by cloning
|
||||
L<ok()>.
|
||||
|
||||
=head2 MOVING FROM Test::Builder
|
||||
|
||||
L<Test2::Manual::Tooling::TestBuilder> - This section maps Test::Builder
|
||||
methods to Test2 concepts.
|
||||
|
||||
=head2 NESTING TOOLS
|
||||
|
||||
L<Test2::Manual::Tooling::Nesting> - How to call other tools from your tool.
|
||||
|
||||
=head2 TOOLS WITH SUBTESTS
|
||||
|
||||
L<Test2::Manual::Tooling::Subtest> - How write tools that make use of subtests.
|
||||
|
||||
=head2 TESTING YOUR TEST TOOLS
|
||||
|
||||
L<Test2::Manual::Tooling::Testing> - How to write tests for your test tools.
|
||||
|
||||
=head1 PLUGIN TUTORIALS
|
||||
|
||||
=head2 TAKING ACTION WHEN A NEW TOOL STARTS
|
||||
|
||||
L<Test2::Manual::Tooling::Plugin::ToolStarts> - How to add behaviors that occur
|
||||
when a tool starts work.
|
||||
|
||||
=head2 TAKING ACTION AFTER A TOOL IS DONE
|
||||
|
||||
L<Test2::Manual::Tooling::Plugin::ToolCompletes> - How to add behaviors that
|
||||
occur when a tool completes work.
|
||||
|
||||
=head2 TAKING ACTION AT THE END OF TESTING
|
||||
|
||||
L<Test2::Manual::Tooling::Plugin::TestingDone> - How to add behaviors that
|
||||
occur when testing is complete (IE done_testing, or end of test).
|
||||
|
||||
=head2 TAKING ACTION JUST BEFORE EXIT
|
||||
|
||||
L<Test2::Manual::Tooling::Plugin::TestExit> - How to safely add pre-exit
|
||||
behaviors.
|
||||
|
||||
=head1 WRITING A SIMPLE JSONL FORMATTER
|
||||
|
||||
L<Test2::Manual::Tooling::Formatter> - How to write a custom formatter, in our
|
||||
case a JSONL formatter.
|
||||
|
||||
=head1 WHERE TO FIND HOOKS AND APIS
|
||||
|
||||
=over 4
|
||||
|
||||
=item global API
|
||||
|
||||
L<Test2::API> is the global API. This is primarily used by plugins that provide
|
||||
global behavior.
|
||||
|
||||
=item In hubs
|
||||
|
||||
L<Test2::Hub> is the base class for all hubs. This is where hooks for
|
||||
manipulating events, or running things at the end of testing live.
|
||||
|
||||
=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
|
||||
145
database/perl/vendor/lib/Test2/Manual/Tooling/FirstTool.pm
vendored
Normal file
145
database/perl/vendor/lib/Test2/Manual/Tooling/FirstTool.pm
vendored
Normal file
@@ -0,0 +1,145 @@
|
||||
package Test2::Manual::Tooling::FirstTool;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Manual::Tooling::FirstTool - Write your first tool with Test2.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This tutorial will help you write your very first tool by cloning the C<ok()>
|
||||
tool.
|
||||
|
||||
=head1 COMPLETE CODE UP FRONT
|
||||
|
||||
package Test2::Tools::MyOk;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test2::API qw/context/;
|
||||
|
||||
use base 'Exporter';
|
||||
our @EXPORT = qw/ok/;
|
||||
|
||||
sub ok($;$@) {
|
||||
my ($bool, $name, @diag) = @_;
|
||||
|
||||
my $ctx = context();
|
||||
|
||||
return $ctx->pass_and_release($name) if $bool;
|
||||
return $ctx->fail_and_release($name, @diag);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 LINE BY LINE
|
||||
|
||||
=over 4
|
||||
|
||||
=item sub ok($;$@) {
|
||||
|
||||
In this case we are emulating the C<ok()> function exported by
|
||||
L<Test2::Tools::Basic>.
|
||||
|
||||
C<ok()> and similar test tools use prototypes to enforce argument parsing. Your
|
||||
test tools do not necessarily need prototypes, like any perl function you need
|
||||
to make the decision based on how it is used.
|
||||
|
||||
The prototype requires at least 1 argument, which will
|
||||
be forced into a scalar context. The second argument is optional, and is also
|
||||
forced to be scalar, it is the name of the test. Any remaining arguments are
|
||||
treated as diagnostics messages that will only be used if the test failed.
|
||||
|
||||
=item my ($bool, $name, @diag) = @_;
|
||||
|
||||
This line does not need much explanation, we are simply grabbing the args.
|
||||
|
||||
=item my $ctx = context();
|
||||
|
||||
This is a vital line in B<ALL> tools. The context object is the primary API for
|
||||
test tools. You B<MUST> get a context if you want to issue any events, such as
|
||||
making assertions. Further, the context is responsible for making sure failures
|
||||
are attributed to the correct file and line number.
|
||||
|
||||
B<Note:> A test function B<MUST> always release the context when it is done,
|
||||
you cannot simply let it fall out of scope and be garbage collected. Test2 does
|
||||
a pretty good job of yelling at you if you make this mistake.
|
||||
|
||||
B<Note:> You B<MUST NOT> ever store or pass around a I<real> context object. If
|
||||
you wish to hold on to a context for any reason you must use clone to make a
|
||||
copy C<< my $copy = $ctx->clone >>. The copy may be passed around or stored,
|
||||
but the original B<MUST> be released when you are done with it.
|
||||
|
||||
=item return $ctx->pass_and_release($name) if $bool;
|
||||
|
||||
When C<$bool> is true, this line uses the context object to issue a
|
||||
L<Test2::Event::Pass> event. Along with issuing the event this will also
|
||||
release the context object and return true.
|
||||
|
||||
This is short form for:
|
||||
|
||||
if($bool) {
|
||||
$ctx->pass($name);
|
||||
$ctx->release;
|
||||
return 1;
|
||||
}
|
||||
|
||||
=item return $ctx->fail_and_release($name, @diag);
|
||||
|
||||
This line issues a L<Test2::Event::Fail> event, releases the context object,
|
||||
and returns false. The fail event will include any diagnostics messages from
|
||||
the C<@diag> array.
|
||||
|
||||
This is short form for:
|
||||
|
||||
$ctx->fail($name, @diag);
|
||||
$ctx->release;
|
||||
return 0;
|
||||
|
||||
=back
|
||||
|
||||
=head1 CONTEXT OBJECT DOCUMENTATION
|
||||
|
||||
L<Test2::API::Context> is the place to read up on what methods the context
|
||||
provides.
|
||||
|
||||
=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
|
||||
138
database/perl/vendor/lib/Test2/Manual/Tooling/Formatter.pm
vendored
Normal file
138
database/perl/vendor/lib/Test2/Manual/Tooling/Formatter.pm
vendored
Normal file
@@ -0,0 +1,138 @@
|
||||
package Test2::Manual::Tooling::Formatter;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Manual::Tooling::Formatter - How to write a custom formatter, in our
|
||||
case a JSONL formatter.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This tutorial explains a minimal formatter that outputs each event as a json
|
||||
string on its own line. A true formatter will probably be significantly more
|
||||
complicated, but this will give you the basics needed to get started.
|
||||
|
||||
=head1 COMPLETE CODE UP FRONT
|
||||
|
||||
package Test2::Formatter::MyFormatter;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use JSON::MaybeXS qw/encode_json/;
|
||||
|
||||
use base qw/Test2::Formatter/;
|
||||
|
||||
sub new { bless {}, shift }
|
||||
|
||||
sub encoding {};
|
||||
|
||||
sub write {
|
||||
my ($self, $e, $num, $f) = @_;
|
||||
$f ||= $e->facet_data;
|
||||
|
||||
print encode_json($f), "\n";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 LINE BY LINE
|
||||
|
||||
=over 4
|
||||
|
||||
=item use base qw/Test2::Formatter/;
|
||||
|
||||
All formatters should inherit from L<Test2::Formatter>.
|
||||
|
||||
=item sub new { bless {}, shift }
|
||||
|
||||
Formatters need to be instantiable objects, this is a minimal C<new()> method.
|
||||
|
||||
=item sub encoding {};
|
||||
|
||||
For this example we leave this sub empty. In general you should implement this
|
||||
sub to make sure you honor situations where the encoding is set. L<Test2::V0>
|
||||
itself will try to set the encoding to UTF8.
|
||||
|
||||
=item sub write { ... }
|
||||
|
||||
The C<write()> method is the most important, each event is sent here.
|
||||
|
||||
=item my ($self, $e, $num, $f) = @_;
|
||||
|
||||
The C<write()> method receives 3 or 4 arguments, the fourth is optional.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $self
|
||||
|
||||
The formatter itself.
|
||||
|
||||
=item $e
|
||||
|
||||
The event being written
|
||||
|
||||
=item $num
|
||||
|
||||
The most recent assertion number. If the event being processed is an assertion
|
||||
then this will have been bumped by 1 since the last call to write. For non
|
||||
assertions this number is set to the most recent assertion.
|
||||
|
||||
=item $f
|
||||
|
||||
This MAY be a hashref containing all the facet data from the event. More often
|
||||
then not this will be undefined. This is only set if the facet data was needed
|
||||
by the hub, and it usually is not.
|
||||
|
||||
=back
|
||||
|
||||
=item $f ||= $e->facet_data;
|
||||
|
||||
We want to dump the event facet data. This will set C<$f> to the facet data
|
||||
unless we already have the facet data.
|
||||
|
||||
=item print encode_json($f), "\n";
|
||||
|
||||
This line prints the JSON encoded facet data, and a newline.
|
||||
|
||||
=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
|
||||
140
database/perl/vendor/lib/Test2/Manual/Tooling/Nesting.pm
vendored
Normal file
140
database/perl/vendor/lib/Test2/Manual/Tooling/Nesting.pm
vendored
Normal file
@@ -0,0 +1,140 @@
|
||||
package Test2::Manual::Tooling::Nesting;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Manual::Tooling::Nesting - Tutorial for using other tools within your
|
||||
own.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Sometimes you find yourself writing the same test pattern over and over, in
|
||||
such cases you may want to encapsulate the logic in a new test function that
|
||||
calls several tools together. This sounds easy enough, but can cause headaches
|
||||
if not done correctly.
|
||||
|
||||
=head1 NAIVE WAY
|
||||
|
||||
Lets say you find yourself writing the same test pattern over and over for multiple objects:
|
||||
|
||||
my $obj1 = $class1->new;
|
||||
is($obj1->foo, 'foo', "got foo");
|
||||
is($obj1->bar, 'bar', "got bar");
|
||||
|
||||
my $obj2 = $class1->new;
|
||||
is($obj2->foo, 'foo', "got foo");
|
||||
is($obj2->bar, 'bar', "got bar");
|
||||
|
||||
... 10x more times for classes 2-12
|
||||
|
||||
The naive way to do this is to write a C<check_class()> function like this:
|
||||
|
||||
sub check_class {
|
||||
my $class = shift;
|
||||
my $obj = $class->new;
|
||||
is($obj->foo, 'foo', "got foo");
|
||||
is($obj->bar, 'bar', "got bar");
|
||||
}
|
||||
|
||||
check_class($class1);
|
||||
check_class($class2);
|
||||
check_class($class3);
|
||||
...
|
||||
|
||||
This will appear to work fine, and you might not notice any problems,
|
||||
I<so long as the tests are passing.>
|
||||
|
||||
=head2 WHATS WRONG WITH IT?
|
||||
|
||||
The problems with the naive approach become obvious if things start to fail.
|
||||
The diagnostics that tell you what file and line the failure occurred on will be
|
||||
wrong. The failure will be reported to the line I<inside> C<check_class>, not
|
||||
to the line where C<check_class()> was called. This is problem because it
|
||||
leaves you with no idea which class is failing.
|
||||
|
||||
=head2 HOW TO FIX IT
|
||||
|
||||
Luckily this is extremely easy to fix. You need to acquire a context object at
|
||||
the start of your function, and release it at the end... yes it is that simple.
|
||||
|
||||
use Test2::API qw/context/;
|
||||
|
||||
sub check_class {
|
||||
my $class = shift;
|
||||
|
||||
my $ctx = context();
|
||||
|
||||
my $obj = $class->new;
|
||||
is($obj->foo, 'foo', "got foo");
|
||||
is($obj->bar, 'bar', "got bar");
|
||||
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
See, that was easy. With these 2 additional lines we know have proper file+line
|
||||
reporting. The nested tools will find the context we acquired here, and know to
|
||||
use it's file and line numbers.
|
||||
|
||||
=head3 THE OLD WAY (DO NOT DO THIS ANYMORE)
|
||||
|
||||
With L<Test::Builder> there was a global variables called
|
||||
C<$Test::Builder::Level> which helped solve this problem:
|
||||
|
||||
sub check_class {
|
||||
my $class = shift;
|
||||
|
||||
local $Test::Builder::Level = $Test::Builder::Level + 1;
|
||||
|
||||
my $obj = $class->new;
|
||||
is($obj->foo, 'foo', "got foo");
|
||||
is($obj->bar, 'bar', "got bar");
|
||||
}
|
||||
|
||||
This variable worked well enough (and will still work) but was not very
|
||||
discoverable. Another problem with this variable is that it becomes cumbersome
|
||||
if you have a more deeply nested code structure called the nested tools, you
|
||||
might need to count stack frames, and hope they never change due to a third
|
||||
party module. The context solution has no such caveats.
|
||||
|
||||
=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
|
||||
108
database/perl/vendor/lib/Test2/Manual/Tooling/Plugin/TestExit.pm
vendored
Normal file
108
database/perl/vendor/lib/Test2/Manual/Tooling/Plugin/TestExit.pm
vendored
Normal file
@@ -0,0 +1,108 @@
|
||||
package Test2::Manual::Tooling::Plugin::TestExit;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Manual::Tooling::Plugin::TestExit - How to safely add pre-exit
|
||||
behaviors.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This describes the correct/safe way to add pre-exit behaviors to tests via a
|
||||
custom plugin.
|
||||
|
||||
The naive way to attempt this would be to add an C<END { ... }> block. That can
|
||||
work, and may not cause problems.... On the other hand there are a lot of ways
|
||||
that can bite you. Describing all the potential problems of an END block, and
|
||||
how it might conflict with Test2 (Which has its own END block) is beyond the
|
||||
scope of this document.
|
||||
|
||||
=head1 COMPLETE CODE UP FRONT
|
||||
|
||||
package Test2::Plugin::MyPlugin;
|
||||
|
||||
use Test2::API qw{test2_add_callback_exit};
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
|
||||
test2_add_callback_exit(sub {
|
||||
my ($ctx, $orig_code, $new_exit_code_ref) = @_;
|
||||
|
||||
return if $orig_code == 42;
|
||||
|
||||
$$new_exit_code_ref = 42;
|
||||
});
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 LINE BY LINE
|
||||
|
||||
=over 4
|
||||
|
||||
=item use Test2::API qw{test2_add_callback_exit};
|
||||
|
||||
This imports the C<(test2_add_callback_exit)> callback.
|
||||
|
||||
=item test2_add_callback_exit(sub { ... });
|
||||
|
||||
This adds our callback to be called before exiting.
|
||||
|
||||
=item my ($ctx, $orig_code, $new_exit_code_ref) = @_
|
||||
|
||||
The callback gets 3 arguments. First is a context object you may use. The
|
||||
second is the original exit code of the C<END> block Test2 is using. The third
|
||||
argument is a scalar reference which you may use to get the current exit code,
|
||||
or set a new one.
|
||||
|
||||
=item return if $orig_code == 42
|
||||
|
||||
This is a short-cut to do nothing if the original exit code was already 42.
|
||||
|
||||
=item $$new_exit_code_ref = 42
|
||||
|
||||
This changes the exit code to 42.
|
||||
|
||||
=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
|
||||
121
database/perl/vendor/lib/Test2/Manual/Tooling/Plugin/TestingDone.pm
vendored
Normal file
121
database/perl/vendor/lib/Test2/Manual/Tooling/Plugin/TestingDone.pm
vendored
Normal file
@@ -0,0 +1,121 @@
|
||||
package Test2::Manual::Tooling::Plugin::TestingDone;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Manual::Tooling::Plugin::TestingDone - Run code when the test file is
|
||||
finished, or when done_testing is called.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a way to add behavior to the end of a test file. This code is run
|
||||
either when done_testing() is called, or when the test file has no more
|
||||
run-time code to run.
|
||||
|
||||
When triggered by done_testing() this will be run BEFORE the plan is calculated
|
||||
and sent. This means it IS safe to make test assertions in this callback.
|
||||
|
||||
=head1 COMPLETE CODE UP FRONT
|
||||
|
||||
package Test2::Plugin::MyPlugin;
|
||||
|
||||
use Test2::API qw{test2_add_callback_testing_done};
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
|
||||
test2_add_callback_testing_done(sub {
|
||||
ok(!$some_global, '$some_global was not set');
|
||||
print "The test file is done, or done_testing was just called\n"
|
||||
});
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 LINE BY LINE
|
||||
|
||||
=over 4
|
||||
|
||||
=item use Test2::API qw{test2_add_callback_testing_done};
|
||||
|
||||
This imports the C<test2_add_callback_testing_done()> callback.
|
||||
|
||||
=item test2_add_callback_testing_done(sub { ... });
|
||||
|
||||
This adds our callback to be called when testing is done.
|
||||
|
||||
=item ok(!$some_global, '$some_global was not set')
|
||||
|
||||
It is safe to make assertions in this type of callback. This code simply
|
||||
asserts that some global was never set over the course of the test.
|
||||
|
||||
=item print "The test file is done, or done_testing was just called\n"
|
||||
|
||||
This prints a message when the callback is run.
|
||||
|
||||
=back
|
||||
|
||||
=head1 UNDER THE HOOD
|
||||
|
||||
Before test2_add_callback_testing_done() this kind of thing was still possible,
|
||||
but it was hard to get right, here is the code to do it:
|
||||
|
||||
test2_add_callback_post_load(sub {
|
||||
my $stack = test2_stack();
|
||||
|
||||
# Insure we have at least one hub, but we do not necessarily want the
|
||||
# one this returns.
|
||||
$stack->top;
|
||||
|
||||
# We want the root hub, not the top one.
|
||||
my ($root) = Test2::API::test2_stack->all;
|
||||
|
||||
# Make sure the hub does not believe nothing has happened.
|
||||
$root->set_active(1);
|
||||
|
||||
# Now we can add our follow-up code
|
||||
$root->follow_up(sub {
|
||||
# Your callback code here
|
||||
});
|
||||
});
|
||||
|
||||
=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
|
||||
94
database/perl/vendor/lib/Test2/Manual/Tooling/Plugin/ToolCompletes.pm
vendored
Normal file
94
database/perl/vendor/lib/Test2/Manual/Tooling/Plugin/ToolCompletes.pm
vendored
Normal file
@@ -0,0 +1,94 @@
|
||||
package Test2::Manual::Tooling::Plugin::ToolCompletes;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Manual::Tooling::Plugin::ToolCompletes - How to add behaviors that occur
|
||||
when a tool completes work.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This tutorial helps you understand how to add behaviors that occur when a tool
|
||||
is done with its work. All tools need to acquire and then release a context,
|
||||
for this tutorial we make use of the release hooks that are called every time a
|
||||
tool releases the context object.
|
||||
|
||||
=head1 COMPLETE CODE UP FRONT
|
||||
|
||||
package Test2::Plugin::MyPlugin;
|
||||
|
||||
use Test2::API qw{test2_add_callback_context_release};
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
|
||||
test2_add_callback_context_release(sub {
|
||||
my $ctx_ref = shift;
|
||||
|
||||
print "Context was released\n";
|
||||
});
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 LINE BY LINE
|
||||
|
||||
=over 4
|
||||
|
||||
=item use Test2::API qw{test2_add_callback_context_release};
|
||||
|
||||
This imports the C<test2_add_callback_context_release()> callback.
|
||||
|
||||
=item test2_add_callback_context_release(sub { ... })
|
||||
|
||||
=item my $ctx_ref = shift
|
||||
|
||||
The coderefs for test2_add_callback_context_release() will receive exactly 1
|
||||
argument, the context being released.
|
||||
|
||||
=item print "Context was released\n"
|
||||
|
||||
Print a notification whenever the context is released.
|
||||
|
||||
=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
|
||||
126
database/perl/vendor/lib/Test2/Manual/Tooling/Plugin/ToolStarts.pm
vendored
Normal file
126
database/perl/vendor/lib/Test2/Manual/Tooling/Plugin/ToolStarts.pm
vendored
Normal file
@@ -0,0 +1,126 @@
|
||||
package Test2::Manual::Tooling::Plugin::ToolStarts;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Manual::Tooling::Plugin::ToolStarts - How to add behaviors that occur
|
||||
when a tool starts work.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This tutorial will help you write plugins that have behavior when a tool
|
||||
starts. All tools should start by acquiring a context object. This tutorial
|
||||
shows you the hooks you can use to take advantage of the context acquisition.
|
||||
|
||||
=head1 COMPLETE CODE UP FRONT
|
||||
|
||||
package Test2::Plugin::MyPlugin;
|
||||
|
||||
use Test2::API qw{
|
||||
test2_add_callback_context_init
|
||||
test2_add_callback_context_acquire
|
||||
};
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
|
||||
# Let us know every time a tool requests a context, and give us a
|
||||
# chance to modify the parameters before we find it.
|
||||
test2_add_callback_context_acquire(sub {
|
||||
my $params_ref = shift;
|
||||
|
||||
print "A tool has requested the context\n";
|
||||
});
|
||||
|
||||
# Callback every time a new context is created, not called if an
|
||||
# existing context is found.
|
||||
test2_add_callback_context_init(sub {
|
||||
my $ctx_ref = shift;
|
||||
|
||||
print "A new context was created\n";
|
||||
});
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=head1 LINE BY LINE
|
||||
|
||||
=over 4
|
||||
|
||||
=item use Test2::API qw{test2_add_callback_context_init test2_add_callback_context_acquire};
|
||||
|
||||
This imports the C<test2_add_callback_context_init()> and
|
||||
C<test2_add_callback_context_acquire()> callbacks.
|
||||
|
||||
=item test2_add_callback_context_acquire(sub { ... })
|
||||
|
||||
This is where we add our callback for context acquisition. Every time
|
||||
C<Test2::API::context()> is called the callback will be run.
|
||||
|
||||
=item my $params_ref = shift
|
||||
|
||||
In the test2_add_callback_context_acquire() callbacks we get exactly 1
|
||||
argument, a reference to the parameters that C<context()> will use to find the
|
||||
context.
|
||||
|
||||
=item print "A tool has requested the context\n"
|
||||
|
||||
Print a notification whenever a tool asks for a context.
|
||||
|
||||
=item test2_add_callback_context_init(sub { ... })
|
||||
|
||||
Add our context init callback. These callbacks are triggered whenever a
|
||||
completely new context is created. This is not called if an existing context is
|
||||
found. In short this only fires off for the top level tool, not nested tools.
|
||||
|
||||
=item my $ctx_ref = shift
|
||||
|
||||
The coderefs for test2_add_callback_context_init() will receive exactly 1
|
||||
argument, the newly created context.
|
||||
|
||||
=item print "A new context was created\n"
|
||||
|
||||
Print a notification whenever a new context is created.
|
||||
|
||||
=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
|
||||
164
database/perl/vendor/lib/Test2/Manual/Tooling/Subtest.pm
vendored
Normal file
164
database/perl/vendor/lib/Test2/Manual/Tooling/Subtest.pm
vendored
Normal file
@@ -0,0 +1,164 @@
|
||||
package Test2::Manual::Tooling::Subtest;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Manual::Tooling::Subtest - How to implement a tool that makes use of
|
||||
subtests.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Subtests are a nice way of making related events visually, and architecturally
|
||||
distinct.
|
||||
|
||||
=head1 WHICH TYPE OF SUBTEST DO I NEED?
|
||||
|
||||
There are 2 types of subtest. The first type is subtests with user-supplied
|
||||
coderefs, such as the C<subtest()> function itself. The second type is subtest
|
||||
that do not have any user supplied coderefs.
|
||||
|
||||
So which type do you need? The answer to that is simple, if you are going to
|
||||
let the user define the subtest with their own codeblock, you have the first
|
||||
type, otherwise you have the second.
|
||||
|
||||
In either case, you will still need use the same API function:
|
||||
C<Test2::API::run_subtest>.
|
||||
|
||||
=head2 SUBTEST WITH USER SUPPLIED CODEREF
|
||||
|
||||
This example will emulate the C<subtest> function.
|
||||
|
||||
use Test2::API qw/context run_subtest/;
|
||||
|
||||
sub my_subtest {
|
||||
my ($name, $code) = @_;
|
||||
|
||||
# Like any other tool, you need to acquire a context, if you do not then
|
||||
# things will not report the correct file and line number.
|
||||
my $ctx = context();
|
||||
|
||||
my $bool = run_subtest($name, $code);
|
||||
|
||||
$ctx->release;
|
||||
|
||||
return $bool;
|
||||
}
|
||||
|
||||
This looks incredibly simple... and it is. C<run_subtest()> does all the hard
|
||||
work for you. This will issue an L<Test2::Event::Subtest> event with the
|
||||
results of the subtest. The subtest event itself will report to the proper file
|
||||
and line number due to the context you acquired (even though it does not I<look>
|
||||
like you used the context.
|
||||
|
||||
C<run_subtest()> can take additional arguments:
|
||||
|
||||
run_subtest($name, $code, \%params, @args);
|
||||
|
||||
=over 4
|
||||
|
||||
=item @args
|
||||
|
||||
This allows you to pass arguments into the codeblock that gets run.
|
||||
|
||||
=item \%params
|
||||
|
||||
This is a hashref of parameters. Currently there are 3 possible parameters:
|
||||
|
||||
=over 4
|
||||
|
||||
=item buffered => $bool
|
||||
|
||||
This will turn the subtest into the new style buffered subtest. This type of
|
||||
subtest is recommended, but not default.
|
||||
|
||||
=item inherit_trace => $bool
|
||||
|
||||
This is used for tool-side coderefs.
|
||||
|
||||
=item no_fork => $bool
|
||||
|
||||
react to forking/threading inside the subtest itself. In general you are
|
||||
unlikely to need/want this parameter.
|
||||
|
||||
=back
|
||||
|
||||
=back
|
||||
|
||||
=head2 SUBTEST WITH TOOL-SIDE CODEREF
|
||||
|
||||
This is particularly useful if you want to turn a tool that wraps other tools
|
||||
into a subtest. For this we will be using the tool we created in
|
||||
L<Test2::Manual::Tooling::Nesting>.
|
||||
|
||||
use Test2::API qw/context run_subtest/;
|
||||
|
||||
sub check_class {
|
||||
my $class = shift;
|
||||
|
||||
my $ctx = context();
|
||||
|
||||
my $code = sub {
|
||||
my $obj = $class->new;
|
||||
is($obj->foo, 'foo', "got foo");
|
||||
is($obj->bar, 'bar', "got bar");
|
||||
};
|
||||
|
||||
my $bool = run_subtest($class, $code, {buffered => 1, inherit_trace => 1});
|
||||
|
||||
$ctx->release;
|
||||
|
||||
return $bool;
|
||||
}
|
||||
|
||||
The C<run_subtest()> function does all the heavy lifting for us. All we need
|
||||
to do is give the function a name, a coderef to run, and the
|
||||
C<< inherit_trace => 1 >> parameter. The C<< buffered => 1 >> parameter is
|
||||
optional, but recommended.
|
||||
|
||||
The C<inherit_trace> parameter tells the subtest tool that the contexts acquired
|
||||
inside the nested tools should use the same trace as the subtest itself. For
|
||||
user-supplied codeblocks you do not use inherit_trace because you want errors
|
||||
to report to the user-supplied file+line.
|
||||
|
||||
=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
|
||||
171
database/perl/vendor/lib/Test2/Manual/Tooling/TestBuilder.pm
vendored
Normal file
171
database/perl/vendor/lib/Test2/Manual/Tooling/TestBuilder.pm
vendored
Normal file
@@ -0,0 +1,171 @@
|
||||
package Test2::Manual::Tooling::TestBuilder;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Manual::Tooling::TestBuilder - This section maps Test::Builder methods
|
||||
to Test2 concepts.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
With Test::Builder tools were encouraged to use methods on the Test::Builder
|
||||
singleton object. Test2 has a different approach, every tool should get a new
|
||||
L<Test2::API::Context> object, and call methods on that. This document maps
|
||||
several concepts from Test::Builder to Test2.
|
||||
|
||||
=head1 CONTEXT
|
||||
|
||||
First thing to do, stop using the Test::Builder singleton, in fact stop using
|
||||
or even loading Test::Builder. Instead of Test::Builder each tool you write
|
||||
should follow this template:
|
||||
|
||||
use Test2::API qw/context/;
|
||||
|
||||
sub my_tool {
|
||||
my $ctx = context();
|
||||
|
||||
... do work ...
|
||||
|
||||
$ctx->ok(1, "a passing assertion");
|
||||
|
||||
$ctx->release;
|
||||
|
||||
return $whatever;
|
||||
}
|
||||
|
||||
The original Test::Builder style was this:
|
||||
|
||||
use Test::Builder;
|
||||
my $tb = Test::Builder->new; # gets the singleton
|
||||
|
||||
sub my_tool {
|
||||
... do work ...
|
||||
|
||||
$tb->ok(1, "a passing assertion");
|
||||
|
||||
return $whatever;
|
||||
}
|
||||
|
||||
=head1 TEST BUILDER METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $tb->BAIL_OUT($reason)
|
||||
|
||||
The context object has a 'bail' method:
|
||||
|
||||
$ctx->bail($reason)
|
||||
|
||||
=item $tb->diag($string)
|
||||
|
||||
=item $tb->note($string)
|
||||
|
||||
The context object has diag and note methods:
|
||||
|
||||
$ctx->diag($string);
|
||||
$ctx->note($string);
|
||||
|
||||
=item $tb->done_testing
|
||||
|
||||
The context object has a done_testing method:
|
||||
|
||||
$ctx->done_testing;
|
||||
|
||||
Unlike the Test::Builder version, no arguments are allowed.
|
||||
|
||||
=item $tb->like
|
||||
|
||||
=item $tb->unlike
|
||||
|
||||
These are not part of context, instead look at L<Test2::Compare> and
|
||||
L<Test2::Tools::Compare>.
|
||||
|
||||
=item $tb->ok($bool, $name)
|
||||
|
||||
# Preferred
|
||||
$ctx->pass($name);
|
||||
$ctx->fail($name, @diag);
|
||||
|
||||
# Discouraged, but supported:
|
||||
$ctx->ok($bool, $name, \@failure_diags)
|
||||
|
||||
=item $tb->subtest
|
||||
|
||||
use the C<Test2::API::run_subtest()> function instead. See L<Test2::API> for documentation.
|
||||
|
||||
=item $tb->todo_start
|
||||
|
||||
=item $tb->todo_end
|
||||
|
||||
See L<Test2::Tools::Todo> instead.
|
||||
|
||||
=item $tb->output, $tb->failure_output, and $tb->todo_output
|
||||
|
||||
These are handled via formatters now. See L<Test2::Formatter> and
|
||||
L<Test2::Formatter::TAP>.
|
||||
|
||||
=back
|
||||
|
||||
=head1 LEVEL
|
||||
|
||||
L<Test::Builder> had the C<$Test::Builder::Level> variable that you could
|
||||
modify in order to set the stack depth. This was useful if you needed to nest
|
||||
tools and wanted to make sure your file and line number were correct. It was
|
||||
also frustrating and prone to errors. Some people never even discovered the
|
||||
level variable and always had incorrect line numbers when their tools would
|
||||
fail.
|
||||
|
||||
L<Test2> uses the context system, which solves the problem a better way. The
|
||||
top-most tool get a context, and holds on to it until it is done. Any tool
|
||||
nested under the first will find and use the original context instead of
|
||||
generating a new one. This means the level problem is solved for free, no
|
||||
variables to mess with.
|
||||
|
||||
L<Test2> is also smart enough to honor c<$Test::Builder::Level> if it is set.
|
||||
|
||||
=head1 TODO
|
||||
|
||||
L<Test::Builder> used the C<$TODO> package variable to set the TODO state. This
|
||||
was confusing, and easy to get wrong. See L<Test2::Tools::Todo> for the modern
|
||||
way to accomplish a TODO state.
|
||||
|
||||
=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
|
||||
151
database/perl/vendor/lib/Test2/Manual/Tooling/Testing.pm
vendored
Normal file
151
database/perl/vendor/lib/Test2/Manual/Tooling/Testing.pm
vendored
Normal file
@@ -0,0 +1,151 @@
|
||||
package Test2::Manual::Tooling::Testing;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Manual::Tooling::Testing - Tutorial on how to test your testing tools.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Testing your test tools used to be a complex and difficult prospect. The old
|
||||
tools such as L<Test::Tester> and L<Test::Builder::Tester> were limited, and
|
||||
fragile. Test2 on the other hand was designed from the very start to be easily
|
||||
tested! This tutorial shows you how.
|
||||
|
||||
=head1 THE HOLY GRAIL OF TESTING YOUR TOOLS
|
||||
|
||||
The key to making Test2 easily testable (specially when compared to
|
||||
Test::Builder) is the C<intercept> function.
|
||||
|
||||
use Test2::API qw/intercept/;
|
||||
|
||||
my $events = intercept {
|
||||
ok(1, "pass");
|
||||
ok(0, "fail");
|
||||
|
||||
diag("A diag");
|
||||
};
|
||||
|
||||
The intercept function lets you use any test tools you want inside a codeblock.
|
||||
No events or contexts generated within the intercept codeblock will have any
|
||||
effect on the outside testing state. The C<intercept> function completely
|
||||
isolates the tools called within.
|
||||
|
||||
B<Note:> Plugins and things that effect global API state may not be fully
|
||||
isolated. C<intercept> is intended specifically for event isolation.
|
||||
|
||||
The C<intercept> function will return an arrayref containing all the events
|
||||
that were generated within the codeblock. You can now make any assertions you
|
||||
want about the events you expected your tools to generate.
|
||||
|
||||
[
|
||||
bless({...}, 'Test2::Event::Ok'), # pass
|
||||
bless({...}, 'Test2::Event::Ok'), # fail
|
||||
bless({...}, 'Test2::Event::Diag'), # Failure diagnostics (not always a second event)
|
||||
bless({...}, 'Test2::Event::Diag'), # custom 'A diag' message
|
||||
]
|
||||
|
||||
Most test tools eventually produce one or more events. To effectively verify
|
||||
the events you get from intercept you really should read up on how events work
|
||||
L<Test2::Manual::Anatomy::Event>. Once you know about events you can move on to
|
||||
the next section which points you at some helpers.
|
||||
|
||||
=head1 ADDITIONAL HELPERS
|
||||
|
||||
=head2 Test2::Tools::Tester
|
||||
|
||||
This is the most recent set of tools to help you test your events. To really
|
||||
understand these you should familiarize yourself with
|
||||
L<Test2::Manual::Anatomy::Event>. If you are going to be writing anything more
|
||||
than the most simple of tools you should know how events work.
|
||||
|
||||
The L<Test2::Tools::Tester> documentation is a good place for further reading.
|
||||
|
||||
=head2 Test2::Tools::HarnessTester
|
||||
|
||||
The L<Test2::Tools::HarnessTester> can export the C<summarize_events()> tool.
|
||||
This tool lets you run your event arrayref through L<Test2::Harness> so that you
|
||||
can get a pass/fail summary.
|
||||
|
||||
my $summary = summarize_events($events);
|
||||
|
||||
The summary looks like this:
|
||||
|
||||
{
|
||||
plan => $plan_facet, # the plan event facet
|
||||
pass => $bool, # true if the events result in a pass
|
||||
fail => $bool, # true if the events result in a fail
|
||||
errors => $error_count, # Number of error facets seen
|
||||
failures => $failure_count, # Number of failing assertions seen
|
||||
assertions => $assertion_count, # Total number of assertions seen
|
||||
}
|
||||
|
||||
=head2 Test2::Tools::Compare
|
||||
|
||||
B<DEPRECATED> These tools were written before the switch to faceted events.
|
||||
These will still work, but are no longer the recommended way to test your
|
||||
tools.
|
||||
|
||||
The L<Test2::Tools::Compare> library exports a handful of extras to help test
|
||||
events.
|
||||
|
||||
=over 4
|
||||
|
||||
=item event $TYPE => ...
|
||||
|
||||
Use in an array check against $events to check for a specific type of event
|
||||
with the properties you specify.
|
||||
|
||||
=item fail_events $TYPE => ...
|
||||
|
||||
Use when you expect a failing assertion of $TYPE. This will automatically check
|
||||
that the next event following it is a diagnostics message with the default
|
||||
failure text.
|
||||
|
||||
B<Note:> This is outdated as a single event may now possess both the failing
|
||||
assertion AND the failing text, such events will fail this test.
|
||||
|
||||
=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
|
||||
897
database/perl/vendor/lib/Test2/Mock.pm
vendored
Normal file
897
database/perl/vendor/lib/Test2/Mock.pm
vendored
Normal file
@@ -0,0 +1,897 @@
|
||||
package Test2::Mock;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Carp qw/croak confess/;
|
||||
our @CARP_NOT = (__PACKAGE__);
|
||||
|
||||
use Scalar::Util qw/weaken reftype blessed/;
|
||||
use Test2::Util qw/pkg_to_file/;
|
||||
use Test2::Util::Stash qw/parse_symbol slot_to_sig get_symbol get_stash purge_symbol/;
|
||||
use Test2::Util::Sub qw/gen_accessor gen_reader gen_writer/;
|
||||
|
||||
sub new; # Prevent hashbase from giving us 'new';
|
||||
use Test2::Util::HashBase qw/class parent child _purge_on_destroy _blocked_load _symbols _track sub_tracking call_tracking/;
|
||||
|
||||
sub new {
|
||||
my $class = shift;
|
||||
|
||||
croak "Called new() on a blessed instance, did you mean to call \$control->class->new()?"
|
||||
if blessed($class);
|
||||
|
||||
my $self = bless({}, $class);
|
||||
|
||||
$self->{+SUB_TRACKING} ||= {};
|
||||
$self->{+CALL_TRACKING} ||= [];
|
||||
|
||||
my @sets;
|
||||
while (my $arg = shift @_) {
|
||||
my $val = shift @_;
|
||||
|
||||
if ($class->can(uc($arg))) {
|
||||
$self->{$arg} = $val;
|
||||
next;
|
||||
}
|
||||
|
||||
push @sets => [$arg, $val];
|
||||
}
|
||||
|
||||
croak "The 'class' field is required"
|
||||
unless $self->{+CLASS};
|
||||
|
||||
for my $set (@sets) {
|
||||
my ($meth, $val) = @$set;
|
||||
my $type = reftype($val);
|
||||
|
||||
confess "'$meth' is not a valid constructor argument for $class"
|
||||
unless $self->can($meth);
|
||||
|
||||
if (!$type) {
|
||||
$self->$meth($val);
|
||||
}
|
||||
elsif($type eq 'HASH') {
|
||||
$self->$meth(%$val);
|
||||
}
|
||||
elsif($type eq 'ARRAY') {
|
||||
$self->$meth(@$val);
|
||||
}
|
||||
else {
|
||||
croak "'$val' is not a valid argument for '$meth'"
|
||||
}
|
||||
}
|
||||
|
||||
return $self;
|
||||
}
|
||||
|
||||
sub _check {
|
||||
return unless $_[0]->{+CHILD};
|
||||
croak "There is an active child controller, cannot proceed";
|
||||
}
|
||||
|
||||
sub purge_on_destroy {
|
||||
my $self = shift;
|
||||
($self->{+_PURGE_ON_DESTROY}) = @_ if @_;
|
||||
return $self->{+_PURGE_ON_DESTROY};
|
||||
}
|
||||
|
||||
sub stash {
|
||||
my $self = shift;
|
||||
get_stash($self->{+CLASS});
|
||||
}
|
||||
|
||||
sub file {
|
||||
my $self = shift;
|
||||
my $file = $self->class;
|
||||
return pkg_to_file($self->class);
|
||||
}
|
||||
|
||||
sub block_load {
|
||||
my $self = shift;
|
||||
$self->_check();
|
||||
|
||||
my $file = $self->file;
|
||||
|
||||
croak "Cannot block the loading of module '" . $self->class . "', already loaded in file $INC{$file}"
|
||||
if $INC{$file};
|
||||
|
||||
$INC{$file} = __FILE__;
|
||||
|
||||
$self->{+_BLOCKED_LOAD} = 1;
|
||||
}
|
||||
|
||||
my %NEW = (
|
||||
hash => sub {
|
||||
my ($class, %params) = @_;
|
||||
return bless \%params, $class;
|
||||
},
|
||||
array => sub {
|
||||
my ($class, @params) = @_;
|
||||
return bless \@params, $class;
|
||||
},
|
||||
ref => sub {
|
||||
my ($class, $params) = @_;
|
||||
return bless $params, $class;
|
||||
},
|
||||
ref_copy => sub {
|
||||
my ($class, $params) = @_;
|
||||
my $type = reftype($params);
|
||||
|
||||
return bless {%$params}, $class
|
||||
if $type eq 'HASH';
|
||||
|
||||
return bless [@$params], $class
|
||||
if $type eq 'ARRAY';
|
||||
|
||||
croak "Not sure how to construct an '$class' from '$params'";
|
||||
},
|
||||
);
|
||||
|
||||
sub override_constructor {
|
||||
my $self = shift;
|
||||
my ($name, $type) = @_;
|
||||
$self->_check();
|
||||
|
||||
my $sub = $NEW{$type}
|
||||
|| croak "'$type' is not a known constructor type";
|
||||
|
||||
$self->override($name => $sub);
|
||||
}
|
||||
|
||||
sub add_constructor {
|
||||
my $self = shift;
|
||||
my ($name, $type) = @_;
|
||||
$self->_check();
|
||||
|
||||
my $sub = $NEW{$type}
|
||||
|| croak "'$type' is not a known constructor type";
|
||||
|
||||
$self->add($name => $sub);
|
||||
}
|
||||
|
||||
sub autoload {
|
||||
my $self = shift;
|
||||
$self->_check();
|
||||
my $class = $self->class;
|
||||
my $stash = $self->stash;
|
||||
|
||||
croak "Class '$class' already has an AUTOLOAD"
|
||||
if $stash->{AUTOLOAD} && *{$stash->{AUTOLOAD}}{CODE};
|
||||
croak "Class '$class' already has an can"
|
||||
if $stash->{can} && *{$stash->{can}}{CODE};
|
||||
|
||||
# Weaken this reference so that AUTOLOAD does not prevent its own
|
||||
# destruction.
|
||||
weaken(my $c = $self);
|
||||
|
||||
my ($file, $line) = (__FILE__, __LINE__ + 3);
|
||||
my $autoload = eval <<EOT || die "Failed generating AUTOLOAD sub: $@";
|
||||
package $class;
|
||||
#line $line "$file (Generated AUTOLOAD)"
|
||||
our \$AUTOLOAD;
|
||||
sub {
|
||||
my (\$self) = \@_;
|
||||
my (\$pkg, \$name) = (\$AUTOLOAD =~ m/^(.*)::([^:]+)\$/g);
|
||||
\$AUTOLOAD = undef;
|
||||
|
||||
return if \$name eq 'DESTROY';
|
||||
my \$sub = sub {
|
||||
my \$self = shift;
|
||||
(\$self->{\$name}) = \@_ if \@_;
|
||||
return \$self->{\$name};
|
||||
};
|
||||
|
||||
\$c->add(\$name => \$sub);
|
||||
|
||||
if (\$c->{_track}) {
|
||||
my \$call = {sub_name => \$name, sub_ref => \$sub, args => [\@_]};
|
||||
push \@{\$c->{sub_tracking}->{\$name}} => \$call;
|
||||
push \@{\$c->{call_tracking}} => \$call;
|
||||
}
|
||||
|
||||
goto &\$sub;
|
||||
}
|
||||
EOT
|
||||
|
||||
$line = __LINE__ + 3;
|
||||
my $can = eval <<EOT || die "Failed generating can method: $@";
|
||||
package $class;
|
||||
#line $line "$file (Generated can)"
|
||||
use Scalar::Util 'reftype';
|
||||
sub {
|
||||
my (\$self, \$meth) = \@_;
|
||||
if (\$self->SUPER::can(\$meth)) {
|
||||
return \$self->SUPER::can(\$meth);
|
||||
}
|
||||
elsif (ref \$self && reftype \$self eq 'HASH' && exists \$self->{\$meth}) {
|
||||
return sub { shift->\$meth(\@_) };
|
||||
}
|
||||
return undef;
|
||||
}
|
||||
EOT
|
||||
|
||||
{
|
||||
local $self->{+_TRACK} = 0;
|
||||
$self->add(AUTOLOAD => $autoload);
|
||||
$self->add(can => $can);
|
||||
}
|
||||
}
|
||||
|
||||
sub before {
|
||||
my $self = shift;
|
||||
my ($name, $sub) = @_;
|
||||
$self->_check();
|
||||
my $orig = $self->current($name);
|
||||
$self->_inject({}, $name => sub { $sub->(@_); $orig->(@_) });
|
||||
}
|
||||
|
||||
sub after {
|
||||
my $self = shift;
|
||||
my ($name, $sub) = @_;
|
||||
$self->_check();
|
||||
my $orig = $self->current($name);
|
||||
$self->_inject({}, $name => sub {
|
||||
my @out;
|
||||
|
||||
my $want = wantarray;
|
||||
|
||||
if ($want) {
|
||||
@out = $orig->(@_);
|
||||
}
|
||||
elsif(defined $want) {
|
||||
$out[0] = $orig->(@_);
|
||||
}
|
||||
else {
|
||||
$orig->(@_);
|
||||
}
|
||||
|
||||
$sub->(@_);
|
||||
|
||||
return @out if $want;
|
||||
return $out[0] if defined $want;
|
||||
return;
|
||||
});
|
||||
}
|
||||
|
||||
sub around {
|
||||
my $self = shift;
|
||||
my ($name, $sub) = @_;
|
||||
$self->_check();
|
||||
my $orig = $self->current($name);
|
||||
$self->_inject({}, $name => sub { $sub->($orig, @_) });
|
||||
}
|
||||
|
||||
sub add {
|
||||
my $self = shift;
|
||||
$self->_check();
|
||||
$self->_inject({add => 1}, @_);
|
||||
}
|
||||
|
||||
sub override {
|
||||
my $self = shift;
|
||||
$self->_check();
|
||||
$self->_inject({}, @_);
|
||||
}
|
||||
|
||||
sub set {
|
||||
my $self = shift;
|
||||
$self->_check();
|
||||
$self->_inject({set => 1}, @_);
|
||||
}
|
||||
|
||||
sub current {
|
||||
my $self = shift;
|
||||
my ($sym) = @_;
|
||||
|
||||
return get_symbol($sym, $self->{+CLASS});
|
||||
}
|
||||
|
||||
sub orig {
|
||||
my $self = shift;
|
||||
my ($sym) = @_;
|
||||
|
||||
$sym = "&$sym" unless $sym =~ m/^[&\$\%\@]/;
|
||||
|
||||
my $syms = $self->{+_SYMBOLS}
|
||||
or croak "No symbols have been mocked yet";
|
||||
|
||||
my $ref = $syms->{$sym};
|
||||
|
||||
croak "Symbol '$sym' is not mocked"
|
||||
unless $ref && @$ref;
|
||||
|
||||
my ($orig) = @$ref;
|
||||
|
||||
return $orig;
|
||||
}
|
||||
|
||||
sub track {
|
||||
my $self = shift;
|
||||
|
||||
($self->{+_TRACK}) = @_ if @_;
|
||||
|
||||
return $self->{+_TRACK};
|
||||
}
|
||||
|
||||
sub clear_call_tracking { @{shift->{+CALL_TRACKING}} = () }
|
||||
|
||||
sub clear_sub_tracking {
|
||||
my $self = shift;
|
||||
|
||||
unless (@_) {
|
||||
%{$self->{+SUB_TRACKING}} = ();
|
||||
return;
|
||||
}
|
||||
|
||||
for my $item (@_) {
|
||||
delete $self->{+SUB_TRACKING}->{$item};
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _parse_inject {
|
||||
my $self = shift;
|
||||
my ($param, $arg) = @_;
|
||||
|
||||
if ($param =~ m/^-(.*)$/) {
|
||||
my $sym = $1;
|
||||
my $sig = slot_to_sig(reftype($arg));
|
||||
my $ref = $arg;
|
||||
return ($sig, $sym, $ref);
|
||||
}
|
||||
|
||||
return ('&', $param, $arg)
|
||||
if ref($arg) && reftype($arg) eq 'CODE';
|
||||
|
||||
my ($is, $field, $val);
|
||||
|
||||
if(defined($arg) && !ref($arg) && $arg =~ m/^(rw|ro|wo)$/) {
|
||||
$is = $arg;
|
||||
$field = $param;
|
||||
}
|
||||
elsif (!ref($arg)) {
|
||||
$val = $arg;
|
||||
$is = 'val';
|
||||
}
|
||||
elsif (reftype($arg) eq 'HASH') {
|
||||
$field = delete $arg->{field} || $param;
|
||||
|
||||
$val = delete $arg->{val};
|
||||
$is = delete $arg->{is};
|
||||
|
||||
croak "Cannot specify 'is' and 'val' together" if $val && $is;
|
||||
|
||||
$is ||= $val ? 'val' : 'rw';
|
||||
|
||||
croak "The following keys are not valid when defining a mocked sub with a hashref: " . join(", " => keys %$arg)
|
||||
if keys %$arg;
|
||||
}
|
||||
else {
|
||||
confess "'$arg' is not a valid argument when defining a mocked sub";
|
||||
}
|
||||
|
||||
my $sub;
|
||||
if ($is eq 'rw') {
|
||||
$sub = gen_accessor($field);
|
||||
}
|
||||
elsif ($is eq 'ro') {
|
||||
$sub = gen_reader($field);
|
||||
}
|
||||
elsif ($is eq 'wo') {
|
||||
$sub = gen_writer($field);
|
||||
}
|
||||
else { # val
|
||||
$sub = sub { $val };
|
||||
}
|
||||
|
||||
return ('&', $param, $sub);
|
||||
}
|
||||
|
||||
sub _inject {
|
||||
my $self = shift;
|
||||
my ($params, @pairs) = @_;
|
||||
|
||||
my $add = $params->{add};
|
||||
my $set = $params->{set};
|
||||
|
||||
my $class = $self->{+CLASS};
|
||||
|
||||
$self->{+_SYMBOLS} ||= {};
|
||||
my $syms = $self->{+_SYMBOLS};
|
||||
|
||||
while (my $param = shift @pairs) {
|
||||
my $arg = shift @pairs;
|
||||
my ($sig, $sym, $ref) = $self->_parse_inject($param, $arg);
|
||||
my $orig = $self->current("$sig$sym");
|
||||
|
||||
croak "Cannot override '$sig$class\::$sym', symbol is not already defined"
|
||||
unless $orig || $add || $set || ($sig eq '&' && $class->can($sym));
|
||||
|
||||
# Cannot be too sure about scalars in globs
|
||||
croak "Cannot add '$sig$class\::$sym', symbol is already defined"
|
||||
if $add && $orig
|
||||
&& (reftype($orig) ne 'SCALAR' || defined($$orig));
|
||||
|
||||
$syms->{"$sig$sym"} ||= [];
|
||||
push @{$syms->{"$sig$sym"}} => $orig; # Might be undef, thats expected
|
||||
|
||||
if ($self->{+_TRACK} && $sig eq '&') {
|
||||
my $sub_tracker = $self->{+SUB_TRACKING};
|
||||
my $call_tracker = $self->{+CALL_TRACKING};
|
||||
my $sub = $ref;
|
||||
$ref = sub {
|
||||
my $call = {sub_name => $sym, sub_ref => $sub, args => [@_]};
|
||||
push @{$sub_tracker->{$param}} => $call;
|
||||
push @$call_tracker => $call;
|
||||
goto &$sub;
|
||||
};
|
||||
}
|
||||
|
||||
no strict 'refs';
|
||||
no warnings 'redefine';
|
||||
*{"$class\::$sym"} = $ref;
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _set_or_unset {
|
||||
my $self = shift;
|
||||
my ($symbol, $set) = @_;
|
||||
|
||||
my $class = $self->{+CLASS};
|
||||
|
||||
return purge_symbol($symbol, $class)
|
||||
unless $set;
|
||||
|
||||
my $sym = parse_symbol($symbol, $class);
|
||||
no strict 'refs';
|
||||
no warnings 'redefine';
|
||||
*{"$class\::$sym->{name}"} = $set;
|
||||
}
|
||||
|
||||
sub restore {
|
||||
my $self = shift;
|
||||
my ($sym) = @_;
|
||||
$self->_check();
|
||||
|
||||
$sym = "&$sym" unless $sym =~ m/^[&\$\%\@]/;
|
||||
|
||||
my $syms = $self->{+_SYMBOLS}
|
||||
or croak "No symbols are mocked";
|
||||
|
||||
my $ref = $syms->{$sym};
|
||||
|
||||
croak "Symbol '$sym' is not mocked"
|
||||
unless $ref && @$ref;
|
||||
|
||||
my $old = pop @$ref;
|
||||
delete $syms->{$sym} unless @$ref;
|
||||
|
||||
return $self->_set_or_unset($sym, $old);
|
||||
}
|
||||
|
||||
sub reset {
|
||||
my $self = shift;
|
||||
my ($sym) = @_;
|
||||
$self->_check();
|
||||
|
||||
$sym = "&$sym" unless $sym =~ m/^[&\$\%\@]/;
|
||||
|
||||
my $syms = $self->{+_SYMBOLS}
|
||||
or croak "No symbols are mocked";
|
||||
|
||||
my $ref = delete $syms->{$sym};
|
||||
|
||||
croak "Symbol '$sym' is not mocked"
|
||||
unless $ref && @$ref;
|
||||
|
||||
my ($old) = @$ref;
|
||||
|
||||
return $self->_set_or_unset($sym, $old);
|
||||
}
|
||||
|
||||
sub reset_all {
|
||||
my $self = shift;
|
||||
$self->_check();
|
||||
|
||||
my $syms = $self->{+_SYMBOLS} || return;
|
||||
|
||||
$self->reset($_) for keys %$syms;
|
||||
|
||||
delete $self->{+_SYMBOLS};
|
||||
}
|
||||
|
||||
sub _purge {
|
||||
my $self = shift;
|
||||
my $stash = $self->stash;
|
||||
delete $stash->{$_} for keys %$stash;
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
|
||||
delete $self->{+CHILD};
|
||||
$self->reset_all if $self->{+_SYMBOLS};
|
||||
|
||||
delete $INC{$self->file} if $self->{+_BLOCKED_LOAD};
|
||||
|
||||
$self->_purge if $self->{+_PURGE_ON_DESTROY};
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Mock - Module for managing mocked classes and instances.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module lets you add and override methods for any package temporarily. When
|
||||
the instance is destroyed it will restore the package to its original state.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Mock;
|
||||
use MyClass;
|
||||
|
||||
my $mock = Test2::Mock->new(
|
||||
track => $BOOL, # enable call tracking if desired
|
||||
class => 'MyClass',
|
||||
override => [
|
||||
name => sub { 'fred' },
|
||||
...
|
||||
],
|
||||
add => [
|
||||
is_mocked => sub { 1 }
|
||||
...
|
||||
],
|
||||
...
|
||||
);
|
||||
|
||||
# Unmock the 'name' sub
|
||||
$mock->restore('name');
|
||||
|
||||
...
|
||||
|
||||
$mock = undef; # Will remove all the mocking
|
||||
|
||||
=head1 CONSTRUCTION
|
||||
|
||||
=head1 METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $mock = Test2::Mock->new(class => $CLASS, ...)
|
||||
|
||||
This will create a new instance of L<Test2::Mock> that manages mocking
|
||||
for the specified C<$CLASS>.
|
||||
|
||||
Any C<Test2::Mock> method can be used as a constructor argument, each
|
||||
should be followed by an arrayref of arguments to be used within the method. For
|
||||
instance the C<add()> method:
|
||||
|
||||
my $mock = Test2::Mock->new(
|
||||
class => 'AClass',
|
||||
add => [foo => sub { 'foo' }],
|
||||
);
|
||||
|
||||
is identical to this:
|
||||
|
||||
my $mock = Test2::Mock->new(
|
||||
class => 'AClass',
|
||||
);
|
||||
$mock->add(foo => sub { 'foo' });
|
||||
|
||||
=item $mock->track($bool)
|
||||
|
||||
Turn tracking on or off. Any sub added/overridden/set when tracking is on will
|
||||
log every call in a hash retrievable via C<< $mock->tracking >>. Changing the
|
||||
tracking toggle will not affect subs already altered, but will affect any
|
||||
additional alterations.
|
||||
|
||||
=item $hashref = $mock->sub_tracking
|
||||
|
||||
The tracking data looks like this:
|
||||
|
||||
{
|
||||
sub_name => [
|
||||
{sub_name => $sub_name, sub_ref => $mock_subref, args => [... copy of @_ from the call ... ]},
|
||||
...,
|
||||
...,
|
||||
],
|
||||
}
|
||||
|
||||
Unlike call_tracking, this lists all calls by sub, so you can choose to only
|
||||
look at the sub specific calls.
|
||||
|
||||
B<Please note:> The hashref items with the subname and args are shared with
|
||||
call_tracking, modifying one modifies the other, so copy first!
|
||||
|
||||
=item $arrayref = $mock->call_tracking
|
||||
|
||||
The tracking data looks like this:
|
||||
|
||||
[
|
||||
{sub_name => $sub_name, sub_ref => $mock_subref, args => [... copy of @_ from the call ... ]},
|
||||
...,
|
||||
...,
|
||||
]
|
||||
|
||||
Unlike sub_tracking this lists all calls to any mocked sub, in the order they
|
||||
were called. To filter by sub use sub_tracking.
|
||||
|
||||
B<Please note:> The hashref items with the subname and args are shared with
|
||||
sub_tracking, modifying one modifies the other, so copy first!
|
||||
|
||||
=item $mock->clear_sub_tracking()
|
||||
|
||||
=item $mock->clear_sub_tracking(\@subnames)
|
||||
|
||||
Clear tracking data. With no arguments ALL tracking data is cleared. When
|
||||
arguments are provided then only those specific keys will be cleared.
|
||||
|
||||
=item $mock->clear_call_tracking()
|
||||
|
||||
Clear all items from call_tracking.
|
||||
|
||||
=item $mock->add('symbol' => ..., 'symbol2' => ...)
|
||||
|
||||
=item $mock->override('symbol1' => ..., 'symbol2' => ...)
|
||||
|
||||
=item $mock->set('symbol1' => ..., 'symbol2' => ...)
|
||||
|
||||
C<add()> and C<override()> are the primary ways to add/modify methods for a
|
||||
class. Both accept the exact same type of arguments. The difference is that
|
||||
C<override> will fail unless the symbol you are overriding already exists,
|
||||
C<add> on the other hand will fail if the symbol does already exist.
|
||||
|
||||
C<set()> was more recently added for cases where you may not know if the sub
|
||||
already exists. These cases are rare, and set should be avoided (think of it
|
||||
like 'no strict'). However there are valid use cases, so it was added.
|
||||
|
||||
B<Note:> Think of override as a push operation. If you call override on the
|
||||
same symbol multiple times it will track that. You can use C<restore()> as a
|
||||
pop operation to go back to the previous mock. C<reset> can be used to remove
|
||||
all the mocking for a symbol.
|
||||
|
||||
Arguments must be a symbol name, with optional sigil, followed by a new
|
||||
specification of the symbol. If no sigil is specified then '&' (sub) is
|
||||
assumed. A simple example of overriding a sub:
|
||||
|
||||
$mock->override(foo => sub { 'overridden foo' });
|
||||
my $val = $class->foo; # Runs our override
|
||||
# $val is now set to 'overridden foo'
|
||||
|
||||
You can also simply provide a value and it will be wrapped in a sub for you:
|
||||
|
||||
$mock->override( foo => 'foo' );
|
||||
|
||||
The example above will generate a sub that always returns the string 'foo'.
|
||||
|
||||
There are three *special* values that can be used to generate accessors:
|
||||
|
||||
$mock->add(
|
||||
name => 'rw', # Generates a read/write accessor
|
||||
age => 'ro', # Generates a read only accessor
|
||||
size => 'wo', # Generates a write only accessor
|
||||
);
|
||||
|
||||
If you want to have a sub that actually returns one of the three special strings, or
|
||||
that returns a coderef, you can use a hashref as the spec:
|
||||
|
||||
my $ref = sub { 'my sub' };
|
||||
$mock->add(
|
||||
rw_string => { val => 'rw' },
|
||||
ro_string => { val => 'ro' },
|
||||
wo_string => { val => 'wo' },
|
||||
coderef => { val => $ref }, # the coderef method returns $ref each time
|
||||
);
|
||||
|
||||
You can also override/add other symbol types, such as hash:
|
||||
|
||||
package Foo;
|
||||
...
|
||||
|
||||
$mock->add('%foo' => {a => 1});
|
||||
|
||||
print $Foo::foo{a}; # prints '1'
|
||||
|
||||
You can also tell mock to deduce the symbol type for the add/override from the
|
||||
reference, rules are similar to glob assignments:
|
||||
|
||||
$mock->add(
|
||||
-foo => sub { 'foo' }, # Adds the &foo sub to the package
|
||||
-foo => { foo => 1 }, # Adds the %foo hash to the package
|
||||
-foo => [ 'f', 'o', 'o' ], # Adds the @foo array to the package
|
||||
-foo => \"foo", # Adds the $foo scalar to the package
|
||||
);
|
||||
|
||||
=item $mock->restore($SYMBOL)
|
||||
|
||||
Restore the symbol to what it was before the last override. If the symbol was
|
||||
recently added this will remove it. If the symbol has been overridden multiple
|
||||
times this will ONLY restore it to the previous state. Think of C<override> as a
|
||||
push operation, and C<restore> as the pop operation.
|
||||
|
||||
=item $mock->reset($SYMBOL)
|
||||
|
||||
Remove all mocking of the symbol and restore the original symbol. If the symbol
|
||||
was initially added then it will be completely removed.
|
||||
|
||||
=item $mock->orig($SYMBOL)
|
||||
|
||||
This will return the original symbol, before any mocking. For symbols that were
|
||||
added this will return undef.
|
||||
|
||||
=item $mock->current($SYMBOL)
|
||||
|
||||
This will return the current symbol.
|
||||
|
||||
=item $mock->reset_all
|
||||
|
||||
Remove all added symbols, and restore all overridden symbols to their originals.
|
||||
|
||||
=item $mock->add_constructor($NAME => $TYPE)
|
||||
|
||||
=item $mock->override_constructor($NAME => $TYPE)
|
||||
|
||||
This can be used to inject constructors. The first argument should be the name
|
||||
of the constructor. The second argument specifies the constructor type.
|
||||
|
||||
The C<hash> type is the most common, all arguments are used to create a new
|
||||
hash that is blessed.
|
||||
|
||||
hash => sub {
|
||||
my ($class, %params) = @_;
|
||||
return bless \%params, $class;
|
||||
};
|
||||
|
||||
The C<array> type is similar to the hash type, but accepts a list instead of
|
||||
key/value pairs:
|
||||
|
||||
array => sub {
|
||||
my ($class, @params) = @_;
|
||||
return bless \@params, $class;
|
||||
};
|
||||
|
||||
The C<ref> type takes a reference and blesses it. This will modify your
|
||||
original input argument.
|
||||
|
||||
ref => sub {
|
||||
my ($class, $params) = @_;
|
||||
return bless $params, $class;
|
||||
};
|
||||
|
||||
The C<ref_copy> type will copy your reference and bless the copy:
|
||||
|
||||
ref_copy => sub {
|
||||
my ($class, $params) = @_;
|
||||
my $type = reftype($params);
|
||||
|
||||
return bless {%$params}, $class
|
||||
if $type eq 'HASH';
|
||||
|
||||
return bless [@$params], $class
|
||||
if $type eq 'ARRAY';
|
||||
|
||||
croak "Not sure how to construct a '$class' from '$params'";
|
||||
};
|
||||
|
||||
=item $mock->before($NAME, sub { ... })
|
||||
|
||||
This will replace the original sub C<$NAME> with a new sub that calls your
|
||||
custom code just before calling the original method. The return from your
|
||||
custom sub is ignored. Your sub and the original both get the unmodified
|
||||
arguments.
|
||||
|
||||
=item $mock->after($NAME, sub { ... })
|
||||
|
||||
This is similar to before, except your callback runs after the original code.
|
||||
The return from your callback is ignored.
|
||||
|
||||
=item $mock->around($NAME, sub { ... })
|
||||
|
||||
This gives you the chance to wrap the original sub:
|
||||
|
||||
$mock->around(foo => sub {
|
||||
my $orig = shift;
|
||||
my $self = shift;
|
||||
my (@args) = @_;
|
||||
|
||||
...
|
||||
$self->$orig(@args);
|
||||
...
|
||||
|
||||
return ...;
|
||||
});
|
||||
|
||||
The original sub is passed in as the first argument, even before C<$self>. You
|
||||
are responsible for making sure your wrapper sub returns the correct thing.
|
||||
|
||||
=item $mock->autoload
|
||||
|
||||
This will inject an C<AUTOLOAD> sub into the class. This autoload will
|
||||
automatically generate read-write accessors for any sub called that does not
|
||||
already exist.
|
||||
|
||||
=item $mock->block_load
|
||||
|
||||
This will prevent the real class from loading until the mock is destroyed. This
|
||||
will fail if the class is already loaded. This will let you mock a class
|
||||
completely without loading the original module.
|
||||
|
||||
=item $pm_file = $mock->file
|
||||
|
||||
This returns the relative path to the file for the module. This corresponds to
|
||||
the C<%INC> entry.
|
||||
|
||||
=item $bool = $mock->purge_on_destroy($bool)
|
||||
|
||||
When true, this will cause the package stash to be completely obliterated when
|
||||
the mock object falls out of scope or is otherwise destroyed. You do not
|
||||
normally want this.
|
||||
|
||||
=item $stash = $mock->stash
|
||||
|
||||
This returns the stash for the class being mocked. This is the equivalent of:
|
||||
|
||||
my $stash = \%{"${class}\::"};
|
||||
|
||||
This saves you from needing to turn off strict.
|
||||
|
||||
=item $class = $mock->class
|
||||
|
||||
The class being mocked by this instance.
|
||||
|
||||
=item $p = $mock->parent
|
||||
|
||||
If you mock a class twice the first instance is the parent, the second is the
|
||||
child. This prevents the parent from being destroyed before the child, which
|
||||
would lead to a very unpleasant situation.
|
||||
|
||||
=item $c = $mock->child
|
||||
|
||||
Returns the child mock, if any.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2-Suite can be found at
|
||||
L<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 L<https://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
81
database/perl/vendor/lib/Test2/Plugin.pm
vendored
Normal file
81
database/perl/vendor/lib/Test2/Plugin.pm
vendored
Normal file
@@ -0,0 +1,81 @@
|
||||
package Test2::Plugin;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Plugin - Documentation for plugins
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Plugins are packages that cause behavior changes, or other side effects for the
|
||||
test file that loads them. They should not export any functions, or provide any
|
||||
tools. Plugins should be distinct units of functionality.
|
||||
|
||||
If you wish to combine behavior changes with tools then you should write a
|
||||
Plugin, a Tools module, and a bundle that loads them both.
|
||||
|
||||
=head1 FAQ
|
||||
|
||||
=over 4
|
||||
|
||||
=item Should I subclass Test2::Plugin?
|
||||
|
||||
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 PLUGIN?
|
||||
|
||||
Writing a plugin is not as simple as writing an L<Test2::Bundle>, or writing
|
||||
L<Test2::Tools>. Plugins alter behavior, or cause desirable side-effects. To
|
||||
accomplish this you typically need a custom C<import()> method that calls one
|
||||
or more functions provided by the L<Test2::API> package.
|
||||
|
||||
If you want to write a plugin you should look at existing plugins, as well as
|
||||
the L<Test2::API> and L<Test2::Hub> documentation. There is no formula for a
|
||||
Plugin, they are generally unique, however consistent rules are that they
|
||||
should not load other plugins, or export any functions.
|
||||
|
||||
=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
|
||||
80
database/perl/vendor/lib/Test2/Plugin/BailOnFail.pm
vendored
Normal file
80
database/perl/vendor/lib/Test2/Plugin/BailOnFail.pm
vendored
Normal file
@@ -0,0 +1,80 @@
|
||||
package Test2::Plugin::BailOnFail;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::API qw/test2_add_callback_context_release/;
|
||||
|
||||
my $LOADED = 0;
|
||||
sub import {
|
||||
return if $LOADED++;
|
||||
|
||||
test2_add_callback_context_release(sub {
|
||||
my $ctx = shift;
|
||||
return if $ctx->hub->is_passing;
|
||||
$ctx->bail("(Bail On Fail)");
|
||||
});
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Plugin::BailOnFail - Automatically bail out of testing on the first test
|
||||
failure.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module will issue a bailout event after the first test failure. This will
|
||||
prevent your tests from continuing. The bailout runs when the context is
|
||||
released; that is, it will run when the test function you are using, such as
|
||||
C<ok()>, returns. This gives the tools the ability to output any extra
|
||||
diagnostics they may need.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::V0;
|
||||
use Test2::Plugin::BailOnFail;
|
||||
|
||||
ok(1, "pass");
|
||||
ok(0, "fail");
|
||||
ok(1, "Will not 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
|
||||
78
database/perl/vendor/lib/Test2/Plugin/DieOnFail.pm
vendored
Normal file
78
database/perl/vendor/lib/Test2/Plugin/DieOnFail.pm
vendored
Normal file
@@ -0,0 +1,78 @@
|
||||
package Test2::Plugin::DieOnFail;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::API qw/test2_add_callback_context_release/;
|
||||
|
||||
my $LOADED = 0;
|
||||
sub import {
|
||||
return if $LOADED++;
|
||||
|
||||
test2_add_callback_context_release(sub {
|
||||
my $ctx = shift;
|
||||
return if $ctx->hub->is_passing;
|
||||
$ctx->throw("(Die On Fail)");
|
||||
});
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Plugin::DieOnFail - Automatically die on the first test failure.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module will die after the first test failure. This will prevent your tests
|
||||
from continuing. The exception is thrown when the context is released, that is
|
||||
it will run when the test function you are using, such as C<ok()>, returns.
|
||||
This gives the tools the ability to output any extra diagnostics they may need.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::V0;
|
||||
use Test2::Plugin::DieOnFail;
|
||||
|
||||
ok(1, "pass");
|
||||
ok(0, "fail");
|
||||
ok(1, "Will not 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
|
||||
90
database/perl/vendor/lib/Test2/Plugin/ExitSummary.pm
vendored
Normal file
90
database/perl/vendor/lib/Test2/Plugin/ExitSummary.pm
vendored
Normal file
@@ -0,0 +1,90 @@
|
||||
package Test2::Plugin::ExitSummary;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::API qw/test2_add_callback_exit/;
|
||||
|
||||
my $ADDED_HOOK = 0;
|
||||
sub import { test2_add_callback_exit(\&summary) unless $ADDED_HOOK++ }
|
||||
|
||||
sub active { $ADDED_HOOK }
|
||||
|
||||
sub summary {
|
||||
my ($ctx, $real, $new) = @_;
|
||||
|
||||
# Avoid double-printing diagnostics if Test::Builder already loaded.
|
||||
return if $INC{'Test/Builder.pm'};
|
||||
|
||||
my $hub = $ctx->hub;
|
||||
my $plan = $hub->plan;
|
||||
my $count = $hub->count;
|
||||
my $failed = $hub->failed;
|
||||
|
||||
$ctx->diag('No tests run!') if !$count && (!$plan || $plan ne 'SKIP');
|
||||
$ctx->diag('Tests were run but no plan was declared and done_testing() was not seen.')
|
||||
if $count && !$plan;
|
||||
|
||||
$ctx->diag("Looks like your test exited with $real after test #$count.")
|
||||
if $real;
|
||||
|
||||
$ctx->diag("Did not follow plan: expected $plan, ran $count.")
|
||||
if $plan && $plan =~ m/^[0-9]+$/ && defined $count && $count != $plan;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Plugin::ExitSummary - Add extra diagnostics on failure at the end of the
|
||||
test.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This will provide some diagnostics after a failed test. These diagnostics can
|
||||
range from telling you how you deviated from your plan, warning you if there
|
||||
was no plan, etc. People used to L<Test::More> generally expect these
|
||||
diagnostics.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Plugin::ExitSummary;
|
||||
|
||||
=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
|
||||
154
database/perl/vendor/lib/Test2/Plugin/NoWarnings.pm
vendored
Normal file
154
database/perl/vendor/lib/Test2/Plugin/NoWarnings.pm
vendored
Normal file
@@ -0,0 +1,154 @@
|
||||
package Test2::Plugin::NoWarnings;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.09';
|
||||
|
||||
# This is the version that added test2_is_testing_done.
|
||||
use Test2 1.302167;
|
||||
use Test2::API qw( context_do test2_is_testing_done );
|
||||
use Test2::Event::Warning;
|
||||
|
||||
my $echo = 0;
|
||||
|
||||
sub import {
|
||||
shift;
|
||||
my %args = @_;
|
||||
$echo = $args{echo} if exists $args{echo};
|
||||
return;
|
||||
}
|
||||
|
||||
my $_orig_warn_handler = $SIG{__WARN__};
|
||||
## no critic (Variables::RequireLocalizedPunctuationVars)
|
||||
$SIG{__WARN__} = sub {
|
||||
unless ( test2_is_testing_done() ) {
|
||||
my $w = $_[0];
|
||||
$w =~ s/\n+$//g;
|
||||
|
||||
context_do {
|
||||
my $ctx = shift;
|
||||
$ctx->send_event(
|
||||
'Warning',
|
||||
warning => "Unexpected warning: $w",
|
||||
);
|
||||
}
|
||||
$_[0];
|
||||
|
||||
return unless $echo;
|
||||
}
|
||||
|
||||
return if $_orig_warn_handler && $_orig_warn_handler eq 'IGNORE';
|
||||
|
||||
# The rest was copied from Test::Warnings
|
||||
|
||||
# TODO: this doesn't handle blessed coderefs... does anyone care?
|
||||
goto &$_orig_warn_handler
|
||||
if $_orig_warn_handler
|
||||
and (
|
||||
( ref $_orig_warn_handler eq 'CODE' )
|
||||
or ( $_orig_warn_handler ne 'DEFAULT'
|
||||
and $_orig_warn_handler ne 'IGNORE'
|
||||
and defined &$_orig_warn_handler )
|
||||
);
|
||||
|
||||
if ( $_[0] =~ /\n$/ ) {
|
||||
warn $_[0];
|
||||
}
|
||||
else {
|
||||
require Carp;
|
||||
Carp::carp( $_[0] );
|
||||
}
|
||||
};
|
||||
|
||||
1;
|
||||
|
||||
# ABSTRACT: Fail if tests warn
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Plugin::NoWarnings - Fail if tests warn
|
||||
|
||||
=head1 VERSION
|
||||
|
||||
version 0.09
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::V0;
|
||||
use Test2::Plugin::NoWarnings;
|
||||
|
||||
...;
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Loading this plugin causes your tests to fail if there any warnings while they
|
||||
run. Each warning generates a new failing test and the warning content is
|
||||
outputted via C<diag>.
|
||||
|
||||
This module uses C<$SIG{__WARN__}>, so if the code you're testing sets this,
|
||||
then this module will stop working.
|
||||
|
||||
=head1 ECHOING WARNINGS
|
||||
|
||||
By default, this module suppresses the warning itself so it does not go to
|
||||
C<STDERR>. If you'd like to also have the warning go to C<STDERR> untouched,
|
||||
you can ask for this with the C<echo> import argument:
|
||||
|
||||
use Test2::Plugin::NoWarnings echo => 1;
|
||||
|
||||
=head1 SUPPORT
|
||||
|
||||
Bugs may be submitted at L<https://github.com/houseabsolute/Test2-Plugin-NoWarnings/issues>.
|
||||
|
||||
I am also usually active on IRC as 'autarch' on C<irc://irc.perl.org>.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2-Plugin-NoWarnings can be found at L<https://github.com/houseabsolute/Test2-Plugin-NoWarnings>.
|
||||
|
||||
=head1 DONATIONS
|
||||
|
||||
If you'd like to thank me for the work I've done on this module, please
|
||||
consider making a "donation" to me via PayPal. I spend a lot of free time
|
||||
creating free software, and would appreciate any support you'd care to offer.
|
||||
|
||||
Please note that B<I am not suggesting that you must do this> in order for me
|
||||
to continue working on this particular software. I will continue to do so,
|
||||
inasmuch as I have in the past, for as long as it interests me.
|
||||
|
||||
Similarly, a donation made in this way will probably not make me work on this
|
||||
software much more, unless I get so many donations that I can consider working
|
||||
on free software full time (let's all have a chuckle at that together).
|
||||
|
||||
To donate, log into PayPal and send money to autarch@urth.org, or use the
|
||||
button at L<https://www.urth.org/fs-donation.html>.
|
||||
|
||||
=head1 AUTHOR
|
||||
|
||||
Dave Rolsky <autarch@urth.org>
|
||||
|
||||
=head1 CONTRIBUTOR
|
||||
|
||||
=for stopwords Michael Alan Dorman
|
||||
|
||||
Michael Alan Dorman <mdorman@ironicdesign.com>
|
||||
|
||||
=head1 COPYRIGHT AND LICENSE
|
||||
|
||||
This software is Copyright (c) 2020 by Dave Rolsky.
|
||||
|
||||
This is free software, licensed under:
|
||||
|
||||
The Artistic License 2.0 (GPL Compatible)
|
||||
|
||||
The full text of the license can be found in the
|
||||
F<LICENSE> file included with this distribution.
|
||||
|
||||
=cut
|
||||
161
database/perl/vendor/lib/Test2/Plugin/SRand.pm
vendored
Normal file
161
database/perl/vendor/lib/Test2/Plugin/SRand.pm
vendored
Normal file
@@ -0,0 +1,161 @@
|
||||
package Test2::Plugin::SRand;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Carp qw/carp/;
|
||||
|
||||
use Test2::API qw{
|
||||
context
|
||||
test2_add_callback_post_load
|
||||
test2_add_callback_exit
|
||||
test2_stack
|
||||
};
|
||||
|
||||
my $ADDED_HOOK = 0;
|
||||
my $SEED;
|
||||
my $FROM;
|
||||
|
||||
sub seed { $SEED }
|
||||
sub from { $FROM }
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
|
||||
carp "SRand loaded multiple times, re-seeding rand"
|
||||
if defined $SEED;
|
||||
|
||||
if (@_ == 1) {
|
||||
($SEED) = @_;
|
||||
$FROM = 'import arg';
|
||||
}
|
||||
elsif (@_ == 2 and $_[0] eq 'seed') {
|
||||
$SEED = $_[1];
|
||||
$FROM = 'import arg';
|
||||
}
|
||||
elsif(exists $ENV{T2_RAND_SEED}) {
|
||||
$SEED = $ENV{T2_RAND_SEED};
|
||||
$FROM = 'environment variable';
|
||||
}
|
||||
else {
|
||||
my @ltime = localtime;
|
||||
# Yes, this would be an awful seed if you actually wanted randomness.
|
||||
# The idea here is that we want "random" behavior to be predictable
|
||||
# within a given day. This allows you to reproduce failures that may or
|
||||
# may not happen due to randomness.
|
||||
$SEED = sprintf('%04d%02d%02d', 1900 + $ltime[5], 1 + $ltime[4], $ltime[3]);
|
||||
$FROM = 'local date';
|
||||
}
|
||||
|
||||
$SEED = 0 unless $SEED;
|
||||
srand($SEED);
|
||||
|
||||
if ($ENV{HARNESS_IS_VERBOSE} || !$ENV{HARNESS_ACTIVE}) {
|
||||
# If the harness is verbose then just display the message for all to
|
||||
# see. It is nice info and they already asked for noisy output.
|
||||
|
||||
test2_add_callback_post_load(sub {
|
||||
test2_stack()->top; # Ensure we have at least 1 hub.
|
||||
my ($hub) = test2_stack()->all;
|
||||
$hub->send(
|
||||
Test2::Event::Note->new(
|
||||
trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__, 'SRAND']),
|
||||
message => "Seeded srand with seed '$SEED' from $FROM.",
|
||||
)
|
||||
);
|
||||
});
|
||||
}
|
||||
elsif (!$ADDED_HOOK++) {
|
||||
# The seed can be important for debugging, so if anything is wrong we
|
||||
# should output the seed message as a diagnostics message. This must be
|
||||
# done at the very end, even later than a hub hook.
|
||||
test2_add_callback_exit(
|
||||
sub {
|
||||
my ($ctx, $real, $new) = @_;
|
||||
|
||||
$ctx->diag("Seeded srand with seed '$SEED' from $FROM.")
|
||||
if $real
|
||||
|| ($new && $$new)
|
||||
|| !$ctx->hub->is_passing;
|
||||
}
|
||||
);
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Plugin::SRand - Control the random seed for more controlled test
|
||||
environments.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module gives you control over the random seed used for your unit tests. In
|
||||
some testing environments the random seed can play a major role in results.
|
||||
|
||||
The default configuration for this module will seed srand with the local date.
|
||||
Using the date as the seed means that on any given day the random seed will
|
||||
always be the same, this means behavior will not change from run to run on a
|
||||
given day. However the seed is different on different days allowing you to be
|
||||
sure the code still works with actual randomness.
|
||||
|
||||
The seed is printed for you on failure, or when the harness is verbose. You can
|
||||
use the C<T2_RAND_SEED> environment variable to specify the seed. You can also
|
||||
provide a specific seed as a load-time argument to the plugin.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
Loading the plugin is easy, and the defaults are sane:
|
||||
|
||||
use Test2::Plugin::SRand;
|
||||
|
||||
Custom seed:
|
||||
|
||||
use Test2::Plugin::SRand seed => 42;
|
||||
|
||||
=head1 NOTE ON LOAD ORDER
|
||||
|
||||
If you use this plugin you probably want to use it as the first, or near-first
|
||||
plugin. C<srand> is not called until the plugin is loaded, so other plugins
|
||||
loaded first may already be making use of random numbers before your seed
|
||||
takes effect.
|
||||
|
||||
=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
|
||||
129
database/perl/vendor/lib/Test2/Plugin/Times.pm
vendored
Normal file
129
database/perl/vendor/lib/Test2/Plugin/Times.pm
vendored
Normal file
@@ -0,0 +1,129 @@
|
||||
package Test2::Plugin::Times;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test2::Util::Times qw/render_bench render_duration/;
|
||||
|
||||
use Test2::API qw{
|
||||
test2_add_callback_exit
|
||||
};
|
||||
|
||||
use Time::HiRes qw/time/;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
my $ADDED_HOOK = 0;
|
||||
my $START;
|
||||
sub import {
|
||||
return if $ADDED_HOOK++;
|
||||
|
||||
$START = time;
|
||||
test2_add_callback_exit(\&send_time_event);
|
||||
}
|
||||
|
||||
sub send_time_event {
|
||||
my ($ctx, $real, $new) = @_;
|
||||
my $stop = time;
|
||||
my @times = times();
|
||||
|
||||
my $summary = render_bench($START, $stop, @times);
|
||||
my $duration = render_duration($START, $stop);
|
||||
|
||||
my $e = $ctx->send_ev2(
|
||||
about => {package => __PACKAGE__, details => $summary},
|
||||
info => [{tag => 'TIME', details => $summary}],
|
||||
times => {
|
||||
details => $summary,
|
||||
start => $START,
|
||||
stop => $stop,
|
||||
user => $times[0],
|
||||
sys => $times[1],
|
||||
cuser => $times[2],
|
||||
csys => $times[3],
|
||||
},
|
||||
harness_job_fields => [
|
||||
{name => "time_duration", details => $duration},
|
||||
{name => "time_user", details => $times[0]},
|
||||
{name => "time_sys", details => $times[1]},
|
||||
{name => "time_cuser", details => $times[2]},
|
||||
{name => "time_csys", details => $times[3]},
|
||||
],
|
||||
);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Plugin::Times - Output timing data at the end of the test.
|
||||
|
||||
=head1 CAVEAT
|
||||
|
||||
It is important to note that this timing data does not include global
|
||||
destruction. This data is only collected up until the point done_testing() is
|
||||
called. If your program takes time for END blocks, garbage collection, and
|
||||
similar, then this timing data will fall short of reality.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This plugin will output a diagnostics message at the end of testing that tells
|
||||
you how much time elapsed, and how hard the system worked on the test.
|
||||
|
||||
This will produce a string like one of these (Note these numbers are completely
|
||||
made up). I<Which string is used depends on the time elapsed.>
|
||||
|
||||
0.12345s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU)
|
||||
|
||||
11.1234s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU)
|
||||
|
||||
01m:54.45s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU)
|
||||
|
||||
18h:22m:54.45s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU)
|
||||
|
||||
04d:18h:22m:54.45s on wallclock (0.05 usr 0.00 sys + 0.00 cusr 0.00 csys = 0.05 CPU)
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Plugin::Times;
|
||||
|
||||
This is also useful at the command line for 1-time use:
|
||||
|
||||
$ perl -MTest2::Plugin::Times path/to/test.t
|
||||
|
||||
=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
|
||||
132
database/perl/vendor/lib/Test2/Plugin/UTF8.pm
vendored
Normal file
132
database/perl/vendor/lib/Test2/Plugin/UTF8.pm
vendored
Normal file
@@ -0,0 +1,132 @@
|
||||
package Test2::Plugin::UTF8;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Carp qw/croak/;
|
||||
|
||||
use Test2::API qw{
|
||||
test2_add_callback_post_load
|
||||
test2_stack
|
||||
};
|
||||
|
||||
my $LOADED = 0;
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
|
||||
my $import_utf8 = 1;
|
||||
while ( my $arg = shift @_ ) {
|
||||
croak "Unsupported import argument '$arg'" unless $arg eq 'encoding_only';
|
||||
$import_utf8 = 0;
|
||||
}
|
||||
|
||||
# Load and import UTF8 into the caller.
|
||||
if ( $import_utf8 ) {
|
||||
require utf8;
|
||||
utf8->import;
|
||||
}
|
||||
|
||||
return if $LOADED++; # do not add multiple hooks
|
||||
|
||||
# Set the output formatters to use utf8
|
||||
test2_add_callback_post_load(sub {
|
||||
my $stack = test2_stack;
|
||||
$stack->top; # Make sure we have at least 1 hub
|
||||
|
||||
my $warned = 0;
|
||||
for my $hub ($stack->all) {
|
||||
my $format = $hub->format || next;
|
||||
|
||||
unless ($format->can('encoding')) {
|
||||
warn "Could not apply UTF8 to unknown formatter ($format)\n" unless $warned++;
|
||||
next;
|
||||
}
|
||||
|
||||
$format->encoding('utf8');
|
||||
}
|
||||
});
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Plugin::UTF8 - Test2 plugin to test with utf8.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
When used, this plugin will make tests work with utf8. This includes
|
||||
turning on the utf8 pragma and updating the Test2 output formatter to
|
||||
use utf8.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Plugin::UTF8;
|
||||
|
||||
This is similar to:
|
||||
|
||||
use utf8;
|
||||
BEGIN {
|
||||
require Test2::Tools::Encoding;
|
||||
Test2::Tools::Encoding::set_encoding('utf8');
|
||||
}
|
||||
|
||||
You can also disable the utf8 import by using 'encoding_only' to only enable
|
||||
utf8 encoding on the output format.
|
||||
|
||||
use Test2::Plugin::UTF8 qw(encoding_only);
|
||||
|
||||
=head1 import options
|
||||
|
||||
=head2 encoding_only
|
||||
|
||||
Does not import utf8 in your test and only enables the encoding mode on the output.
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
This module currently sets output handles to have the ':utf8' output
|
||||
layer. Some might prefer ':encoding(utf-8)' which is more strict about
|
||||
verifying characters. There is a debate about whether or not encoding
|
||||
to utf8 from perl internals can ever fail, so it may not matter. This
|
||||
was also chosen because the alternative causes threads to segfault,
|
||||
see L<perlbug 31923|https://rt.perl.org/Public/Bug/Display.html?id=31923>.
|
||||
|
||||
=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
|
||||
137
database/perl/vendor/lib/Test2/Require.pm
vendored
Normal file
137
database/perl/vendor/lib/Test2/Require.pm
vendored
Normal file
@@ -0,0 +1,137 @@
|
||||
package Test2::Require;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::API qw/context/;
|
||||
use Carp qw/croak/;
|
||||
|
||||
sub skip {
|
||||
my $class = shift;
|
||||
croak "Class '$class' needs to implement 'skip()'";
|
||||
}
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
return if $class eq __PACKAGE__;
|
||||
|
||||
my $skip = $class->skip(@_);
|
||||
return unless defined $skip;
|
||||
|
||||
my $ctx = context();
|
||||
$ctx->plan(0, SKIP => $skip || "No reason given.");
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Require - Base class and documentation for skip-unless type test
|
||||
packages.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Test2::Require::* packages are packages you load to ensure your test file is
|
||||
skipped unless a specific requirement is met. Modules in this namespace may
|
||||
subclass L<Test2::Require> if they wish, but it is not strictly necessary to do
|
||||
so.
|
||||
|
||||
=head1 HOW DO I WRITE A 'REQUIRE' MODULE?
|
||||
|
||||
=head2 AS A SUBCLASS
|
||||
|
||||
package Test2::Require::Widget;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Require';
|
||||
|
||||
sub HAVE_WIDGETS { ... };
|
||||
|
||||
sub skip {
|
||||
my $class = shift;
|
||||
my @import_args = @_;
|
||||
|
||||
if (HAVE_WIDGETS()) {
|
||||
# We have widgets, do not skip
|
||||
return undef;
|
||||
}
|
||||
else {
|
||||
# No widgets, skip the test
|
||||
return "Skipped because there are no widgets" unless HAVE_WIDGETS();
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
A subclass of L<Test2::Require> simply needs to implement a C<skip()> method.
|
||||
This method will receive all import arguments. This method should return undef
|
||||
if the test should run, and should return a reason for skipping if the test
|
||||
should be skipped.
|
||||
|
||||
=head2 STAND-ALONE
|
||||
|
||||
If you do not wish to subclass L<Test2::Require> then you should write an
|
||||
C<import()> method:
|
||||
|
||||
package Test2::Require::Widget;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test2::API qw/context/;
|
||||
|
||||
sub HAVE_WIDGETS { ... };
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
|
||||
# Have widgets, should run.
|
||||
return if HAVE_WIDGETS();
|
||||
|
||||
# Use the context object to create the event
|
||||
my $ctx = context();
|
||||
$ctx->plan(0, SKIP => "Skipped because there are no widgets");
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
=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
|
||||
72
database/perl/vendor/lib/Test2/Require/AuthorTesting.pm
vendored
Normal file
72
database/perl/vendor/lib/Test2/Require/AuthorTesting.pm
vendored
Normal file
@@ -0,0 +1,72 @@
|
||||
package Test2::Require::AuthorTesting;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Require';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
sub skip {
|
||||
my $class = shift;
|
||||
return undef if $ENV{'AUTHOR_TESTING'};
|
||||
return 'Author test, set the $AUTHOR_TESTING environment variable to run it';
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Require::AuthorTesting - Only run a test when the AUTHOR_TESTING
|
||||
environment variable is set.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
It is common practice to write tests that are only run when the AUTHOR_TESTING
|
||||
environment variable is set. This module automates the (admittedly trivial) work
|
||||
of creating such a test.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Require::AuthorTesting;
|
||||
|
||||
...
|
||||
|
||||
done_testing;
|
||||
|
||||
=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
|
||||
75
database/perl/vendor/lib/Test2/Require/EnvVar.pm
vendored
Normal file
75
database/perl/vendor/lib/Test2/Require/EnvVar.pm
vendored
Normal file
@@ -0,0 +1,75 @@
|
||||
package Test2::Require::EnvVar;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp qw/confess/;
|
||||
use base 'Test2::Require';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
sub skip {
|
||||
my $class = shift;
|
||||
my ($var) = @_;
|
||||
confess "no environment variable specified" unless $var;
|
||||
return undef if $ENV{$var};
|
||||
return "This test only runs if the \$$var environment variable is set";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Require::EnvVar - Only run a test when a specific environment variable
|
||||
is set.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
It is common practice to write tests that are only run when an environment
|
||||
variable is set. This module automates the (admittedly trivial) work of creating
|
||||
such a test.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Require::EnvVar 'SOME_VAR';
|
||||
|
||||
...
|
||||
|
||||
done_testing;
|
||||
|
||||
=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
|
||||
112
database/perl/vendor/lib/Test2/Require/Fork.pm
vendored
Normal file
112
database/perl/vendor/lib/Test2/Require/Fork.pm
vendored
Normal file
@@ -0,0 +1,112 @@
|
||||
package Test2::Require::Fork;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Require';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::Util qw/CAN_FORK/;
|
||||
|
||||
sub skip {
|
||||
return undef if CAN_FORK;
|
||||
return "This test requires a perl capable of forking.";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Require::Fork - Skip a test file unless the system supports forking
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
It is fairly common to write tests that need to fork. Not all systems support
|
||||
forking. This library does the hard work of checking if forking is supported on
|
||||
the current system. If forking is not supported then this will skip all tests
|
||||
and exit true.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Require::Fork;
|
||||
|
||||
... Code that forks ...
|
||||
|
||||
=head1 EXPLANATION
|
||||
|
||||
Checking if the current system supports forking is not simple. Here is an
|
||||
example of how to do it:
|
||||
|
||||
use Config;
|
||||
|
||||
sub CAN_FORK {
|
||||
return 1 if $Config{d_fork};
|
||||
|
||||
# Some platforms use ithreads to mimic forking
|
||||
return 0 unless $^O eq 'MSWin32' || $^O eq 'NetWare';
|
||||
return 0 unless $Config{useithreads};
|
||||
return 0 unless $Config{ccflags} =~ /-DPERL_IMPLICIT_SYS/;
|
||||
|
||||
# Threads are not reliable before 5.008001
|
||||
return 0 unless $] >= 5.008001;
|
||||
|
||||
# Devel::Cover currently breaks with threads
|
||||
return 0 if $INC{'Devel/Cover.pm'};
|
||||
return 1;
|
||||
}
|
||||
|
||||
Duplicating this non-trivial code in all tests that need to fork is error-prone. It is
|
||||
easy to forget bits, or get it wrong. On top of these checks, you also need to
|
||||
tell the harness that no tests should run and why.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<Test2::Require::CanReallyfork>
|
||||
|
||||
Similar to this module, but will skip on any perl that only has fork emulation.
|
||||
|
||||
=item L<Test2::Require::CanThread>
|
||||
|
||||
Skip the test file if the system does not support threads.
|
||||
|
||||
=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
|
||||
113
database/perl/vendor/lib/Test2/Require/Module.pm
vendored
Normal file
113
database/perl/vendor/lib/Test2/Require/Module.pm
vendored
Normal file
@@ -0,0 +1,113 @@
|
||||
package Test2::Require::Module;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Require';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::Util qw/pkg_to_file/;
|
||||
|
||||
sub skip {
|
||||
my $class = shift;
|
||||
my ($module, $ver) = @_;
|
||||
|
||||
return "Module '$module' is not installed"
|
||||
unless check_installed($module);
|
||||
|
||||
return undef unless defined $ver;
|
||||
|
||||
return check_version($module, $ver);
|
||||
}
|
||||
|
||||
sub check_installed {
|
||||
my ($mod) = @_;
|
||||
my $file = pkg_to_file($mod);
|
||||
|
||||
return 1 if eval { require $file; 1 };
|
||||
my $error = $@;
|
||||
|
||||
return 0 if $error =~ m/Can't locate \Q$file\E in \@INC/;
|
||||
|
||||
# Some other error, rethrow it.
|
||||
die $error;
|
||||
}
|
||||
|
||||
sub check_version {
|
||||
my ($mod, $ver) = @_;
|
||||
|
||||
return undef if eval { $mod->VERSION($ver); 1 };
|
||||
my $have = $mod->VERSION;
|
||||
return "Need '$mod' version $ver, have $have.";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Require::Module - Skip tests if certain packages are not installed, or
|
||||
insufficient versions.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Sometimes you have tests that are nice to run, but depend on tools that may not
|
||||
be available. Instead of adding the tool as a dep, or making the test always
|
||||
skip, it is common to make the test run conditionally. This package helps make
|
||||
that possible.
|
||||
|
||||
This module is modeled after L<Test::Requires>. The difference is that this
|
||||
module is based on L<Test2> directly, and does not go through L<Test::Builder>.
|
||||
Another difference is that the packages you check for are not imported into
|
||||
your namespace for you. This is intentional.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# The test will be skipped unless Some::Module is installed, any version.
|
||||
use Test2::Require::Module 'Some::Module';
|
||||
|
||||
# The test will be skipped unless 'Other::Module' is installed and at
|
||||
# version '5.555' or greater.
|
||||
use Test2::Require::Module 'Other::Module' => '5.555';
|
||||
|
||||
# We now need to use them directly, Test2::Require::Module does not import
|
||||
# them for us.
|
||||
use Some::Module;
|
||||
use Other::Module;
|
||||
|
||||
=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
|
||||
79
database/perl/vendor/lib/Test2/Require/Perl.pm
vendored
Normal file
79
database/perl/vendor/lib/Test2/Require/Perl.pm
vendored
Normal file
@@ -0,0 +1,79 @@
|
||||
package Test2::Require::Perl;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Require';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::Util qw/pkg_to_file/;
|
||||
use Scalar::Util qw/reftype/;
|
||||
|
||||
sub skip {
|
||||
my $class = shift;
|
||||
my ($ver) = @_;
|
||||
|
||||
return undef if eval "no warnings 'portable'; require $ver; 1";
|
||||
my $error = $@;
|
||||
return $1 if $error =~ m/^(Perl \S* required)/i;
|
||||
die $error;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Require::Perl - Skip the test unless the necessary version of Perl is
|
||||
installed.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Sometimes you have tests that are nice to run, but depend on a certain version
|
||||
of Perl. This package lets you run the test conditionally, depending on if the
|
||||
correct version of Perl is available.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
# Skip the test unless perl 5.10 or greater is installed.
|
||||
use Test2::Require::Perl 'v5.10';
|
||||
|
||||
# Enable 5.10 features.
|
||||
use v5.10;
|
||||
|
||||
=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
|
||||
86
database/perl/vendor/lib/Test2/Require/RealFork.pm
vendored
Normal file
86
database/perl/vendor/lib/Test2/Require/RealFork.pm
vendored
Normal file
@@ -0,0 +1,86 @@
|
||||
package Test2::Require::RealFork;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Require';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::Util qw/CAN_REALLY_FORK/;
|
||||
|
||||
sub skip {
|
||||
return undef if CAN_REALLY_FORK;
|
||||
return "This test requires a perl capable of true forking.";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Require::RealFork - Skip a test file unless the system supports true
|
||||
forking
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
It is fairly common to write tests that need to fork. Not all systems support
|
||||
forking. This library does the hard work of checking if forking is supported on
|
||||
the current system. If forking is not supported then this will skip all tests
|
||||
and exit true.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Require::RealFork;
|
||||
|
||||
... Code that forks ...
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<Test2::Require::Canfork>
|
||||
|
||||
Similar to this module, but will allow fork emulation.
|
||||
|
||||
=item L<Test2::Require::CanThread>
|
||||
|
||||
Skip the test file if the system does not support threads.
|
||||
|
||||
=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
|
||||
106
database/perl/vendor/lib/Test2/Require/Threads.pm
vendored
Normal file
106
database/perl/vendor/lib/Test2/Require/Threads.pm
vendored
Normal file
@@ -0,0 +1,106 @@
|
||||
package Test2::Require::Threads;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use base 'Test2::Require';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::Util qw/CAN_THREAD/;
|
||||
|
||||
sub skip {
|
||||
return undef if CAN_THREAD;
|
||||
return "This test requires a perl capable of threading.";
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Require::Threads - Skip a test file unless the system supports threading
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
It is fairly common to write tests that need to use threads. Not all systems
|
||||
support threads. This library does the hard work of checking if threading is
|
||||
supported on the current system. If threading is not supported then this will
|
||||
skip all tests and exit true.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Require::Threads;
|
||||
|
||||
... Code that uses threads ...
|
||||
|
||||
=head1 EXPLANATION
|
||||
|
||||
Checking if the current system supports threading is not simple, here is an
|
||||
example of how to do it:
|
||||
|
||||
use Config;
|
||||
|
||||
sub CAN_THREAD {
|
||||
# Threads are not reliable before 5.008001
|
||||
return 0 unless $] >= 5.008001;
|
||||
return 0 unless $Config{'useithreads'};
|
||||
|
||||
# Devel::Cover currently breaks with threads
|
||||
return 0 if $INC{'Devel/Cover.pm'};
|
||||
return 1;
|
||||
}
|
||||
|
||||
Duplicating this non-trivial code in all tests that need to use threads is
|
||||
error-prone. It is easy to forget bits, or get it wrong. On top of these checks you
|
||||
also need to tell the harness that no tests should run and why.
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
=over 4
|
||||
|
||||
=item L<Test2::Require::CanFork>
|
||||
|
||||
Skip the test file if the system does not support forking.
|
||||
|
||||
=item L<Test2>
|
||||
|
||||
Test2::Require::Threads uses L<Test2> under the hood.
|
||||
|
||||
=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
|
||||
382
database/perl/vendor/lib/Test2/Suite.pm
vendored
Normal file
382
database/perl/vendor/lib/Test2/Suite.pm
vendored
Normal file
@@ -0,0 +1,382 @@
|
||||
package Test2::Suite;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Suite - Distribution with a rich set of tools built upon the Test2
|
||||
framework.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Rich set of tools, plugins, bundles, etc built upon the L<Test2> testing
|
||||
library. If you are interested in writing tests, this is the distribution for
|
||||
you.
|
||||
|
||||
=head2 WHAT ARE TOOLS, PLUGINS, AND BUNDLES?
|
||||
|
||||
=over 4
|
||||
|
||||
=item TOOLS
|
||||
|
||||
Tools are packages that export functions for use in test files. These functions
|
||||
typically generate events. Tools B<SHOULD NEVER> alter behavior of other tools,
|
||||
or the system in general.
|
||||
|
||||
=item PLUGINS
|
||||
|
||||
Plugins are packages that produce effects, or alter behavior of tools. An
|
||||
example would be a plugin that causes the test to bail out after the first
|
||||
failure. Plugins B<SHOULD NOT> export anything.
|
||||
|
||||
=item BUNDLES
|
||||
|
||||
Bundles are collections of tools and plugins. A bundle should load and
|
||||
re-export functions from Tool packages. A bundle may also load and configure
|
||||
any number of plugins.
|
||||
|
||||
=back
|
||||
|
||||
If you want to write something that both exports new functions, and effects
|
||||
behavior, you should write both a Tools distribution, and a Plugin distribution,
|
||||
then a Bundle that loads them both. This is important as it helps avoid the
|
||||
problem where a package exports much-desired tools, but
|
||||
also produces undesirable side effects.
|
||||
|
||||
=head1 INCLUDED BUNDLES
|
||||
|
||||
=over 4
|
||||
|
||||
=item Test2::V#
|
||||
|
||||
These do not live in the bundle namespace as they are the primary ways to use
|
||||
Test2::Suite.
|
||||
|
||||
The current latest is L<Test2::V0>.
|
||||
|
||||
use Test2::V0;
|
||||
# strict and warnings are on for you now.
|
||||
|
||||
ok(...);
|
||||
|
||||
# Note: is does deep checking, unlike the 'is' from Test::More.
|
||||
is(...);
|
||||
|
||||
...
|
||||
|
||||
done_testing;
|
||||
|
||||
This bundle includes every tool listed in the L</INCLUDED TOOLS> section below,
|
||||
except for L<Test2::Tools::ClassicCompare>. This bundle provides most of what
|
||||
anyone writing tests could need. This is also the preferred bundle/toolset of
|
||||
the L<Test2> author.
|
||||
|
||||
See L<Test2::V0> for complete documentation.
|
||||
|
||||
=item Extended
|
||||
|
||||
B<** Deprecated **> See L<Test2::V0>
|
||||
|
||||
use Test2::Bundle::Extended;
|
||||
# strict and warnings are on for you now.
|
||||
|
||||
ok(...);
|
||||
|
||||
# Note: is does deep checking, unlike the 'is' from Test::More.
|
||||
is(...);
|
||||
|
||||
...
|
||||
|
||||
done_testing;
|
||||
|
||||
This bundle includes every tool listed in the L</INCLUDED TOOLS> section below,
|
||||
except for L<Test2::Tools::ClassicCompare>. This bundle provides most of what
|
||||
anyone writing tests could need. This is also the preferred bundle/toolset of
|
||||
the L<Test2> author.
|
||||
|
||||
See L<Test2::Bundle::Extended> for complete documentation.
|
||||
|
||||
=item More
|
||||
|
||||
use Test2::Bundle::More;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
plan 3; # Or you can use done_testing at the end
|
||||
|
||||
ok(...);
|
||||
|
||||
is(...); # Note: String compare
|
||||
|
||||
is_deeply(...);
|
||||
|
||||
...
|
||||
|
||||
done_testing; # Use instead of plan
|
||||
|
||||
This bundle is meant to be a I<mostly> drop-in replacement for L<Test::More>.
|
||||
There are some notable differences to be aware of however. Some exports are
|
||||
missing: C<eq_array>, C<eq_hash>, C<eq_set>, C<$TODO>, C<explain>, C<use_ok>,
|
||||
C<require_ok>. As well it is no longer possible to set the plan at import:
|
||||
C<< use .. tests => 5 >>. C<$TODO> has been replaced by the C<todo()>
|
||||
function. Planning is done using C<plan>, C<skip_all>, or C<done_testing>.
|
||||
|
||||
See L<Test2::Bundle::More> for complete documentation.
|
||||
|
||||
=item Simple
|
||||
|
||||
use Test2::Bundle::Simple;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
plan 1;
|
||||
|
||||
ok(...);
|
||||
|
||||
This bundle is meant to be a I<mostly> drop-in replacement for L<Test::Simple>.
|
||||
See L<Test2::Bundle::Simple> for complete documentation.
|
||||
|
||||
=back
|
||||
|
||||
=head1 INCLUDED TOOLS
|
||||
|
||||
=over 4
|
||||
|
||||
=item Basic
|
||||
|
||||
Basic provides most of the essential tools previously found in L<Test::More>.
|
||||
However it does not export any tools used for comparison. The basic C<pass>,
|
||||
C<fail>, C<ok> functions are present, as are functions for planning.
|
||||
|
||||
See L<Test2::Tools::Basic> for complete documentation.
|
||||
|
||||
=item Compare
|
||||
|
||||
This provides C<is>, C<like>, C<isnt>, C<unlike>, and several additional
|
||||
helpers. B<Note:> These are all I<deep> comparison tools and work like a
|
||||
combination of L<Test::More>'s C<is> and C<is_deeply>.
|
||||
|
||||
See L<Test2::Tools::Compare> for complete documentation.
|
||||
|
||||
=item ClassicCompare
|
||||
|
||||
This provides L<Test::More> flavored C<is>, C<like>, C<isnt>, C<unlike>, and
|
||||
C<is_deeply>. It also provides C<cmp_ok>.
|
||||
|
||||
See L<Test2::Tools::ClassicCompare> for complete documentation.
|
||||
|
||||
=item Class
|
||||
|
||||
This provides functions for testing objects and classes, things like C<isa_ok>.
|
||||
|
||||
See L<Test2::Tools::Class> for complete documentation.
|
||||
|
||||
=item Defer
|
||||
|
||||
This provides functions for writing test functions in one place, but running
|
||||
them later. This is useful for testing things that run in an altered state.
|
||||
|
||||
See L<Test2::Tools::Defer> for complete documentation.
|
||||
|
||||
=item Encoding
|
||||
|
||||
This exports a single function that can be used to change the encoding of all
|
||||
your test output.
|
||||
|
||||
See L<Test2::Tools::Encoding> for complete documentation.
|
||||
|
||||
=item Exports
|
||||
|
||||
This provides tools for verifying exports. You can verify that functions have
|
||||
been imported, or that they have not been imported.
|
||||
|
||||
See L<Test2::Tools::Exports> for complete documentation.
|
||||
|
||||
=item Mock
|
||||
|
||||
This provides tools for mocking objects and classes. This is based largely on
|
||||
L<Mock::Quick>, but several interface improvements have been added that cannot
|
||||
be added to Mock::Quick itself without breaking backwards compatibility.
|
||||
|
||||
See L<Test2::Tools::Mock> for complete documentation.
|
||||
|
||||
=item Ref
|
||||
|
||||
This exports tools for validating and comparing references.
|
||||
|
||||
See L<Test2::Tools::Ref> for complete documentation.
|
||||
|
||||
=item Spec
|
||||
|
||||
This is an RSPEC implementation with concurrency support.
|
||||
|
||||
See L<Test2::Tools::Spec> for more details.
|
||||
|
||||
=item Subtest
|
||||
|
||||
This exports tools for running subtests.
|
||||
|
||||
See L<Test2::Tools::Subtest> for complete documentation.
|
||||
|
||||
=item Target
|
||||
|
||||
This lets you load the package(s) you intend to test, and alias them into
|
||||
constants/package variables.
|
||||
|
||||
See L<Test2::Tools::Target> for complete documentation.
|
||||
|
||||
=back
|
||||
|
||||
=head1 INCLUDED PLUGINS
|
||||
|
||||
=over 4
|
||||
|
||||
=item BailOnFail
|
||||
|
||||
The much requested "bail-out on first failure" plugin. When this plugin is
|
||||
loaded, any failure will cause the test to bail out immediately.
|
||||
|
||||
See L<Test2::Plugin::BailOnFail> for complete documentation.
|
||||
|
||||
=item DieOnFail
|
||||
|
||||
The much requested "die on first failure" plugin. When this plugin is
|
||||
loaded, any failure will cause the test to die immediately.
|
||||
|
||||
See L<Test2::Plugin::DieOnFail> for complete documentation.
|
||||
|
||||
=item ExitSummary
|
||||
|
||||
This plugin gives you statistics and diagnostics at the end of your test in the
|
||||
event of a failure.
|
||||
|
||||
See L<Test2::Plugin::ExitSummary> for complete documentation.
|
||||
|
||||
=item SRand
|
||||
|
||||
Use this to set the random seed to a specific seed, or to the current date.
|
||||
|
||||
See L<Test2::Plugin::SRand> for complete documentation.
|
||||
|
||||
=item UTF8
|
||||
|
||||
Turn on utf8 for your testing. This sets the current file to be utf8, it also
|
||||
sets STDERR, STDOUT, and your formatter to all output utf8.
|
||||
|
||||
See L<Test2::Plugin::UTF8> for complete documentation.
|
||||
|
||||
=back
|
||||
|
||||
=head1 INCLUDED REQUIREMENT CHECKERS
|
||||
|
||||
=over 4
|
||||
|
||||
=item AuthorTesting
|
||||
|
||||
Using this package will cause the test file to be skipped unless the
|
||||
AUTHOR_TESTING environment variable is set.
|
||||
|
||||
See L<Test2::Require::AuthorTesting> for complete documentation.
|
||||
|
||||
=item EnvVar
|
||||
|
||||
Using this package will cause the test file to be skipped unless a custom
|
||||
environment variable is set.
|
||||
|
||||
See L<Test2::Require::EnvVar> for complete documentation.
|
||||
|
||||
=item Fork
|
||||
|
||||
Using this package will cause the test file to be skipped unless the system is
|
||||
capable of forking (including emulated forking).
|
||||
|
||||
See L<Test2::Require::Fork> for complete documentation.
|
||||
|
||||
=item RealFork
|
||||
|
||||
Using this package will cause the test file to be skipped unless the system is
|
||||
capable of true forking.
|
||||
|
||||
See L<Test2::Require::RealFork> for complete documentation.
|
||||
|
||||
=item Module
|
||||
|
||||
Using this package will cause the test file to be skipped unless the specified
|
||||
module is installed (and optionally at a minimum version).
|
||||
|
||||
See L<Test2::Require::Module> for complete documentation.
|
||||
|
||||
=item Perl
|
||||
|
||||
Using this package will cause the test file to be skipped unless the specified
|
||||
minimum perl version is met.
|
||||
|
||||
See L<Test2::Require::Perl> for complete documentation.
|
||||
|
||||
=item Threads
|
||||
|
||||
Using this package will cause the test file to be skipped unless the system has
|
||||
threading enabled.
|
||||
|
||||
B<Note:> This will not turn threading on for you.
|
||||
|
||||
See L<Test2::Require::Threads> for complete documentation.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
See the L<Test2> documentation for a namespace map. Everything in this
|
||||
distribution uses L<Test2>.
|
||||
|
||||
L<Test2::Manual> is the Test2 Manual.
|
||||
|
||||
=head1 CONTACTING US
|
||||
|
||||
Many Test2 developers and users lurk on L<irc://irc.perl.org/#perl>. We also
|
||||
have a slack team that can be joined by anyone with an C<@cpan.org> email
|
||||
address L<https://perl-test2.slack.com/> If you do not have an C<@cpan.org>
|
||||
email you can ask for a slack invite by emailing Chad Granum
|
||||
E<lt>exodist@cpan.orgE<gt>.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2-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
|
||||
184
database/perl/vendor/lib/Test2/Todo.pm
vendored
Normal file
184
database/perl/vendor/lib/Test2/Todo.pm
vendored
Normal file
@@ -0,0 +1,184 @@
|
||||
package Test2::Todo;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp qw/croak/;
|
||||
use Test2::Util::HashBase qw/hub _filter reason/;
|
||||
|
||||
use Test2::API qw/test2_stack/;
|
||||
|
||||
use overload '""' => \&reason, fallback => 1;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
sub init {
|
||||
my $self = shift;
|
||||
|
||||
my $reason = $self->{+REASON};
|
||||
croak "The 'reason' attribute is required" unless defined $reason;
|
||||
|
||||
my $hub = $self->{+HUB} ||= test2_stack->top;
|
||||
|
||||
$self->{+_FILTER} = $hub->pre_filter(
|
||||
sub {
|
||||
my ($active_hub, $event) = @_;
|
||||
|
||||
# Turn a diag into a note
|
||||
return Test2::Event::Note->new(%$event) if ref($event) eq 'Test2::Event::Diag';
|
||||
|
||||
if ($active_hub == $hub) {
|
||||
$event->set_todo($reason) if $event->can('set_todo');
|
||||
$event->add_amnesty({tag => 'TODO', details => $reason});
|
||||
$event->set_effective_pass(1) if $event->isa('Test2::Event::Ok');
|
||||
}
|
||||
else {
|
||||
$event->add_amnesty({tag => 'TODO', details => $reason, inherited => 1});
|
||||
}
|
||||
|
||||
return $event;
|
||||
},
|
||||
inherit => 1,
|
||||
todo => $reason,
|
||||
);
|
||||
}
|
||||
|
||||
sub end {
|
||||
my $self = shift;
|
||||
my $hub = $self->{+HUB} or return;
|
||||
|
||||
$hub->pre_unfilter($self->{+_FILTER});
|
||||
delete $self->{+HUB};
|
||||
delete $self->{+_FILTER};
|
||||
}
|
||||
|
||||
sub DESTROY {
|
||||
my $self = shift;
|
||||
$self->end;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Todo - TODO extension for Test2.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is an object that lets you create and manage TODO states for tests. This
|
||||
is an extension, not a plugin or a tool. This library can be used by plugins
|
||||
and tools to manage todo states.
|
||||
|
||||
If you simply want to write a todo test then you should look at the C<todo>
|
||||
function provided by L<Test2::Tools::Basic>.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Todo;
|
||||
|
||||
# Start the todo
|
||||
my $todo = Test2::Todo->new(reason => 'Fix later');
|
||||
|
||||
# Will be considered todo, so suite still passes
|
||||
ok(0, "oops");
|
||||
|
||||
# End the todo
|
||||
$todo->end;
|
||||
|
||||
# TODO has ended, this test will actually fail.
|
||||
ok(0, "oops");
|
||||
|
||||
=head1 CONSTRUCTION OPTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item reason (required)
|
||||
|
||||
The reason for the todo, this can be any defined value.
|
||||
|
||||
=item hub (optional)
|
||||
|
||||
The hub to which the TODO state should be applied. If none is provided then the
|
||||
current global hub is used.
|
||||
|
||||
=back
|
||||
|
||||
=head1 INSTANCE METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $todo->end
|
||||
|
||||
End the todo state.
|
||||
|
||||
=back
|
||||
|
||||
=head1 CLASS METHODS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $count = Test2::Todo->hub_in_todo($hub)
|
||||
|
||||
If the hub has any todo objects this will return the total number of them. If
|
||||
the hub has no todo objects it will return 0.
|
||||
|
||||
=back
|
||||
|
||||
=head1 OTHER NOTES
|
||||
|
||||
=head2 How it works
|
||||
|
||||
When an instance is created a filter sub is added to the L<Test2::Hub>. This
|
||||
filter will set the C<todo> and C<diag_todo> attributes on all events as they
|
||||
come in. When the instance is destroyed, or C<end()> is called, the filter is
|
||||
removed.
|
||||
|
||||
When a new hub is pushed (such as when a subtest is started) the new hub will
|
||||
inherit the filter, but it will only set C<diag_todo>, it will not set C<todo>
|
||||
on events in child hubs.
|
||||
|
||||
=head2 $todo->end is called at destruction
|
||||
|
||||
If your C<$todo> object falls out of scope and gets garbage collected, the todo
|
||||
will end.
|
||||
|
||||
=head2 Can I use multiple instances?
|
||||
|
||||
Yes. The most recently created one that is still active will win.
|
||||
|
||||
=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
|
||||
117
database/perl/vendor/lib/Test2/Tools.pm
vendored
Normal file
117
database/perl/vendor/lib/Test2/Tools.pm
vendored
Normal file
@@ -0,0 +1,117 @@
|
||||
package Test2::Tools;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools - Documentation for Tools.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Tools are packages that export test functions, typically all related to a
|
||||
specific aspect of testing. If you have a couple different categories of
|
||||
exports then you may want to break them into separate modules.
|
||||
|
||||
Tools should export testing functions. Loading tools B<should not> have side
|
||||
effects, or alter the behavior of other tools. If you want to alter behaviors
|
||||
or create side effects then you probably want to write a L<Test2::Plugin>.
|
||||
|
||||
=head1 FAQ
|
||||
|
||||
=over 4
|
||||
|
||||
=item Why is it called Test2::Tools, and not Test2::Tool?
|
||||
|
||||
This question arises since Tools is the only namespace in the plural. This is
|
||||
because each Plugin should be a distinct unit of functionality, but a Tools
|
||||
dist can (and usually should) export several tools. A bundle is also typically
|
||||
described as a single unit. Nobody would like Test2::Bundles::Foo.
|
||||
|
||||
=item Should my tools subclass Test2::Tools?
|
||||
|
||||
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 'TOOLS' MODULE?
|
||||
|
||||
It is very easy to write tools:
|
||||
|
||||
package Test2::Tools::Mine
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
# All tools should use the context() function.
|
||||
use Test2::API qw/context/;
|
||||
|
||||
our @EXPORTS = qw/ok plan/;
|
||||
use base 'Exporter';
|
||||
|
||||
sub ok($;$) {
|
||||
my ($bool, $name) = @_;
|
||||
|
||||
# All tool functions should start by grabbing a context
|
||||
my $ctx = context();
|
||||
|
||||
# The context is the primary interface for generating events
|
||||
$ctx->ok($bool, $name);
|
||||
|
||||
# When you are done you release the context
|
||||
$ctx->release;
|
||||
|
||||
return $bool ? 1 : 0;
|
||||
}
|
||||
|
||||
sub plan {
|
||||
my ($max) = @_;
|
||||
my $ctx = context();
|
||||
$ctx->plan($max);
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
See L<Test2::API::Context> for documentation on what the C<$ctx> object can do.
|
||||
|
||||
=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
|
||||
176
database/perl/vendor/lib/Test2/Tools/AsyncSubtest.pm
vendored
Normal file
176
database/perl/vendor/lib/Test2/Tools/AsyncSubtest.pm
vendored
Normal file
@@ -0,0 +1,176 @@
|
||||
package Test2::Tools::AsyncSubtest;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::IPC;
|
||||
use Test2::AsyncSubtest;
|
||||
use Test2::API qw/context/;
|
||||
use Carp qw/croak/;
|
||||
|
||||
our @EXPORT = qw/async_subtest fork_subtest thread_subtest/;
|
||||
use base 'Exporter';
|
||||
|
||||
sub async_subtest {
|
||||
my $name = shift;
|
||||
my ($params, $code);
|
||||
$params = shift(@_) if @_ && ref($_[0]) eq 'HASH';
|
||||
$code = shift(@_) if @_ && ref($_[0]) eq 'CODE';
|
||||
|
||||
my $ctx = context();
|
||||
|
||||
my $subtest = Test2::AsyncSubtest->new(name => $name, context => 1, hub_init_args => $params);
|
||||
|
||||
$subtest->run($code, $subtest) if $code;
|
||||
|
||||
$ctx->release;
|
||||
return $subtest;
|
||||
}
|
||||
|
||||
sub fork_subtest {
|
||||
my $name = shift;
|
||||
my ($params, $code);
|
||||
$params = shift(@_) if @_ && ref($_[0]) eq 'HASH';
|
||||
$code = shift(@_) if @_ && ref($_[0]) eq 'CODE';
|
||||
|
||||
my $ctx = context();
|
||||
|
||||
croak "fork_subtest requires a CODE reference as the second argument"
|
||||
unless ref($code) eq 'CODE';
|
||||
|
||||
my $subtest = Test2::AsyncSubtest->new(name => $name, context => 1, hub_init_args => $params);
|
||||
|
||||
$subtest->run_fork($code, $subtest);
|
||||
|
||||
$ctx->release;
|
||||
return $subtest;
|
||||
}
|
||||
|
||||
sub thread_subtest {
|
||||
my $name = shift;
|
||||
my ($params, $code);
|
||||
$params = shift(@_) if @_ && ref($_[0]) eq 'HASH';
|
||||
$code = shift(@_) if @_ && ref($_[0]) eq 'CODE';
|
||||
|
||||
my $ctx = context();
|
||||
|
||||
croak "thread_subtest requires a CODE reference as the second argument"
|
||||
unless ref($code) eq 'CODE';
|
||||
|
||||
my $subtest = Test2::AsyncSubtest->new(name => $name, context => 1, hub_init_args => $params);
|
||||
|
||||
$subtest->run_thread($code, $subtest);
|
||||
|
||||
$ctx->release;
|
||||
return $subtest;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::AsyncSubtest - Tools for writing async subtests.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
These are tools for writing async subtests. Async subtests are subtests which
|
||||
can be started and stashed so that they can continue to receive events while
|
||||
other events are also being generated.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Bundle::Extended;
|
||||
use Test2::Tools::AsyncSubtest;
|
||||
|
||||
my $ast1 = async_subtest local => sub {
|
||||
ok(1, "Inside subtest");
|
||||
};
|
||||
|
||||
my $ast2 = fork_subtest child => sub {
|
||||
ok(1, "Inside subtest in another process");
|
||||
};
|
||||
|
||||
# You must call finish on the subtests you create. Finish will wait/join on
|
||||
# any child processes and threads.
|
||||
$ast1->finish;
|
||||
$ast2->finish;
|
||||
|
||||
done_testing;
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
Everything is exported by default.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $ast = async_subtest $name
|
||||
|
||||
=item $ast = async_subtest $name => sub { ... }
|
||||
|
||||
=item $ast = async_subtest $name => \%hub_params, sub { ... }
|
||||
|
||||
Create an async subtest. Run the codeblock if it is provided.
|
||||
|
||||
=item $ast = fork_subtest $name => sub { ... }
|
||||
|
||||
=item $ast = fork_subtest $name => \%hub_params, sub { ... }
|
||||
|
||||
Create an async subtest. Run the codeblock in a forked process.
|
||||
|
||||
=item $ast = thread_subtest $name => sub { ... }
|
||||
|
||||
=item $ast = thread_subtest $name => \%hub_params, sub { ... }
|
||||
|
||||
B<** DISCOURAGED **> Threads are fragile. Thread tests are not even run unless
|
||||
the AUTHOR_TESTING or T2_DO_THREAD_TESTS env vars are enabled.
|
||||
|
||||
Create an async subtest. Run the codeblock in a thread.
|
||||
|
||||
=back
|
||||
|
||||
=head1 NOTES
|
||||
|
||||
=over 4
|
||||
|
||||
=item Async Subtests are always buffered.
|
||||
|
||||
=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
|
||||
355
database/perl/vendor/lib/Test2/Tools/Basic.pm
vendored
Normal file
355
database/perl/vendor/lib/Test2/Tools/Basic.pm
vendored
Normal file
@@ -0,0 +1,355 @@
|
||||
package Test2::Tools::Basic;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Carp qw/croak/;
|
||||
use Test2::API qw/context/;
|
||||
|
||||
our @EXPORT = qw{
|
||||
ok pass fail diag note todo skip
|
||||
plan skip_all done_testing bail_out
|
||||
};
|
||||
use base 'Exporter';
|
||||
|
||||
sub ok($;$@) {
|
||||
my ($bool, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
$ctx->ok($bool, $name, \@diag);
|
||||
$ctx->release;
|
||||
return $bool ? 1 : 0;
|
||||
}
|
||||
|
||||
sub pass {
|
||||
my ($name) = @_;
|
||||
my $ctx = context();
|
||||
$ctx->ok(1, $name);
|
||||
$ctx->release;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub fail {
|
||||
my ($name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
$ctx->ok(0, $name, \@diag);
|
||||
$ctx->release;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub diag {
|
||||
my $ctx = context();
|
||||
$ctx->diag( join '', grep { defined $_ } @_ );
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
sub note {
|
||||
my $ctx = context();
|
||||
$ctx->note( join '', grep { defined $_ } @_ );
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
sub todo {
|
||||
my $reason = shift;
|
||||
my $code = shift;
|
||||
|
||||
require Test2::Todo unless $INC{'Test2/Todo.pm'};
|
||||
my $todo = Test2::Todo->new(reason => $reason);
|
||||
|
||||
return $code->() if $code;
|
||||
|
||||
croak "Cannot use todo() in a void context without a codeblock"
|
||||
unless defined wantarray;
|
||||
|
||||
return $todo;
|
||||
}
|
||||
|
||||
sub skip {
|
||||
my ($why, $num) = @_;
|
||||
$num ||= 1;
|
||||
my $ctx = context();
|
||||
$ctx->skip("skipped test", $why) for 1 .. $num;
|
||||
$ctx->release;
|
||||
no warnings 'exiting';
|
||||
last SKIP;
|
||||
}
|
||||
|
||||
sub plan {
|
||||
my $plan = shift;
|
||||
my $ctx = context();
|
||||
|
||||
if ($plan && $plan =~ m/[^0-9]/) {
|
||||
if ($plan eq 'tests') {
|
||||
$plan = shift;
|
||||
}
|
||||
elsif ($plan eq 'skip_all') {
|
||||
skip_all(@_);
|
||||
$ctx->release;
|
||||
return;
|
||||
}
|
||||
}
|
||||
|
||||
$ctx->plan($plan);
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
sub skip_all {
|
||||
my ($reason) = @_;
|
||||
my $ctx = context();
|
||||
$ctx->plan(0, SKIP => $reason);
|
||||
$ctx->release if $ctx;
|
||||
}
|
||||
|
||||
sub done_testing {
|
||||
my $ctx = context();
|
||||
$ctx->hub->finalize($ctx->trace, 1);
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
sub bail_out {
|
||||
my ($reason) = @_;
|
||||
my $ctx = context();
|
||||
$ctx->bail($reason);
|
||||
$ctx->release if $ctx;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Basic - Test2 implementation of the basic testing tools.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is a L<Test2> based implementation of the more basic tools originally
|
||||
provided by L<Test::More>. Not all L<Test::More> tools are provided by this
|
||||
package, only the basic/simple ones. Some tools have been modified for better
|
||||
diagnostics capabilities.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Tools::Basic;
|
||||
|
||||
ok($x, "simple test");
|
||||
|
||||
if ($passing) {
|
||||
pass('a passing test');
|
||||
}
|
||||
else {
|
||||
fail('a failing test');
|
||||
}
|
||||
|
||||
diag "This is a diagnostics message on STDERR";
|
||||
note "This is a diagnostics message on STDOUT";
|
||||
|
||||
{
|
||||
my $todo = todo "Reason for todo";
|
||||
ok(0, "this test is todo");
|
||||
}
|
||||
|
||||
ok(1, "this test is not todo");
|
||||
|
||||
todo "reason" => sub {
|
||||
ok(0, "this test is todo");
|
||||
};
|
||||
|
||||
ok(1, "this test is not todo");
|
||||
|
||||
SKIP: {
|
||||
skip "This will wipe your drive";
|
||||
|
||||
# This never gets run:
|
||||
ok(!system('sudo rm -rf /'), "Wipe drive");
|
||||
}
|
||||
|
||||
done_testing;
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All subs are exported by default.
|
||||
|
||||
=head2 PLANNING
|
||||
|
||||
=over 4
|
||||
|
||||
=item plan($num)
|
||||
|
||||
=item plan('tests' => $num)
|
||||
|
||||
=item plan('skip_all' => $reason)
|
||||
|
||||
Set the number of tests that are expected. This must be done first or last,
|
||||
never in the middle of testing.
|
||||
|
||||
For legacy compatibility you can specify 'tests' as the first argument before
|
||||
the number. You can also use this to skip all with the 'skip_all' prefix,
|
||||
followed by a reason for skipping.
|
||||
|
||||
=item skip_all($reason)
|
||||
|
||||
Set the plan to 0 with a reason, then exit true. This should be used before any
|
||||
tests are run.
|
||||
|
||||
=item done_testing
|
||||
|
||||
Used to mark the end of testing. This is a safe way to have a dynamic or
|
||||
unknown number of tests.
|
||||
|
||||
=item bail_out($reason)
|
||||
|
||||
Invoked when something has gone horribly wrong: stop everything, kill all threads and
|
||||
processes, end the process with a false exit status.
|
||||
|
||||
=back
|
||||
|
||||
=head2 ASSERTIONS
|
||||
|
||||
=over 4
|
||||
|
||||
=item ok($bool)
|
||||
|
||||
=item ok($bool, $name)
|
||||
|
||||
=item ok($bool, $name, @diag)
|
||||
|
||||
Simple assertion. If C<$bool> is true the test passes, and if it is false the test
|
||||
fails. The test name is optional, and all arguments after the name are added as
|
||||
diagnostics message if and only if the test fails. If the test passes all the
|
||||
diagnostics arguments will be ignored.
|
||||
|
||||
=item pass()
|
||||
|
||||
=item pass($name)
|
||||
|
||||
Fire off a passing test (a single Ok event). The name is optional
|
||||
|
||||
=item fail()
|
||||
|
||||
=item fail($name)
|
||||
|
||||
=item fail($name, @diag)
|
||||
|
||||
Fire off a failing test (a single Ok event). The name and diagnostics are optional.
|
||||
|
||||
=back
|
||||
|
||||
=head2 DIAGNOSTICS
|
||||
|
||||
=over 4
|
||||
|
||||
=item diag(@messages)
|
||||
|
||||
Write diagnostics messages. All items in C<@messages> will be joined into a
|
||||
single string with no separator. When using TAP, diagnostics are sent to STDERR.
|
||||
|
||||
=item note(@messages)
|
||||
|
||||
Write note-diagnostics messages. All items in C<@messages> will be joined into
|
||||
a single string with no separator. When using TAP, notes are sent to STDOUT.
|
||||
|
||||
=back
|
||||
|
||||
=head2 META
|
||||
|
||||
=over 4
|
||||
|
||||
=item $todo = todo($reason)
|
||||
|
||||
=item todo $reason => sub { ... }
|
||||
|
||||
This is used to mark some results as TODO. TODO means that the test may fail,
|
||||
but will not cause the overall test suite to fail.
|
||||
|
||||
There are two ways to use this. The first is to use a codeblock, and the TODO will
|
||||
only apply to the codeblock.
|
||||
|
||||
ok(1, "before"); # Not TODO
|
||||
|
||||
todo 'this will fail' => sub {
|
||||
# This is TODO, as is any other test in this block.
|
||||
ok(0, "blah");
|
||||
};
|
||||
|
||||
ok(1, "after"); # Not TODO
|
||||
|
||||
The other way is to use a scoped variable. TODO will end when the variable is
|
||||
destroyed or set to undef.
|
||||
|
||||
ok(1, "before"); # Not TODO
|
||||
|
||||
{
|
||||
my $todo = todo 'this will fail';
|
||||
|
||||
# This is TODO, as is any other test in this block.
|
||||
ok(0, "blah");
|
||||
};
|
||||
|
||||
ok(1, "after"); # Not TODO
|
||||
|
||||
This is the same thing, but without the C<{...}> scope.
|
||||
|
||||
ok(1, "before"); # Not TODO
|
||||
|
||||
my $todo = todo 'this will fail';
|
||||
|
||||
ok(0, "blah"); # TODO
|
||||
|
||||
$todo = undef;
|
||||
|
||||
ok(1, "after"); # Not TODO
|
||||
|
||||
=item skip($why)
|
||||
|
||||
=item skip($why, $count)
|
||||
|
||||
This is used to skip some tests. This requires you to wrap your tests in a
|
||||
block labeled C<SKIP:>. This is somewhat magical. If no C<$count> is specified
|
||||
then it will issue a single result. If you specify C<$count> it will issue that
|
||||
many results.
|
||||
|
||||
SKIP: {
|
||||
skip "This will wipe your drive";
|
||||
|
||||
# This never gets run:
|
||||
ok(!system('sudo rm -rf /'), "Wipe drive");
|
||||
}
|
||||
|
||||
=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
|
||||
193
database/perl/vendor/lib/Test2/Tools/Class.pm
vendored
Normal file
193
database/perl/vendor/lib/Test2/Tools/Class.pm
vendored
Normal file
@@ -0,0 +1,193 @@
|
||||
package Test2::Tools::Class;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::API qw/context/;
|
||||
use Test2::Util::Ref qw/render_ref/;
|
||||
|
||||
use Scalar::Util qw/blessed/;
|
||||
|
||||
our @EXPORT = qw/can_ok isa_ok DOES_ok/;
|
||||
use base 'Exporter';
|
||||
|
||||
# For easier grepping
|
||||
# sub isa_ok is defined here
|
||||
# sub can_ok is defined here
|
||||
# sub DOES_ok is defined here
|
||||
BEGIN {
|
||||
for my $op (qw/isa can DOES/) {
|
||||
my $sub = sub($;@) {
|
||||
my ($thing, @args) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
my (@items, $name);
|
||||
if (ref($args[0]) eq 'ARRAY') {
|
||||
$name = $args[1];
|
||||
@items = @{$args[0]};
|
||||
}
|
||||
else {
|
||||
@items = @args;
|
||||
}
|
||||
|
||||
my $thing_name = ref($thing) ? render_ref($thing) : defined($thing) ? "$thing" : "<undef>";
|
||||
$thing_name =~ s/\n/\\n/g;
|
||||
$thing_name =~ s/#//g;
|
||||
$thing_name =~ s/\(0x[a-f0-9]+\)//gi;
|
||||
|
||||
$name ||= @items == 1 ? "$thing_name\->$op('$items[0]')" : "$thing_name\->$op(...)";
|
||||
|
||||
unless (defined($thing) && (blessed($thing) || !ref($thing) && length($thing))) {
|
||||
my $thing = defined($thing)
|
||||
? ref($thing) || "'$thing'"
|
||||
: '<undef>';
|
||||
|
||||
$ctx->ok(0, $name, ["$thing is neither a blessed reference or a package name."]);
|
||||
|
||||
$ctx->release;
|
||||
return 0;
|
||||
}
|
||||
|
||||
unless(UNIVERSAL->can($op) || $thing->can($op)) {
|
||||
$ctx->skip($name, "'$op' is not supported on this platform");
|
||||
$ctx->release;
|
||||
return 1;
|
||||
}
|
||||
|
||||
my $file = $ctx->trace->file;
|
||||
my $line = $ctx->trace->line;
|
||||
|
||||
my @bad;
|
||||
for my $item (@items) {
|
||||
my ($bool, $ok, $err);
|
||||
|
||||
{
|
||||
local ($@, $!);
|
||||
$ok = eval qq/#line $line "$file"\n\$bool = \$thing->$op(\$item); 1/;
|
||||
$err = $@;
|
||||
}
|
||||
|
||||
die $err unless $ok;
|
||||
next if $bool;
|
||||
|
||||
push @bad => $item;
|
||||
}
|
||||
|
||||
$ctx->ok( !@bad, $name, [map { "Failed: $thing_name\->$op('$_')" } @bad]);
|
||||
|
||||
$ctx->release;
|
||||
|
||||
return !@bad;
|
||||
};
|
||||
|
||||
no strict 'refs';
|
||||
*{$op . "_ok"} = $sub;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Class - Test2 implementation of the tools for testing classes.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
L<Test2> based tools for validating classes and objects. These are similar to
|
||||
some tools from L<Test::More>, but they have a more consistent interface.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Tools::Class;
|
||||
|
||||
isa_ok($CLASS_OR_INSTANCE, $PARENT_CLASS1, $PARENT_CLASS2, ...);
|
||||
isa_ok($CLASS_OR_INSTANCE, [$PARENT_CLASS1, $PARENT_CLASS2, ...], "Test Name");
|
||||
|
||||
can_ok($CLASS_OR_INSTANCE, $METHOD1, $METHOD2, ...);
|
||||
can_ok($CLASS_OR_INSTANCE, [$METHOD1, $METHOD2, ...], "Test Name");
|
||||
|
||||
DOES_ok($CLASS_OR_INSTANCE, $ROLE1, $ROLE2, ...);
|
||||
DOES_ok($CLASS_OR_INSTANCE, [$ROLE1, $ROLE2, ...], "Test Name");
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All subs are exported by default.
|
||||
|
||||
=over 4
|
||||
|
||||
=item can_ok($thing, @methods)
|
||||
|
||||
=item can_ok($thing, \@methods, $test_name)
|
||||
|
||||
This checks that C<$thing> (either a class name, or a blessed instance) has the
|
||||
specified methods.
|
||||
|
||||
If the second argument is an arrayref then it will be used as the list of
|
||||
methods leaving the third argument to be the test name.
|
||||
|
||||
=item isa_ok($thing, @classes)
|
||||
|
||||
=item isa_ok($thing, \@classes, $test_name)
|
||||
|
||||
This checks that C<$thing> (either a class name, or a blessed instance) is or
|
||||
subclasses the specified classes.
|
||||
|
||||
If the second argument is an arrayref then it will be used as the list of
|
||||
classes leaving the third argument to be the test name.
|
||||
|
||||
=item DOES_ok($thing, @roles)
|
||||
|
||||
=item DOES_ok($thing, \@roles, $test_name)
|
||||
|
||||
This checks that C<$thing> (either a class name, or a blessed instance) does
|
||||
the specified roles.
|
||||
|
||||
If the second argument is an arrayref then it will be used as the list of
|
||||
roles leaving the third argument to be the test name.
|
||||
|
||||
B<Note 1:> This uses the C<< $class->DOES(...) >> method, not the C<does()>
|
||||
method Moose provides.
|
||||
|
||||
B<Note 2:> Not all perls have the C<DOES()> method, if you use this on those
|
||||
perls the test will be skipped.
|
||||
|
||||
=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
|
||||
514
database/perl/vendor/lib/Test2/Tools/ClassicCompare.pm
vendored
Normal file
514
database/perl/vendor/lib/Test2/Tools/ClassicCompare.pm
vendored
Normal file
@@ -0,0 +1,514 @@
|
||||
package Test2::Tools::ClassicCompare;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
our @EXPORT = qw/is is_deeply isnt like unlike cmp_ok/;
|
||||
use base 'Exporter';
|
||||
|
||||
use Carp qw/carp/;
|
||||
use Scalar::Util qw/reftype/;
|
||||
|
||||
use Test2::API qw/context/;
|
||||
use Test2::Compare qw/compare strict_convert/;
|
||||
use Test2::Util::Ref qw/rtype render_ref/;
|
||||
use Test2::Util::Table qw/table/;
|
||||
|
||||
use Test2::Compare::Array();
|
||||
use Test2::Compare::Bag();
|
||||
use Test2::Compare::Custom();
|
||||
use Test2::Compare::Event();
|
||||
use Test2::Compare::Hash();
|
||||
use Test2::Compare::Meta();
|
||||
use Test2::Compare::Number();
|
||||
use Test2::Compare::Object();
|
||||
use Test2::Compare::OrderedSubset();
|
||||
use Test2::Compare::Pattern();
|
||||
use Test2::Compare::Ref();
|
||||
use Test2::Compare::Regex();
|
||||
use Test2::Compare::Scalar();
|
||||
use Test2::Compare::Set();
|
||||
use Test2::Compare::String();
|
||||
use Test2::Compare::Undef();
|
||||
use Test2::Compare::Wildcard();
|
||||
|
||||
sub is($$;$@) {
|
||||
my ($got, $exp, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
my @caller = caller;
|
||||
|
||||
my $delta = compare($got, $exp, \&is_convert);
|
||||
|
||||
if ($delta) {
|
||||
$ctx->fail($name, $delta->diag, @diag);
|
||||
}
|
||||
else {
|
||||
$ctx->ok(1, $name);
|
||||
}
|
||||
|
||||
$ctx->release;
|
||||
return !$delta;
|
||||
}
|
||||
|
||||
sub isnt($$;$@) {
|
||||
my ($got, $exp, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
my @caller = caller;
|
||||
|
||||
my $delta = compare($got, $exp, \&isnt_convert);
|
||||
|
||||
if ($delta) {
|
||||
$ctx->fail($name, $delta->diag, @diag);
|
||||
}
|
||||
else {
|
||||
$ctx->ok(1, $name);
|
||||
}
|
||||
|
||||
$ctx->release;
|
||||
return !$delta;
|
||||
}
|
||||
|
||||
sub is_convert {
|
||||
my ($thing) = @_;
|
||||
return Test2::Compare::Undef->new()
|
||||
unless defined $thing;
|
||||
return Test2::Compare::String->new(input => $thing);
|
||||
}
|
||||
|
||||
sub isnt_convert {
|
||||
my ($thing) = @_;
|
||||
return Test2::Compare::Undef->new()
|
||||
unless defined $thing;
|
||||
my $str = Test2::Compare::String->new(input => $thing, negate => 1);
|
||||
}
|
||||
|
||||
sub like($$;$@) {
|
||||
my ($got, $exp, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
my $delta = compare($got, $exp, \&like_convert);
|
||||
|
||||
if ($delta) {
|
||||
$ctx->fail($name, $delta->diag, @diag);
|
||||
}
|
||||
else {
|
||||
$ctx->ok(1, $name);
|
||||
}
|
||||
|
||||
$ctx->release;
|
||||
return !$delta;
|
||||
}
|
||||
|
||||
sub unlike($$;$@) {
|
||||
my ($got, $exp, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
my $delta = compare($got, $exp, \&unlike_convert);
|
||||
|
||||
if ($delta) {
|
||||
$ctx->fail($name, $delta->diag, @diag);
|
||||
}
|
||||
else {
|
||||
$ctx->ok(1, $name);
|
||||
}
|
||||
|
||||
$ctx->release;
|
||||
return !$delta;
|
||||
}
|
||||
|
||||
sub like_convert {
|
||||
my ($thing) = @_;
|
||||
return Test2::Compare::Pattern->new(
|
||||
pattern => $thing,
|
||||
stringify_got => 1,
|
||||
);
|
||||
}
|
||||
|
||||
sub unlike_convert {
|
||||
my ($thing) = @_;
|
||||
return Test2::Compare::Pattern->new(
|
||||
negate => 1,
|
||||
stringify_got => 1,
|
||||
pattern => $thing,
|
||||
);
|
||||
}
|
||||
|
||||
sub is_deeply($$;$@) {
|
||||
my ($got, $exp, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
my @caller = caller;
|
||||
|
||||
my $delta = compare($got, $exp, \&strict_convert);
|
||||
|
||||
if ($delta) {
|
||||
# Temporary thing.
|
||||
my $count = 0;
|
||||
my $implicit = 0;
|
||||
my @deltas = ($delta);
|
||||
while (my $d = shift @deltas) {
|
||||
my $add = $d->children;
|
||||
push @deltas => @$add if $add && @$add;
|
||||
next if $d->verified;
|
||||
$count++;
|
||||
$implicit++ if $d->note && $d->note eq 'implicit end';
|
||||
}
|
||||
|
||||
if ($implicit == $count) {
|
||||
$ctx->ok(1, $name);
|
||||
my $meth = $ENV{AUTHOR_TESTING} ? 'throw' : 'alert';
|
||||
my $type = $delta->render_check;
|
||||
$ctx->$meth(
|
||||
join "\n",
|
||||
"!!! NOTICE OF BEHAVIOR CHANGE !!!",
|
||||
"This test uses at least 1 $type check without using end() or etc().",
|
||||
"The exising behavior is to default to etc() when inside is_deeply().",
|
||||
"The new behavior is to default to end().",
|
||||
"This test will soon start to fail with the following diagnostics:",
|
||||
$delta->diag,
|
||||
"",
|
||||
);
|
||||
}
|
||||
else {
|
||||
$ctx->fail($name, $delta->diag, @diag);
|
||||
}
|
||||
}
|
||||
else {
|
||||
$ctx->ok(1, $name);
|
||||
}
|
||||
|
||||
$ctx->release;
|
||||
return !$delta;
|
||||
}
|
||||
|
||||
our %OPS = (
|
||||
'==' => 'num',
|
||||
'!=' => 'num',
|
||||
'>=' => 'num',
|
||||
'<=' => 'num',
|
||||
'>' => 'num',
|
||||
'<' => 'num',
|
||||
'<=>' => 'num',
|
||||
|
||||
'eq' => 'str',
|
||||
'ne' => 'str',
|
||||
'gt' => 'str',
|
||||
'lt' => 'str',
|
||||
'ge' => 'str',
|
||||
'le' => 'str',
|
||||
'cmp' => 'str',
|
||||
'!~' => 'str',
|
||||
'=~' => 'str',
|
||||
|
||||
'&&' => 'logic',
|
||||
'||' => 'logic',
|
||||
'xor' => 'logic',
|
||||
'or' => 'logic',
|
||||
'and' => 'logic',
|
||||
'//' => 'logic',
|
||||
|
||||
'&' => 'bitwise',
|
||||
'|' => 'bitwise',
|
||||
|
||||
'~~' => 'match',
|
||||
);
|
||||
sub cmp_ok($$$;$@) {
|
||||
my ($got, $op, $exp, $name, @diag) = @_;
|
||||
|
||||
my $ctx = context();
|
||||
|
||||
# Warnings and syntax errors should report to the cmp_ok call, not the test
|
||||
# context. They may not be the same.
|
||||
my ($pkg, $file, $line) = caller;
|
||||
|
||||
my $type = $OPS{$op};
|
||||
if (!$type) {
|
||||
carp "operator '$op' is not supported (you can add it to %Test2::Tools::ClassicCompare::OPS)";
|
||||
$type = 'unsupported';
|
||||
}
|
||||
|
||||
local ($@, $!, $SIG{__DIE__});
|
||||
|
||||
my $test;
|
||||
my $lived = eval <<" EOT";
|
||||
#line $line "(eval in cmp_ok) $file"
|
||||
\$test = (\$got $op \$exp);
|
||||
1;
|
||||
EOT
|
||||
my $error = $@;
|
||||
$ctx->send_event('Exception', error => $error) unless $lived;
|
||||
|
||||
if ($test && $lived) {
|
||||
$ctx->ok(1, $name);
|
||||
$ctx->release;
|
||||
return 1;
|
||||
}
|
||||
|
||||
# Ugh, it failed. Do roughly the same thing Test::More did to try and show
|
||||
# diagnostics, but make it better by showing both the overloaded and
|
||||
# unoverloaded form if overloading is in play. Also unoverload numbers,
|
||||
# Test::More only unoverloaded strings.
|
||||
|
||||
my ($display_got, $display_exp);
|
||||
if($type eq 'str') {
|
||||
$display_got = defined($got) ? "$got" : undef;
|
||||
$display_exp = defined($exp) ? "$exp" : undef;
|
||||
}
|
||||
elsif($type eq 'num') {
|
||||
$display_got = defined($got) ? $got + 0 : undef;
|
||||
$display_exp = defined($exp) ? $exp + 0 : undef;
|
||||
}
|
||||
else { # Well, we did what we could.
|
||||
$display_got = $got;
|
||||
$display_exp = $exp;
|
||||
}
|
||||
|
||||
my $got_ref = ref($got) ? render_ref($got) : $got;
|
||||
my $exp_ref = ref($exp) ? render_ref($exp) : $exp;
|
||||
|
||||
my @table;
|
||||
my $show_both = (
|
||||
(defined($got) && $got_ref ne "$display_got")
|
||||
||
|
||||
(defined($exp) && $exp_ref ne "$display_exp")
|
||||
);
|
||||
|
||||
if ($show_both) {
|
||||
@table = table(
|
||||
header => ['TYPE', 'GOT', 'OP', 'CHECK'],
|
||||
rows => [
|
||||
[$type, $display_got, $op, $lived ? $display_exp : '<EXCEPTION>'],
|
||||
['orig', $got_ref, '', $exp_ref],
|
||||
],
|
||||
);
|
||||
}
|
||||
else {
|
||||
@table = table(
|
||||
header => ['GOT', 'OP', 'CHECK'],
|
||||
rows => [[$display_got, $op, $lived ? $display_exp : '<EXCEPTION>']],
|
||||
);
|
||||
}
|
||||
|
||||
$ctx->ok(0, $name, [join("\n", @table), @diag]);
|
||||
$ctx->release;
|
||||
return 0;
|
||||
}
|
||||
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::ClassicCompare - Classic (Test::More style) comparison tools.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This provides comparison functions that behave like they did in L<Test::More>,
|
||||
unlike the L<Test2::Tools::Compare> plugin which has modified them.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Tools::ClassicCompare qw/is is_deeply isnt like unlike cmp_ok/;
|
||||
|
||||
is($got, $expect, "These are the same when stringified");
|
||||
isnt($got, $unexpect, "These are not the same when stringified");
|
||||
|
||||
like($got, qr/.../, "'got' matches the pattern");
|
||||
unlike($got, qr/.../, "'got' does not match the pattern");
|
||||
|
||||
is_deeply($got, $expect, "These structures are same when checked deeply");
|
||||
|
||||
cmp_ok($GOT, $OP, $WANT, 'Compare these items using the specified operatr');
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $bool = is($got, $expect)
|
||||
|
||||
=item $bool = is($got, $expect, $name)
|
||||
|
||||
=item $bool = is($got, $expect, $name, @diag)
|
||||
|
||||
This does a string comparison of the two arguments. If the two arguments are the
|
||||
same after stringification the test passes. The test will also pass if both
|
||||
arguments are undef.
|
||||
|
||||
The test C<$name> is optional.
|
||||
|
||||
The test C<@diag> is optional, it is extra diagnostics messages that will be
|
||||
displayed if the test fails. The diagnostics are ignored if the test passes.
|
||||
|
||||
It is important to note that this tool considers C<"1"> and C<"1.0"> to not be
|
||||
equal as it uses a string comparison.
|
||||
|
||||
See L<Test2::Tools::Compare> if you want an C<is()> function that tries
|
||||
to be smarter for you.
|
||||
|
||||
=item $bool = isnt($got, $dont_expect)
|
||||
|
||||
=item $bool = isnt($got, $dont_expect, $name)
|
||||
|
||||
=item $bool = isnt($got, $dont_expect, $name, @diag)
|
||||
|
||||
This is the inverse of C<is()>, it passes when the strings are not the same.
|
||||
|
||||
=item $bool = like($got, $pattern)
|
||||
|
||||
=item $bool = like($got, $pattern, $name)
|
||||
|
||||
=item $bool = like($got, $pattern, $name, @diag)
|
||||
|
||||
Check if C<$got> matches the specified pattern. Will fail if it does not match.
|
||||
|
||||
The test C<$name> is optional.
|
||||
|
||||
The test C<@diag> is optional. It contains extra diagnostics messages that will
|
||||
be displayed if the test fails. The diagnostics are ignored if the test passes.
|
||||
|
||||
=item $bool = unlike($got, $pattern)
|
||||
|
||||
=item $bool = unlike($got, $pattern, $name)
|
||||
|
||||
=item $bool = unlike($got, $pattern, $name, @diag)
|
||||
|
||||
This is the inverse of C<like()>. This will fail if C<$got> matches
|
||||
C<$pattern>.
|
||||
|
||||
=item $bool = is_deeply($got, $expect)
|
||||
|
||||
=item $bool = is_deeply($got, $expect, $name)
|
||||
|
||||
=item $bool = is_deeply($got, $expect, $name, @diag)
|
||||
|
||||
This does a deep check, comparing the structures in C<$got> with those in
|
||||
C<$expect>. It will recurse into hashrefs, arrayrefs, and scalar refs. All
|
||||
other values will be stringified and compared as strings. It is important to
|
||||
note that this tool considers C<"1"> and C<"1.0"> to not be equal as it uses a
|
||||
string comparison.
|
||||
|
||||
This is the same as C<Test2::Tools::Compare::is()>.
|
||||
|
||||
=item cmp_ok($got, $op, $expect)
|
||||
|
||||
=item cmp_ok($got, $op, $expect, $name)
|
||||
|
||||
=item cmp_ok($got, $op, $expect, $name, @diag)
|
||||
|
||||
Compare C<$got> to C<$expect> using the operator specified in C<$op>. This is
|
||||
effectively an C<eval "\$got $op \$expect"> with some other stuff to make it
|
||||
more sane. This is useful for comparing numbers, overloaded objects, etc.
|
||||
|
||||
B<Overloading Note:> Your input is passed as-is to the comparison.
|
||||
If the comparison fails between two overloaded objects, the diagnostics will
|
||||
try to show you the overload form that was used in comparisons. It is possible
|
||||
that the diagnostics will be wrong, though attempts have been made to improve
|
||||
them since L<Test::More>.
|
||||
|
||||
B<Exceptions:> If the comparison results in an exception then the test will
|
||||
fail and the exception will be shown.
|
||||
|
||||
C<cmp_ok()> has an internal list of operators it supports. If you provide an
|
||||
unsupported operator it will issue a warning. You can add operators to the
|
||||
C<%Test2::Tools::ClassicCompare::OPS> hash, the key should be the operator, and
|
||||
the value should either be 'str' for string comparison operators, 'num' for
|
||||
numeric operators, or any other true value for other operators.
|
||||
|
||||
Supported operators:
|
||||
|
||||
=over 4
|
||||
|
||||
=item == (num)
|
||||
|
||||
=item != (num)
|
||||
|
||||
=item >= (num)
|
||||
|
||||
=item <= (num)
|
||||
|
||||
=item > (num)
|
||||
|
||||
=item < (num)
|
||||
|
||||
=item <=> (num)
|
||||
|
||||
=item eq (str)
|
||||
|
||||
=item ne (str)
|
||||
|
||||
=item gt (str)
|
||||
|
||||
=item lt (str)
|
||||
|
||||
=item ge (str)
|
||||
|
||||
=item le (str)
|
||||
|
||||
=item cmp (str)
|
||||
|
||||
=item !~ (str)
|
||||
|
||||
=item =~ (str)
|
||||
|
||||
=item &&
|
||||
|
||||
=item ||
|
||||
|
||||
=item xor
|
||||
|
||||
=item or
|
||||
|
||||
=item and
|
||||
|
||||
=item //
|
||||
|
||||
=item &
|
||||
|
||||
=item |
|
||||
|
||||
=item ~~
|
||||
|
||||
=back
|
||||
|
||||
=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
|
||||
1793
database/perl/vendor/lib/Test2/Tools/Compare.pm
vendored
Normal file
1793
database/perl/vendor/lib/Test2/Tools/Compare.pm
vendored
Normal file
File diff suppressed because it is too large
Load Diff
173
database/perl/vendor/lib/Test2/Tools/Defer.pm
vendored
Normal file
173
database/perl/vendor/lib/Test2/Tools/Defer.pm
vendored
Normal file
@@ -0,0 +1,173 @@
|
||||
package Test2::Tools::Defer;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Carp qw/croak/;
|
||||
|
||||
use Test2::Util qw/get_tid/;
|
||||
use Test2::API qw{
|
||||
test2_add_callback_exit
|
||||
test2_pid test2_tid
|
||||
};
|
||||
|
||||
our @EXPORT = qw/def do_def/;
|
||||
use base 'Exporter';
|
||||
|
||||
my %TODO;
|
||||
|
||||
sub def {
|
||||
my ($func, @args) = @_;
|
||||
|
||||
my @caller = caller(0);
|
||||
|
||||
$TODO{$caller[0]} ||= [];
|
||||
push @{$TODO{$caller[0]}} => [$func, \@args, \@caller];
|
||||
}
|
||||
|
||||
sub do_def {
|
||||
my $for = caller;
|
||||
my $tests = delete $TODO{$for} or croak "No tests to run!";
|
||||
|
||||
for my $test (@$tests) {
|
||||
my ($func, $args, $caller) = @$test;
|
||||
|
||||
my ($pkg, $file, $line) = @$caller;
|
||||
|
||||
chomp(my $eval = <<" EOT");
|
||||
package $pkg;
|
||||
# line $line "(eval in Test2::Tools::Defer) $file"
|
||||
\&$func(\@\$args);
|
||||
1;
|
||||
EOT
|
||||
|
||||
eval $eval and next;
|
||||
chomp(my $error = $@);
|
||||
|
||||
require Data::Dumper;
|
||||
chomp(my $td = Data::Dumper::Dumper($args));
|
||||
$td =~ s/^\$VAR1 =/\$args: /;
|
||||
die <<" EOT";
|
||||
Exception: $error
|
||||
--eval--
|
||||
$eval
|
||||
--------
|
||||
Tool: $func
|
||||
Caller: $caller->[0], $caller->[1], $caller->[2]
|
||||
$td
|
||||
EOT
|
||||
}
|
||||
|
||||
return;
|
||||
}
|
||||
|
||||
sub _verify {
|
||||
my ($context, $exit, $new_exit) = @_;
|
||||
|
||||
my $not_ok = 0;
|
||||
for my $pkg (keys %TODO) {
|
||||
my $tests = delete $TODO{$pkg};
|
||||
my $caller = $tests->[0]->[-1];
|
||||
print STDOUT "not ok - deferred tests were not run!\n" unless $not_ok++;
|
||||
print STDERR "# '$pkg' has deferred tests that were never run!\n";
|
||||
print STDERR "# $caller->[1] at line $caller->[2]\n";
|
||||
$$new_exit ||= 255;
|
||||
}
|
||||
}
|
||||
|
||||
test2_add_callback_exit(\&_verify);
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Defer - Write tests that get executed at a later time
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Sometimes you need to test things BEFORE loading the necessary functions. This
|
||||
module lets you do that. You can write tests, and then have them run later,
|
||||
after C<Test2> is loaded. You tell it what test function to run, and what
|
||||
arguments to give it. The function name and arguments will be stored to be
|
||||
executed later. When ready, run C<do_def()> to kick them off once the functions
|
||||
are defined.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Test2::Tools::Defer;
|
||||
|
||||
BEGIN {
|
||||
def ok => (1, 'pass');
|
||||
def is => ('foo', 'foo', 'runs is');
|
||||
...
|
||||
}
|
||||
|
||||
use Test2::Tools::Basic;
|
||||
|
||||
do_def(); # Run the tests
|
||||
|
||||
# Declare some more tests to run later:
|
||||
def ok => (1, "another pass");
|
||||
...
|
||||
|
||||
do_def(); # run the new tests
|
||||
|
||||
done_testing;
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
=over 4
|
||||
|
||||
=item def function => @args;
|
||||
|
||||
This will store the function name, and the arguments to be run later. Note that
|
||||
each package has a separate store of tests to run.
|
||||
|
||||
=item do_def()
|
||||
|
||||
This will run all the stored tests. It will also reset the list to be empty so
|
||||
you can add more tests to run even later.
|
||||
|
||||
=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
|
||||
94
database/perl/vendor/lib/Test2/Tools/Encoding.pm
vendored
Normal file
94
database/perl/vendor/lib/Test2/Tools/Encoding.pm
vendored
Normal file
@@ -0,0 +1,94 @@
|
||||
package Test2::Tools::Encoding;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp qw/croak/;
|
||||
|
||||
use Test2::API qw/test2_stack/;
|
||||
|
||||
use base 'Exporter';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
our @EXPORT = qw/set_encoding/;
|
||||
|
||||
sub set_encoding {
|
||||
my $enc = shift;
|
||||
my $format = test2_stack->top->format;
|
||||
|
||||
unless ($format && eval { $format->can('encoding') }) {
|
||||
$format = '<undef>' unless defined $format;
|
||||
croak "Unable to set encoding on formatter '$format'";
|
||||
}
|
||||
|
||||
$format->encoding($enc);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Encoding - Tools for managing the encoding of L<Test2> based
|
||||
tests.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module exports a function that lets you dynamically change the output
|
||||
encoding at will.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Tools::Encoding;
|
||||
|
||||
set_encoding('utf8');
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All subs are exported by default.
|
||||
|
||||
=over 4
|
||||
|
||||
=item set_encoding($encoding)
|
||||
|
||||
This will set the encoding to whatever you specify. This will only affect the
|
||||
output of the current formatter, which is usually your TAP output formatter.
|
||||
|
||||
=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
|
||||
95
database/perl/vendor/lib/Test2/Tools/Event.pm
vendored
Normal file
95
database/perl/vendor/lib/Test2/Tools/Event.pm
vendored
Normal file
@@ -0,0 +1,95 @@
|
||||
package Test2::Tools::Event;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::Util qw/pkg_to_file/;
|
||||
|
||||
our @EXPORT = qw/gen_event/;
|
||||
use base 'Exporter';
|
||||
|
||||
sub gen_event {
|
||||
my ($type, %fields) = @_;
|
||||
|
||||
$type = "Test2::Event::$type" unless $type =~ s/^\+//;
|
||||
|
||||
require(pkg_to_file($type));
|
||||
|
||||
$fields{trace} ||= Test2::Util::Trace->new(frame => [caller(0)]);
|
||||
|
||||
return $type->new(%fields);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Event - Tools for generating test events.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module provides tools for generating events quickly by bypassing the
|
||||
context/hub. This is particularly useful when testing other L<Test2> packages.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $e = gen_event($TYPE)
|
||||
|
||||
=item $e = gen_event($TYPE, %FIELDS)
|
||||
|
||||
=item $e = gen_event 'Ok';
|
||||
|
||||
=item $e = gen_event Ok => ( ... )
|
||||
|
||||
=item $e = gen_event '+Test2::Event::Ok' => ( ... )
|
||||
|
||||
This will produce an event of the specified type. C<$TYPE> is assumed to be
|
||||
shorthand for C<Test2::Event::$TYPE>, you can prefix C<$TYPE> with a '+' to
|
||||
drop the assumption.
|
||||
|
||||
An L<Test2::Util::Trace> will be generated using C<caller(0)> and will be put in
|
||||
the 'trace' field of your new event, unless you specified your own 'trace'
|
||||
field.
|
||||
|
||||
=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
|
||||
163
database/perl/vendor/lib/Test2/Tools/Exception.pm
vendored
Normal file
163
database/perl/vendor/lib/Test2/Tools/Exception.pm
vendored
Normal file
@@ -0,0 +1,163 @@
|
||||
package Test2::Tools::Exception;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::API qw/context/;
|
||||
|
||||
our @EXPORT = qw/dies lives try_ok/;
|
||||
use base 'Exporter';
|
||||
|
||||
sub dies(&) {
|
||||
my $code = shift;
|
||||
local ($@, $!, $?);
|
||||
my $ok = eval { $code->(); 1 };
|
||||
my $err = $@;
|
||||
|
||||
return undef if $ok;
|
||||
|
||||
unless ($err) {
|
||||
my $ctx = context();
|
||||
$ctx->alert("Got exception as expected, but exception is falsy (undef, '', or 0)...");
|
||||
$ctx->release;
|
||||
}
|
||||
|
||||
return $err;
|
||||
}
|
||||
|
||||
sub lives(&) {
|
||||
my $code = shift;
|
||||
|
||||
my $err;
|
||||
{
|
||||
local ($@, $!, $?);
|
||||
eval { $code->(); 1 } and return 1;
|
||||
$err = $@;
|
||||
}
|
||||
|
||||
# If the eval failed we want to set $@ to the error.
|
||||
$@ = $err;
|
||||
return 0;
|
||||
}
|
||||
|
||||
sub try_ok(&;$) {
|
||||
my ($code, $name) = @_;
|
||||
|
||||
my $ok = &lives($code);
|
||||
my $err = $@;
|
||||
|
||||
# Context should be obtained AFTER code is run so that events inside the
|
||||
# codeblock report inside the codeblock itself. This will also preserve $@
|
||||
# as thrown inside the codeblock.
|
||||
my $ctx = context();
|
||||
chomp(my $diag = "Exception: $err");
|
||||
$ctx->ok($ok, $name, [$diag]);
|
||||
$ctx->release;
|
||||
|
||||
$@ = $err unless $ok;
|
||||
return $ok;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Exception - Test2 based tools for checking exceptions
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This is the L<Test2> implementation of code used to test exceptions. This is
|
||||
similar to L<Test::Fatal>, but it intentionally does much less.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Tools::Exception qw/dies lives/;
|
||||
|
||||
like(
|
||||
dies { die 'xxx' },
|
||||
qr/xxx/,
|
||||
"Got exception"
|
||||
);
|
||||
|
||||
ok(lives { ... }, "did not die") or note($@);
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All subs are exported by default.
|
||||
|
||||
=over 4
|
||||
|
||||
=item $e = dies { ... }
|
||||
|
||||
This will trap any exception the codeblock throws. If no exception is thrown
|
||||
the sub will return undef. If an exception is thrown it will be returned. This
|
||||
function preserves C<$@>, it will not be altered from its value before the sub
|
||||
is called.
|
||||
|
||||
=item $bool = lives { ... }
|
||||
|
||||
This will trap any exception thrown in the codeblock. It will return true when
|
||||
there is no exception, and false when there is. C<$@> is preserved from before
|
||||
the sub is called when there is no exception. When an exception is trapped
|
||||
C<$@> will have the exception so that you can look at it.
|
||||
|
||||
=item $bool = try_ok { ... }
|
||||
|
||||
=item $bool = try_ok { ... } "Test Description"
|
||||
|
||||
This will run the code block trapping any exception. If there is no exception a
|
||||
passing event will be issued. If the test fails a failing event will be issued,
|
||||
and the exception will be reported as diagnostics.
|
||||
|
||||
B<Note:> This function does not preserve C<$@> on failure, it will be set to
|
||||
the exception the codeblock throws, this is by design so that you can obtain
|
||||
the exception if desired.
|
||||
|
||||
=back
|
||||
|
||||
=head1 DIFFERENCES FROM TEST::FATAL
|
||||
|
||||
L<Test::Fatal> sets C<$Test::Builder::Level> such that failing tests inside the
|
||||
exception block will report to the line where C<exception()> is called. I
|
||||
disagree with this, and think the actual line of the failing test is
|
||||
more important. Ultimately, though L<Test::Fatal> cannot be changed, people
|
||||
probably already depend on that behavior.
|
||||
|
||||
=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
|
||||
169
database/perl/vendor/lib/Test2/Tools/Exports.pm
vendored
Normal file
169
database/perl/vendor/lib/Test2/Tools/Exports.pm
vendored
Normal file
@@ -0,0 +1,169 @@
|
||||
package Test2::Tools::Exports;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Carp qw/croak carp/;
|
||||
use Test2::API qw/context/;
|
||||
use Test2::Util::Stash qw/get_symbol/;
|
||||
|
||||
our @EXPORT = qw/imported_ok not_imported_ok/;
|
||||
use base 'Exporter';
|
||||
|
||||
sub imported_ok {
|
||||
my $ctx = context();
|
||||
my $caller = caller;
|
||||
my @missing = grep { !get_symbol($_, $caller) } @_;
|
||||
|
||||
my $name = "Imported symbol";
|
||||
$name .= "s" if @_ > 1;
|
||||
$name .= ": ";
|
||||
my $list = join(", ", @_);
|
||||
substr($list, 37, length($list) - 37, '...') if length($list) > 40;
|
||||
$name .= $list;
|
||||
|
||||
$ctx->ok(!@missing, $name, [map { "'$_' was not imported." } @missing]);
|
||||
|
||||
$ctx->release;
|
||||
|
||||
return !@missing;
|
||||
}
|
||||
|
||||
sub not_imported_ok {
|
||||
my $ctx = context();
|
||||
my $caller = caller;
|
||||
my @found = grep { get_symbol($_, $caller) } @_;
|
||||
|
||||
my $name = "Did not imported symbol";
|
||||
$name .= "s" if @_ > 1;
|
||||
$name .= ": ";
|
||||
my $list = join(", ", @_);
|
||||
substr($list, 37, length($list) - 37, '...') if length($list) > 40;
|
||||
$name .= $list;
|
||||
|
||||
$ctx->ok(!@found, $name, [map { "'$_' was imported." } @found]);
|
||||
|
||||
$ctx->release;
|
||||
|
||||
return !@found;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Exports - Tools for validating exporters.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
These are tools for checking that symbols have been imported into your
|
||||
namespace.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Tools::Exports
|
||||
|
||||
use Data::Dumper;
|
||||
imported_ok qw/Dumper/;
|
||||
not_imported_ok qw/dumper/;
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All subs are exported by default.
|
||||
|
||||
=over 4
|
||||
|
||||
=item imported_ok(@SYMBOLS)
|
||||
|
||||
Check that the specified symbols exist in the current package. This will not
|
||||
find inherited subs. This will only find symbols in the current package's symbol
|
||||
table. This B<WILL NOT> confirm that the symbols were defined outside of the
|
||||
package itself.
|
||||
|
||||
imported_ok( '$scalar', '@array', '%hash', '&sub', 'also_a_sub' );
|
||||
|
||||
C<@SYMBOLS> can contain any number of symbols. Each item in the array must be a
|
||||
string. The string should be the name of a symbol. If a sigil is present then
|
||||
it will search for that specified type, if no sigil is specified it will be
|
||||
used as a sub name.
|
||||
|
||||
=item not_imported_ok(@SYMBOLS)
|
||||
|
||||
Check that the specified symbols do not exist in the current package. This will
|
||||
not find inherited subs. This will only look at symbols in the current package's
|
||||
symbol table.
|
||||
|
||||
not_imported_ok( '$scalar', '@array', '%hash', '&sub', 'also_a_sub' );
|
||||
|
||||
C<@SYMBOLS> can contain any number of symbols. Each item in the array must be a
|
||||
string. The string should be the name of a symbol. If a sigil is present, then
|
||||
it will search for that specified type. If no sigil is specified, it will be
|
||||
used as a sub name.
|
||||
|
||||
=back
|
||||
|
||||
=head1 CAVEATS
|
||||
|
||||
Before Perl 5.10, it is very difficult to distinguish between a package scalar
|
||||
that is undeclared vs declared and undefined. Currently C<imported_ok> and
|
||||
C<not_imported_ok> cannot see package scalars declared using C<our $var> unless
|
||||
the variable has been assigned a defined value.
|
||||
|
||||
This will pass on recent perls, but fail on perls older than 5.10:
|
||||
|
||||
use Test2::Tools::Exports;
|
||||
|
||||
our $foo;
|
||||
|
||||
# Fails on perl onlder than 5.10
|
||||
imported_ok(qw/$foo/);
|
||||
|
||||
If C<$foo> is imported from another module, or imported using
|
||||
C<use vars qw/$foo/;> then it will work on all supported perl versions.
|
||||
|
||||
use Test2::Tools::Exports;
|
||||
|
||||
use vars qw/$foo/;
|
||||
use Some::Module qw/$bar/;
|
||||
|
||||
# Always works
|
||||
imported_ok(qw/$foo $bar/);
|
||||
|
||||
=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
|
||||
125
database/perl/vendor/lib/Test2/Tools/GenTemp.pm
vendored
Normal file
125
database/perl/vendor/lib/Test2/Tools/GenTemp.pm
vendored
Normal file
@@ -0,0 +1,125 @@
|
||||
package Test2::Tools::GenTemp;
|
||||
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use File::Temp qw/tempdir/;
|
||||
use File::Spec;
|
||||
|
||||
our @EXPORT = qw{gen_temp};
|
||||
use base 'Exporter';
|
||||
|
||||
sub gen_temp {
|
||||
my %args = @_;
|
||||
|
||||
my $tempdir_args = delete $args{'-tempdir'} || [CLEANUP => 1, TMPDIR => 1];
|
||||
|
||||
my $tmp = tempdir(@$tempdir_args);
|
||||
|
||||
gen_dir($tmp, \%args);
|
||||
|
||||
return $tmp;
|
||||
}
|
||||
|
||||
sub gen_dir {
|
||||
my ($dir, $content) = @_;
|
||||
|
||||
for my $path (keys %$content) {
|
||||
my $fq = File::Spec->catfile($dir, $path);
|
||||
my $inside = $content->{$path};
|
||||
|
||||
if (ref $inside) {
|
||||
# Subdirectory
|
||||
mkdir($fq) or die "Could not make dir '$fq': $!";
|
||||
gen_dir($fq, $inside);
|
||||
}
|
||||
else {
|
||||
open(my $fh, '>', $fq) or die "Could not open file '$fq' for writing: $!";
|
||||
print $fh $inside;
|
||||
close($fh);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::GenTemp - Tool for generating a populated temp directory.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This exports a tool that helps you make a temporary directory, nested
|
||||
directories and text files within.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Tools::GenTemp qw/gen_temp/;
|
||||
|
||||
my $dir = gen_temp(
|
||||
a_file => "Contents of a_file",
|
||||
a_dir => {
|
||||
'a_file' => 'Contents of a_dir/afile',
|
||||
a_nested_dir => { ... },
|
||||
},
|
||||
...
|
||||
);
|
||||
|
||||
done_testing;
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All subs are exported by default.
|
||||
|
||||
=over 4
|
||||
|
||||
=item gen_temp(file => 'content', subdir => [ sub_dir_file => 'content', ...], ...)
|
||||
|
||||
=item gen_temp(-tempdir => \@TEMPDIR_ARGS, file => 'content', subdir => [ sub_dir_file => 'content', ...], ...)
|
||||
|
||||
This will generate a new temporary directory with all the files and subdirs you
|
||||
specify, recursively. The initial temp directory is created using
|
||||
C<File::Temp::tempdir()>, you may pass arguments to tempdir using the
|
||||
C<< -tempdir => [...] >> argument.
|
||||
|
||||
=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
|
||||
124
database/perl/vendor/lib/Test2/Tools/Grab.pm
vendored
Normal file
124
database/perl/vendor/lib/Test2/Tools/Grab.pm
vendored
Normal file
@@ -0,0 +1,124 @@
|
||||
package Test2::Tools::Grab;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::Util::Grabber;
|
||||
use Test2::EventFacet::Trace();
|
||||
|
||||
our @EXPORT = qw/grab/;
|
||||
use base 'Exporter';
|
||||
|
||||
sub grab { Test2::Util::Grabber->new(trace => Test2::EventFacet::Trace->new(frame => [caller(0)]) ) }
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Grab - Temporarily intercept all events without adding a scope
|
||||
level.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package provides a function that returns an object that grabs all events.
|
||||
Once the object is destroyed events will once again be sent to the main hub.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Tools::Grab;
|
||||
|
||||
my $grab = grab();
|
||||
|
||||
# Generate some events, they are intercepted.
|
||||
ok(1, "pass");
|
||||
ok(0, "fail");
|
||||
|
||||
my $events_a = $grab->flush;
|
||||
|
||||
# Generate some more events, they are intercepted.
|
||||
ok(1, "pass");
|
||||
ok(0, "fail");
|
||||
|
||||
my $events_b = $grab->finish;
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $grab = grab()
|
||||
|
||||
This lets you intercept all events for a section of code without adding
|
||||
anything to your call stack. This is useful for things that are sensitive to
|
||||
changes in the stack depth.
|
||||
|
||||
my $grab = grab();
|
||||
ok(1, 'foo');
|
||||
ok(0, 'bar');
|
||||
|
||||
my $events = $grab->finish;
|
||||
|
||||
is(@$events, 2, "grabbed 2 events.");
|
||||
|
||||
If the C<$grab> object is destroyed without calling C<finish()>, it will
|
||||
automatically clean up after itself and restore the parent hub.
|
||||
|
||||
{
|
||||
my $grab = grab();
|
||||
# Things are grabbed
|
||||
}
|
||||
# Things are back to normal
|
||||
|
||||
By default the hub used has C<no_ending> set to true. This will prevent the hub
|
||||
from enforcing that you issued a plan and ran at least 1 test. You can turn
|
||||
enforcement back one like this:
|
||||
|
||||
$grab->hub->set_no_ending(0);
|
||||
|
||||
With C<no_ending> turned off, C<finish> will run the post-test checks to
|
||||
enforce the plan and that tests were run. In many cases this will result in
|
||||
additional events in your events array.
|
||||
|
||||
=back
|
||||
|
||||
=head1 SEE ALSO
|
||||
|
||||
L<Test2::Util::Grabber> - The object constructed and returned by this tool.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2 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
|
||||
541
database/perl/vendor/lib/Test2/Tools/Mock.pm
vendored
Normal file
541
database/perl/vendor/lib/Test2/Tools/Mock.pm
vendored
Normal file
@@ -0,0 +1,541 @@
|
||||
package Test2::Tools::Mock;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
use Carp qw/croak/;
|
||||
use Scalar::Util qw/blessed reftype weaken/;
|
||||
use Test2::Util qw/try/;
|
||||
use Test2::Util::Sub qw/gen_accessor gen_reader gen_writer/;
|
||||
|
||||
use Test2::Mock();
|
||||
|
||||
use base 'Exporter';
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
our @CARP_NOT = (__PACKAGE__, 'Test2::Mock');
|
||||
our @EXPORT = qw/mock mocked/;
|
||||
our @EXPORT_OK = qw{
|
||||
mock_obj mock_class
|
||||
mock_do mock_build
|
||||
mock_accessor mock_accessors
|
||||
mock_getter mock_getters
|
||||
mock_setter mock_setters
|
||||
mock_building
|
||||
};
|
||||
|
||||
my %HANDLERS;
|
||||
my %MOCKS;
|
||||
my @BUILD;
|
||||
|
||||
sub add_handler {
|
||||
my $class = shift;
|
||||
my ($for, $code) = @_;
|
||||
|
||||
croak "Must specify a package for the mock handler"
|
||||
unless $for;
|
||||
|
||||
croak "Handlers must be code referneces (got: $code)"
|
||||
unless $code && ref($code) eq 'CODE';
|
||||
|
||||
push @{$HANDLERS{$for}} => $code;
|
||||
}
|
||||
|
||||
sub mock_building {
|
||||
return unless @BUILD;
|
||||
return $BUILD[-1];
|
||||
}
|
||||
|
||||
sub mocked {
|
||||
my $proto = shift;
|
||||
my $class = blessed($proto) || $proto;
|
||||
|
||||
# Check if we have any mocks.
|
||||
my $set = $MOCKS{$class} || return;
|
||||
|
||||
# Remove dead mocks (undef due to weaken)
|
||||
pop @$set while @$set && !defined($set->[-1]);
|
||||
|
||||
# Remove the list if it is empty
|
||||
delete $MOCKS{$class} unless @$set;
|
||||
|
||||
# Return the controls (may be empty list)
|
||||
return @$set;
|
||||
}
|
||||
|
||||
sub _delegate {
|
||||
my ($args) = @_;
|
||||
|
||||
my $do = __PACKAGE__->can('mock_do');
|
||||
my $obj = __PACKAGE__->can('mock_obj');
|
||||
my $class = __PACKAGE__->can('mock_class');
|
||||
my $build = __PACKAGE__->can('mock_build');
|
||||
|
||||
return $obj unless @$args;
|
||||
|
||||
my ($proto, $arg1) = @$args;
|
||||
|
||||
return $obj if ref($proto) && !blessed($proto);
|
||||
|
||||
if (blessed($proto)) {
|
||||
return $class unless $proto->isa('Test2::Mock');
|
||||
return $build if $arg1 && ref($arg1) && reftype($arg1) eq 'CODE';
|
||||
}
|
||||
|
||||
return $class if $proto =~ m/(?:::|')/;
|
||||
return $class if $proto =~ m/^_*[A-Z]/;
|
||||
|
||||
return $do if Test2::Mock->can($proto);
|
||||
|
||||
if (my $sub = __PACKAGE__->can("mock_$proto")) {
|
||||
shift @$args;
|
||||
return $sub;
|
||||
}
|
||||
|
||||
return undef;
|
||||
}
|
||||
|
||||
sub mock {
|
||||
croak "undef is not a valid first argument to mock()"
|
||||
if @_ && !defined($_[0]);
|
||||
|
||||
my $sub = _delegate(\@_);
|
||||
|
||||
croak "'$_[0]' does not look like a package name, and is not a valid control method"
|
||||
unless $sub;
|
||||
|
||||
$sub->(@_);
|
||||
}
|
||||
|
||||
sub mock_build {
|
||||
my ($control, $sub) = @_;
|
||||
|
||||
croak "mock_build requires a Test2::Mock object as its first argument"
|
||||
unless $control && blessed($control) && $control->isa('Test2::Mock');
|
||||
|
||||
croak "mock_build requires a coderef as its second argument"
|
||||
unless $sub && ref($sub) && reftype($sub) eq 'CODE';
|
||||
|
||||
push @BUILD => $control;
|
||||
my ($ok, $err) = &try($sub);
|
||||
pop @BUILD;
|
||||
die $err unless $ok;
|
||||
}
|
||||
|
||||
sub mock_do {
|
||||
my ($meth, @args) = @_;
|
||||
|
||||
croak "Not currently building a mock"
|
||||
unless @BUILD;
|
||||
|
||||
my $build = $BUILD[-1];
|
||||
|
||||
croak "'$meth' is not a valid action for mock_do()"
|
||||
if $meth =~ m/^_/ || !$build->can($meth);
|
||||
|
||||
$build->$meth(@args);
|
||||
}
|
||||
|
||||
sub mock_obj {
|
||||
my ($proto) = @_;
|
||||
|
||||
if ($proto && ref($proto) && reftype($proto) ne 'CODE') {
|
||||
shift @_;
|
||||
}
|
||||
else {
|
||||
$proto = {};
|
||||
}
|
||||
|
||||
my $class = _generate_class();
|
||||
my $control;
|
||||
|
||||
if (@_ == 1 && reftype($_[0]) eq 'CODE') {
|
||||
my $orig = shift @_;
|
||||
$control = mock_class(
|
||||
$class,
|
||||
sub {
|
||||
my $c = mock_building;
|
||||
|
||||
# We want to do these BEFORE anything that the sub may do.
|
||||
$c->block_load(1);
|
||||
$c->purge_on_destroy(1);
|
||||
$c->autoload(1);
|
||||
|
||||
$orig->(@_);
|
||||
},
|
||||
);
|
||||
}
|
||||
else {
|
||||
$control = mock_class(
|
||||
$class,
|
||||
# Do these before anything the user specified.
|
||||
block_load => 1,
|
||||
purge_on_destroy => 1,
|
||||
autoload => 1,
|
||||
@_,
|
||||
);
|
||||
}
|
||||
|
||||
my $new = bless($proto, $control->class);
|
||||
|
||||
# We need to ensure there is a reference to the control object, and we want
|
||||
# it to go away with the object.
|
||||
$new->{'~~MOCK~CONTROL~~'} = $control;
|
||||
return $new;
|
||||
}
|
||||
|
||||
sub _generate_class {
|
||||
my $prefix = __PACKAGE__;
|
||||
|
||||
for (1 .. 100) {
|
||||
my $postfix = join '', map { chr(rand(26) + 65) } 1 .. 32;
|
||||
my $class = $prefix . '::__TEMP__::' . $postfix;
|
||||
my $file = $class;
|
||||
$file =~ s{::}{/}g;
|
||||
$file .= '.pm';
|
||||
next if $INC{$file};
|
||||
my $stash = do { no strict 'refs'; \%{"${class}\::"} };
|
||||
next if keys %$stash;
|
||||
return $class;
|
||||
}
|
||||
|
||||
croak "Could not generate a unique class name after 100 attempts";
|
||||
}
|
||||
|
||||
sub mock_class {
|
||||
my $proto = shift;
|
||||
my $class = blessed($proto) || $proto;
|
||||
my @args = @_;
|
||||
|
||||
my $void = !defined(wantarray);
|
||||
|
||||
my $callback = sub {
|
||||
my ($parent) = reverse mocked($class);
|
||||
my $control;
|
||||
|
||||
if (@args == 1 && ref($args[0]) && reftype($args[0]) eq 'CODE') {
|
||||
$control = Test2::Mock->new(class => $class);
|
||||
mock_build($control, @args);
|
||||
}
|
||||
else {
|
||||
$control = Test2::Mock->new(class => $class, @args);
|
||||
}
|
||||
|
||||
if ($parent) {
|
||||
$control->{parent} = $parent;
|
||||
weaken($parent->{child} = $control);
|
||||
}
|
||||
|
||||
$MOCKS{$class} ||= [];
|
||||
push @{$MOCKS{$class}} => $control;
|
||||
weaken($MOCKS{$class}->[-1]);
|
||||
|
||||
return $control;
|
||||
};
|
||||
|
||||
return $callback->() unless $void;
|
||||
|
||||
my $level = 0;
|
||||
my $caller;
|
||||
while (my @call = caller($level++)) {
|
||||
next if $call[0] eq __PACKAGE__;
|
||||
$caller = \@call;
|
||||
last;
|
||||
}
|
||||
|
||||
my $handled;
|
||||
for my $handler (@{$HANDLERS{$caller->[0]}}) {
|
||||
$handled++ if $handler->(
|
||||
class => $class,
|
||||
caller => $caller,
|
||||
builder => $callback,
|
||||
args => \@args,
|
||||
);
|
||||
}
|
||||
|
||||
croak "mock_class should not be called in a void context without a registered handler"
|
||||
unless $handled;
|
||||
}
|
||||
|
||||
sub mock_accessors {
|
||||
return map {( $_ => gen_accessor($_) )} @_;
|
||||
}
|
||||
|
||||
sub mock_accessor {
|
||||
my ($field) = @_;
|
||||
return gen_accessor($field);
|
||||
}
|
||||
|
||||
sub mock_getters {
|
||||
my ($prefix, @list) = @_;
|
||||
return map {( "$prefix$_" => gen_reader($_) )} @list;
|
||||
}
|
||||
|
||||
sub mock_getter {
|
||||
my ($field) = @_;
|
||||
return gen_reader($field);
|
||||
}
|
||||
|
||||
sub mock_setters {
|
||||
my ($prefix, @list) = @_;
|
||||
return map {( "$prefix$_" => gen_writer($_) )} @list;
|
||||
}
|
||||
|
||||
sub mock_setter {
|
||||
my ($field) = @_;
|
||||
return gen_writer($field);
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Mock - Class/Instance mocking for Test2.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
Mocking is often an essential part of testing. This library covers some of the
|
||||
most common mocking needs. This plugin is heavily influenced by L<Mock::Quick>,
|
||||
but with an improved API. This plugin is also intended to play well with other
|
||||
plugins in ways L<Mock::Quick> would be unable to.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
my $mock = mock 'Some::Class' => (
|
||||
track => $BOOL, # Enable/Disable tracking on subs defined below
|
||||
|
||||
add => [
|
||||
new_method => sub { ... },
|
||||
],
|
||||
override => [
|
||||
replace_method => sub { ... },
|
||||
],
|
||||
set => [
|
||||
replace_or_inject => sub { ... },
|
||||
],
|
||||
|
||||
track => $bool, # enable/disable tracking again to affect mocks made after this point
|
||||
..., # Argument keys may be repeated
|
||||
);
|
||||
|
||||
Some::Class->new_method(); # Calls the newly injected method
|
||||
Some::Class->replace_method(); # Calls our replacement method.
|
||||
|
||||
$mock->override(...) # Override some more
|
||||
|
||||
$mock = undef; # Undoes all the mocking, restoring all original methods.
|
||||
|
||||
my $simple_mock = mock {} => (
|
||||
add => [
|
||||
is_active => sub { ... }
|
||||
]
|
||||
);
|
||||
|
||||
$simple_mock->is_active(); # Calls our newly mocked method.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
=head2 DEFAULT
|
||||
|
||||
=over 4
|
||||
|
||||
=item mock
|
||||
|
||||
This is a one-stop shop function that delegates to one of the other methods
|
||||
depending on how it is used. If you are not comfortable with a function that
|
||||
has a lot of potential behaviors, you can use one of the other functions
|
||||
directly.
|
||||
|
||||
=item @mocks = mocked($object)
|
||||
|
||||
=item @mocks = mocked($class)
|
||||
|
||||
Check if an object or class is mocked. If it is mocked the C<$mock> object(s)
|
||||
(L<Test2::Mock>) will be returned.
|
||||
|
||||
=item $mock = mock $class => ( ... );
|
||||
|
||||
=item $mock = mock $instance => ( ... )
|
||||
|
||||
=item $mock = mock 'class', $class => ( ... )
|
||||
|
||||
These forms delegate to C<mock_class()> to mock a package. The third form is to
|
||||
be explicit about what type of mocking you want.
|
||||
|
||||
=item $obj = mock()
|
||||
|
||||
=item $obj = mock { ... }
|
||||
|
||||
=item $obj = mock 'obj', ...;
|
||||
|
||||
These forms delegate to C<mock_obj()> to create instances of anonymous packages
|
||||
where methods are vivified into existence as needed.
|
||||
|
||||
=item mock $mock => sub { ... }
|
||||
|
||||
=item mock $method => ( ... )
|
||||
|
||||
These forms go together, the first form will set C<$mock> as the current mock
|
||||
build, then run the sub. Within the sub you can declare mock specifications
|
||||
using the second form. The first form delegates to C<mock_build()>.
|
||||
|
||||
The second form calls the specified method on the current build. This second
|
||||
form delegates to C<mock_do()>.
|
||||
|
||||
=back
|
||||
|
||||
=head2 BY REQUEST
|
||||
|
||||
=head3 DEFINING MOCKS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $obj = mock_obj( ... )
|
||||
|
||||
=item $obj = mock_obj { ... } => ( ... )
|
||||
|
||||
=item $obj = mock_obj sub { ... }
|
||||
|
||||
=item $obj = mock_obj { ... } => sub { ... }
|
||||
|
||||
This method lets you quickly generate a blessed object. The object will be an
|
||||
instance of a randomly generated package name. Methods will vivify as
|
||||
read/write accessors as needed.
|
||||
|
||||
Arguments can be any method available to L<Test2::Mock> followed by an
|
||||
argument. If the very first argument is a hashref then it will be blessed as
|
||||
your new object.
|
||||
|
||||
If you provide a coderef instead of key/value pairs, the coderef will be run to
|
||||
build the mock. (See the L</"BUILDING MOCKS"> section).
|
||||
|
||||
=item $mock = mock_class $class => ( ... )
|
||||
|
||||
=item $mock = mock_class $instance => ( ... )
|
||||
|
||||
=item $mock = mock_class ... => sub { ... }
|
||||
|
||||
This will create a new instance of L<Test2::Mock> to control the package
|
||||
specified. If you give it a blessed reference it will use the class of the
|
||||
instance.
|
||||
|
||||
Arguments can be any method available to L<Test2::Mock> followed by an
|
||||
argument. If the very first argument is a hashref then it will be blessed as
|
||||
your new object.
|
||||
|
||||
If you provide a coderef instead of key/value pairs, the coderef will be run to
|
||||
build the mock. (See the L</"BUILDING MOCKS"> section).
|
||||
|
||||
=back
|
||||
|
||||
=head3 BUILDING MOCKS
|
||||
|
||||
=over 4
|
||||
|
||||
=item mock_build $mock => sub { ... }
|
||||
|
||||
Set C<$mock> as the current build, then run the specified code. C<$mock> will
|
||||
no longer be the current build when the sub is complete.
|
||||
|
||||
=item $mock = mock_building()
|
||||
|
||||
Get the current building C<$mock> object.
|
||||
|
||||
=item mock_do $method => $args
|
||||
|
||||
Run the specified method on the currently building object.
|
||||
|
||||
=back
|
||||
|
||||
=head3 METHOD GENERATORS
|
||||
|
||||
=over 4
|
||||
|
||||
=item $sub = mock_accessor $field
|
||||
|
||||
Generate a read/write accessor for the specified field. This will generate a sub like the following:
|
||||
|
||||
$sub = sub {
|
||||
my $self = shift;
|
||||
($self->{$field}) = @_ if @_;
|
||||
return $self->{$field};
|
||||
};
|
||||
|
||||
=item $sub = mock_getter $field
|
||||
|
||||
Generate a read only accessor for the specified field. This will generate a sub like the following:
|
||||
|
||||
$sub = sub {
|
||||
my $self = shift;
|
||||
return $self->{$field};
|
||||
};
|
||||
|
||||
=item $sub = mock_setter $field
|
||||
|
||||
Generate a write accessor for the specified field. This will generate a sub like the following:
|
||||
|
||||
$sub = sub {
|
||||
my $self = shift;
|
||||
($self->{$field}) = @_;
|
||||
};
|
||||
|
||||
=item %pairs = mock_accessors(qw/name1 name2 name3/)
|
||||
|
||||
Generates several read/write accessors at once, returns key/value pairs where
|
||||
the key is the field name, and the value is the coderef.
|
||||
|
||||
=item %pairs = mock_getters(qw/name1 name2 name3/)
|
||||
|
||||
Generates several read only accessors at once, returns key/value pairs where
|
||||
the key is the field name, and the value is the coderef.
|
||||
|
||||
=item %pairs = mock_setters(qw/name1 name2 name3/)
|
||||
|
||||
Generates several write accessors at once, returns key/value pairs where the
|
||||
key is the field name, and the value is the coderef.
|
||||
|
||||
=back
|
||||
|
||||
=head1 MOCK CONTROL OBJECTS
|
||||
|
||||
my $mock = mock(...);
|
||||
|
||||
Mock objects are instances of L<Test2::Mock>. See it for their methods.
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2-Suite can be found at
|
||||
L<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 L<https://dev.perl.org/licenses/>
|
||||
|
||||
=cut
|
||||
173
database/perl/vendor/lib/Test2/Tools/Ref.pm
vendored
Normal file
173
database/perl/vendor/lib/Test2/Tools/Ref.pm
vendored
Normal file
@@ -0,0 +1,173 @@
|
||||
package Test2::Tools::Ref;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Scalar::Util qw/reftype refaddr/;
|
||||
use Test2::API qw/context/;
|
||||
use Test2::Util::Ref qw/render_ref/;
|
||||
|
||||
our @EXPORT = qw/ref_ok ref_is ref_is_not/;
|
||||
use base 'Exporter';
|
||||
|
||||
sub ref_ok($;$$) {
|
||||
my ($thing, $wanttype, $name) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
my $gotname = render_ref($thing);
|
||||
my $gottype = reftype($thing);
|
||||
|
||||
if (!$gottype) {
|
||||
$ctx->ok(0, $name, ["'$gotname' is not a reference"]);
|
||||
$ctx->release;
|
||||
return 0;
|
||||
}
|
||||
|
||||
if ($wanttype && $gottype ne $wanttype) {
|
||||
$ctx->ok(0, $name, ["'$gotname' is not a '$wanttype' reference"]);
|
||||
$ctx->release;
|
||||
return 0;
|
||||
}
|
||||
|
||||
$ctx->ok(1, $name);
|
||||
$ctx->release;
|
||||
return 1;
|
||||
}
|
||||
|
||||
sub ref_is($$;$@) {
|
||||
my ($got, $exp, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
$got = '<undef>' unless defined $got;
|
||||
$exp = '<undef>' unless defined $exp;
|
||||
|
||||
my $bool = 0;
|
||||
if (!ref($got)) {
|
||||
$ctx->ok(0, $name, ["First argument '$got' is not a reference", @diag]);
|
||||
}
|
||||
elsif(!ref($exp)) {
|
||||
$ctx->ok(0, $name, ["Second argument '$exp' is not a reference", @diag]);
|
||||
}
|
||||
else {
|
||||
# Don't let overloading mess with us.
|
||||
$bool = refaddr($got) == refaddr($exp);
|
||||
$ctx->ok($bool, $name, ["'$got' is not the same reference as '$exp'", @diag]);
|
||||
}
|
||||
|
||||
$ctx->release;
|
||||
return $bool ? 1 : 0;
|
||||
}
|
||||
|
||||
sub ref_is_not($$;$) {
|
||||
my ($got, $exp, $name, @diag) = @_;
|
||||
my $ctx = context();
|
||||
|
||||
$got = '<undef>' unless defined $got;
|
||||
$exp = '<undef>' unless defined $exp;
|
||||
|
||||
my $bool = 0;
|
||||
if (!ref($got)) {
|
||||
$ctx->ok(0, $name, ["First argument '$got' is not a reference", @diag]);
|
||||
}
|
||||
elsif(!ref($exp)) {
|
||||
$ctx->ok(0, $name, ["Second argument '$exp' is not a reference", @diag]);
|
||||
}
|
||||
else {
|
||||
# Don't let overloading mess with us.
|
||||
$bool = refaddr($got) != refaddr($exp);
|
||||
$ctx->ok($bool, $name, ["'$got' is the same reference as '$exp'", @diag]);
|
||||
}
|
||||
|
||||
$ctx->release;
|
||||
return $bool ? 1 : 0;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Ref - Tools for validating references.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This module contains tools that allow you to verify that something is a ref. It
|
||||
also has tools to check if two refs are the same exact ref, or different. None of
|
||||
the functions in this module do deep comparisons.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Tools::Ref;
|
||||
|
||||
# Ensure something is a ref.
|
||||
ref_ok($ref);
|
||||
|
||||
# Check that $ref is a HASH reference
|
||||
ref_ok($ref, 'HASH', 'Must be a hash')
|
||||
|
||||
ref_is($refa, $refb, "Same exact reference");
|
||||
|
||||
ref_is_not($refa, $refb, "Not the same exact reference");
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All subs are exported by default.
|
||||
|
||||
=over 4
|
||||
|
||||
=item ref_ok($thing)
|
||||
|
||||
=item ref_ok($thing, $type)
|
||||
|
||||
=item ref_ok($thing, $type, $name)
|
||||
|
||||
This checks that C<$thing> is a reference. If C<$type> is specified then it
|
||||
will check that C<$thing> is that type of reference.
|
||||
|
||||
=item ref_is($ref1, $ref2, $name)
|
||||
|
||||
Verify that two references are the exact same reference.
|
||||
|
||||
=item ref_is_not($ref1, $ref2, $name)
|
||||
|
||||
Verify that two references are not the exact same reference.
|
||||
|
||||
=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
|
||||
676
database/perl/vendor/lib/Test2/Tools/Spec.pm
vendored
Normal file
676
database/perl/vendor/lib/Test2/Tools/Spec.pm
vendored
Normal file
@@ -0,0 +1,676 @@
|
||||
package Test2::Tools::Spec;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Carp qw/croak/;
|
||||
use Test2::Workflow qw/parse_args build current_build root_build init_root build_stack/;
|
||||
|
||||
use Test2::API qw/test2_add_callback_testing_done/;
|
||||
|
||||
use Test2::Workflow::Runner();
|
||||
use Test2::Workflow::Task::Action();
|
||||
use Test2::Workflow::Task::Group();
|
||||
use Test2::Tools::Mock();
|
||||
use Importer();
|
||||
|
||||
use vars qw/@EXPORT @EXPORT_OK/;
|
||||
push @EXPORT => qw{describe cases};
|
||||
push @EXPORT_OK => qw{include_workflow include_workflows spec_defaults};
|
||||
|
||||
my %HANDLED;
|
||||
sub import {
|
||||
my $class = shift;
|
||||
my @caller = caller(0);
|
||||
|
||||
my %root_args;
|
||||
my %runner_args;
|
||||
my @import;
|
||||
while (my $arg = shift @_) {
|
||||
if ($arg =~ s/^-//) {
|
||||
my $val = shift @_;
|
||||
|
||||
if (Test2::Workflow::Runner->can($arg)) {
|
||||
$runner_args{$arg} = $val;
|
||||
}
|
||||
elsif (Test2::Workflow::Task::Group->can($arg)) {
|
||||
$root_args{$arg} = $val;
|
||||
}
|
||||
elsif ($arg eq 'root_args') {
|
||||
%root_args = (%root_args, %$val);
|
||||
}
|
||||
elsif ($arg eq 'runner_args') {
|
||||
%runner_args = (%runner_args, %$val);
|
||||
}
|
||||
else {
|
||||
croak "Unrecognized arg: $arg";
|
||||
}
|
||||
}
|
||||
else {
|
||||
push @import => $arg;
|
||||
}
|
||||
}
|
||||
|
||||
if ($HANDLED{$caller[0]}++) {
|
||||
croak "Package $caller[0] has already been initialized"
|
||||
if keys(%root_args) || keys(%runner_args);
|
||||
}
|
||||
else {
|
||||
my $root = init_root(
|
||||
$caller[0],
|
||||
frame => \@caller,
|
||||
code => sub { 1 },
|
||||
%root_args,
|
||||
);
|
||||
|
||||
my $runner = Test2::Workflow::Runner->new(%runner_args);
|
||||
|
||||
Test2::Tools::Mock->add_handler(
|
||||
$caller[0],
|
||||
sub {
|
||||
my %params = @_;
|
||||
my ($class, $caller, $builder, $args) = @params{qw/class caller builder args/};
|
||||
|
||||
my $do_it = eval "package $caller->[0];\n#line $caller->[2] \"$caller->[1]\"\nsub { \$runner\->add_mock(\$builder->()) }";
|
||||
|
||||
# Running
|
||||
if (@{$runner->stack}) {
|
||||
$do_it->();
|
||||
}
|
||||
else { # Not running
|
||||
my $action = Test2::Workflow::Task::Action->new(
|
||||
code => $do_it,
|
||||
name => "mock $class",
|
||||
frame => $caller,
|
||||
scaffold => 1,
|
||||
);
|
||||
|
||||
my $build = current_build() || $root;
|
||||
|
||||
$build->add_primary_setup($action);
|
||||
$build->add_stash($builder->()) unless $build->is_root;
|
||||
}
|
||||
|
||||
return 1;
|
||||
}
|
||||
);
|
||||
|
||||
test2_add_callback_testing_done(
|
||||
sub {
|
||||
return unless $root->populated;
|
||||
my $g = $root->compile;
|
||||
$runner->push_task($g);
|
||||
$runner->run;
|
||||
}
|
||||
);
|
||||
}
|
||||
|
||||
Importer->import_into($class, $caller[0], @import);
|
||||
}
|
||||
|
||||
{
|
||||
no warnings 'once';
|
||||
*cases = \&describe;
|
||||
*include_workflows = \&include_workflow;
|
||||
}
|
||||
|
||||
sub describe {
|
||||
my @caller = caller(0);
|
||||
|
||||
my $want = wantarray;
|
||||
|
||||
my $build = build(args => \@_, caller => \@caller, stack_stop => defined $want ? 1 : 0);
|
||||
|
||||
return $build if defined $want;
|
||||
|
||||
my $current = current_build() || root_build($caller[0])
|
||||
or croak "No current workflow build!";
|
||||
|
||||
$current->add_primary($build);
|
||||
}
|
||||
|
||||
sub include_workflow {
|
||||
my @caller = caller(0);
|
||||
|
||||
my $build = current_build() || root_build(\$caller[0])
|
||||
or croak "No current workflow build!";
|
||||
|
||||
for my $task (@_) {
|
||||
croak "include_workflow only accepts Test2::Workflow::Task objects, got: $task"
|
||||
unless $task->isa('Test2::Workflow::Task');
|
||||
|
||||
$build->add_primary($task);
|
||||
}
|
||||
}
|
||||
|
||||
sub defaults {
|
||||
my %params = @_;
|
||||
|
||||
my ($package, $tool) = @params{qw/package tool/};
|
||||
|
||||
my @stack = (root_build($package), build_stack());
|
||||
return unless @stack;
|
||||
|
||||
my %out;
|
||||
for my $build (@stack) {
|
||||
%out = () if $build->stack_stop;
|
||||
my $new = $build->defaults->{$tool} or next;
|
||||
%out = (%out, %$new);
|
||||
}
|
||||
|
||||
return \%out;
|
||||
}
|
||||
|
||||
|
||||
# Generate a bunch of subs that only have minor differences between them.
|
||||
BEGIN {
|
||||
@EXPORT = qw{
|
||||
tests it
|
||||
case
|
||||
before_all around_all after_all
|
||||
before_case around_case after_case
|
||||
before_each around_each after_each
|
||||
};
|
||||
|
||||
@EXPORT_OK = qw{
|
||||
mini
|
||||
iso miso
|
||||
async masync
|
||||
};
|
||||
|
||||
my %stages = (
|
||||
case => ['add_variant'],
|
||||
tests => ['add_primary'],
|
||||
it => ['add_primary'],
|
||||
|
||||
iso => ['add_primary'],
|
||||
miso => ['add_primary'],
|
||||
|
||||
async => ['add_primary'],
|
||||
masync => ['add_primary'],
|
||||
|
||||
mini => ['add_primary'],
|
||||
|
||||
before_all => ['add_setup'],
|
||||
after_all => ['add_teardown'],
|
||||
around_all => ['add_setup', 'add_teardown'],
|
||||
|
||||
before_case => ['add_variant_setup'],
|
||||
after_case => ['add_variant_teardown'],
|
||||
around_case => ['add_variant_setup', 'add_variant_teardown'],
|
||||
|
||||
before_each => ['add_primary_setup'],
|
||||
after_each => ['add_primary_teardown'],
|
||||
around_each => ['add_primary_setup', 'add_primary_teardown'],
|
||||
);
|
||||
|
||||
my %props = (
|
||||
case => [],
|
||||
tests => [],
|
||||
it => [],
|
||||
|
||||
iso => [iso => 1],
|
||||
miso => [iso => 1, flat => 1],
|
||||
|
||||
async => [async => 1],
|
||||
masync => [async => 1, flat => 1],
|
||||
|
||||
mini => [flat => 1],
|
||||
|
||||
before_all => [scaffold => 1],
|
||||
after_all => [scaffold => 1],
|
||||
around_all => [scaffold => 1, around => 1],
|
||||
|
||||
before_case => [scaffold => 1],
|
||||
after_case => [scaffold => 1],
|
||||
around_case => [scaffold => 1, around => 1],
|
||||
|
||||
before_each => [scaffold => 1],
|
||||
after_each => [scaffold => 1],
|
||||
around_each => [scaffold => 1, around => 1],
|
||||
);
|
||||
|
||||
sub spec_defaults {
|
||||
my ($tool, %params) = @_;
|
||||
my @caller = caller(0);
|
||||
|
||||
croak "'$tool' is not a spec tool"
|
||||
unless exists $props{$tool} || exists $stages{$tool};
|
||||
|
||||
my $build = current_build() || root_build($caller[0])
|
||||
or croak "No current workflow build!";
|
||||
|
||||
my $old = $build->defaults->{$tool} ||= {};
|
||||
$build->defaults->{$tool} = { %$old, %params };
|
||||
}
|
||||
|
||||
my $run = "";
|
||||
for my $func (@EXPORT, @EXPORT_OK) {
|
||||
$run .= <<" EOT";
|
||||
#line ${ \(__LINE__ + 1) } "${ \__FILE__ }"
|
||||
sub $func {
|
||||
my \@caller = caller(0);
|
||||
my \$args = parse_args(args => \\\@_, caller => \\\@caller);
|
||||
my \$action = Test2::Workflow::Task::Action->new(\@{\$props{$func}}, %\$args);
|
||||
|
||||
return \$action if defined wantarray;
|
||||
|
||||
my \$build = current_build() || root_build(\$caller[0])
|
||||
or croak "No current workflow build!";
|
||||
|
||||
if (my \$defaults = defaults(package => \$caller[0], tool => '$func')) {
|
||||
for my \$attr (keys \%\$defaults) {
|
||||
next if defined \$action->\$attr;
|
||||
my \$sub = "set_\$attr";
|
||||
\$action->\$sub(\$defaults->{\$attr});
|
||||
}
|
||||
}
|
||||
|
||||
\$build->\$_(\$action) for \@{\$stages{$func}};
|
||||
}
|
||||
EOT
|
||||
}
|
||||
|
||||
my ($ok, $err);
|
||||
{
|
||||
local $@;
|
||||
$ok = eval "$run\n1";
|
||||
$err = $@;
|
||||
}
|
||||
|
||||
die $@ unless $ok;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Spec - RSPEC implementation on top of Test2::Workflow
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This uses L<Test2::Workflow> to implement an RSPEC variant. This variant
|
||||
supports isolation and/or concurrency via forking or threads.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Bundle::Extended;
|
||||
use Test2::Tools::Spec;
|
||||
|
||||
describe foo => sub {
|
||||
before_all once => sub { ... };
|
||||
before_each many => sub { ... };
|
||||
|
||||
after_all once => sub { ... };
|
||||
after_each many => sub { ... };
|
||||
|
||||
case condition_a => sub { ... };
|
||||
case condition_b => sub { ... };
|
||||
|
||||
tests foo => sub { ... };
|
||||
tests bar => sub { ... };
|
||||
};
|
||||
|
||||
done_testing;
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
All of these use the same argument pattern. The first argument must always be a
|
||||
name for the block. The last argument must always be a code reference.
|
||||
Optionally a configuration hash can be inserted between the name and the code
|
||||
reference.
|
||||
|
||||
FUNCTION "name" => sub { ... };
|
||||
|
||||
FUNCTION "name" => {...}, sub { ... };
|
||||
|
||||
=over 4
|
||||
|
||||
=item NAME
|
||||
|
||||
The first argument to a Test2::Tools::Spec function MUST be a name. The name
|
||||
does not need to be unique.
|
||||
|
||||
=item PARAMS
|
||||
|
||||
This argument is optional. If present this should be a hashref.
|
||||
|
||||
Here are the valid keys for the hashref:
|
||||
|
||||
=over 8
|
||||
|
||||
=item flat => $bool
|
||||
|
||||
If this is set to true then the block will not render as a subtest, instead the
|
||||
events will be inline with the parent subtest (or main test).
|
||||
|
||||
=item async => $bool
|
||||
|
||||
Set this to true to mark a block as being capable of running concurrently with
|
||||
other test blocks. This does not mean the block WILL be run concurrently, just
|
||||
that it can be.
|
||||
|
||||
=item iso => $bool
|
||||
|
||||
Set this to true if the block MUST be run in isolation. If this is true then
|
||||
the block will run in its own forked process.
|
||||
|
||||
These tests will be skipped on any platform that does not have true forking, or
|
||||
working/enabled threads.
|
||||
|
||||
Threads will ONLY be used if the T2_WORKFLOW_USE_THREADS env var is set. Thread
|
||||
tests are only run if the T2_DO_THREAD_TESTS env var is set.
|
||||
|
||||
=item todo => $reason
|
||||
|
||||
Use this to mark an entire block as TODO.
|
||||
|
||||
=item skip => $reason
|
||||
|
||||
Use this to prevent a block from running at all.
|
||||
|
||||
=back
|
||||
|
||||
=item CODEREF
|
||||
|
||||
This argument is required. This should be a code reference that will run some
|
||||
assertions.
|
||||
|
||||
=back
|
||||
|
||||
=head2 ESSENTIALS
|
||||
|
||||
=over 4
|
||||
|
||||
=item tests NAME => sub { ... }
|
||||
|
||||
=item tests NAME => \%params, sub { ... }
|
||||
|
||||
=item tests($NAME, \%PARAMS, \&CODE)
|
||||
|
||||
=item it NAME => sub { ... }
|
||||
|
||||
=item it NAME => \%params, sub { ... }
|
||||
|
||||
=item it($NAME, \%PARAMS, \&CODE)
|
||||
|
||||
This defines a test block. Test blocks are essentially subtests. All test
|
||||
blocks will be run, and are expected to produce events. Test blocks can run
|
||||
multiple times if the C<case()> function is also used.
|
||||
|
||||
C<it()> is an alias to C<tests()>.
|
||||
|
||||
These ARE NOT inherited by nested describe blocks.
|
||||
|
||||
=item case NAME => sub { ... }
|
||||
|
||||
=item case NAME => \%params, sub { ... }
|
||||
|
||||
=item case($NAME, \%PARAMS, \&CODE)
|
||||
|
||||
This lets you specify multiple conditions in which the test blocks should be
|
||||
run. Every test block within the same group (C<describe>) will be run once per
|
||||
case.
|
||||
|
||||
These ARE NOT inherited by nested describe blocks, but nested describe blocks
|
||||
will be executed once per case.
|
||||
|
||||
=item before_each NAME => sub { ... }
|
||||
|
||||
=item before_each NAME => \%params, sub { ... }
|
||||
|
||||
=item before_each($NAME, \%PARAMS, \&CODE)
|
||||
|
||||
Specify a codeblock that should be run multiple times, once before each
|
||||
C<tests()> block is run. These will run AFTER C<case()> blocks but before
|
||||
C<tests()> blocks.
|
||||
|
||||
These ARE inherited by nested describe blocks.
|
||||
|
||||
=item before_case NAME => sub { ... }
|
||||
|
||||
=item before_case NAME => \%params, sub { ... }
|
||||
|
||||
=item before_case($NAME, \%PARAMS, \&CODE)
|
||||
|
||||
Same as C<before_each()>, except these blocks run BEFORE C<case()> blocks.
|
||||
|
||||
These ARE NOT inherited by nested describe blocks.
|
||||
|
||||
=item before_all NAME => sub { ... }
|
||||
|
||||
=item before_all NAME => \%params, sub { ... }
|
||||
|
||||
=item before_all($NAME, \%PARAMS, \&CODE)
|
||||
|
||||
Specify a codeblock that should be run once, before all the test blocks run.
|
||||
|
||||
These ARE NOT inherited by nested describe blocks.
|
||||
|
||||
=item around_each NAME => sub { ... }
|
||||
|
||||
=item around_each NAME => \%params, sub { ... }
|
||||
|
||||
=item around_each($NAME, \%PARAMS, \&CODE)
|
||||
|
||||
Specify a codeblock that should wrap around each test block. These blocks are
|
||||
run AFTER case blocks, but before test blocks.
|
||||
|
||||
around_each wrapit => sub {
|
||||
my $cont = shift;
|
||||
|
||||
local %ENV = ( ... );
|
||||
|
||||
$cont->();
|
||||
|
||||
...
|
||||
};
|
||||
|
||||
The first argument to the codeblock will be a callback that MUST be called
|
||||
somewhere inside the sub in order for nested items to run.
|
||||
|
||||
These ARE inherited by nested describe blocks.
|
||||
|
||||
=item around_case NAME => sub { ... }
|
||||
|
||||
=item around_case NAME => \%params, sub { ... }
|
||||
|
||||
=item around_case($NAME, \%PARAMS, \&CODE)
|
||||
|
||||
Same as C<around_each> except these run BEFORE case blocks.
|
||||
|
||||
These ARE NOT inherited by nested describe blocks.
|
||||
|
||||
=item around_all NAME => sub { ... }
|
||||
|
||||
=item around_all NAME => \%params, sub { ... }
|
||||
|
||||
=item around_all($NAME, \%PARAMS, \&CODE)
|
||||
|
||||
Same as C<around_each> except that it only runs once to wrap ALL test blocks.
|
||||
|
||||
These ARE NOT inherited by nested describe blocks.
|
||||
|
||||
=item after_each NAME => sub { ... }
|
||||
|
||||
=item after_each NAME => \%params, sub { ... }
|
||||
|
||||
=item after_each($NAME, \%PARAMS, \&CODE)
|
||||
|
||||
Same as C<before_each> except it runs right after each test block.
|
||||
|
||||
These ARE inherited by nested describe blocks.
|
||||
|
||||
=item after_case NAME => sub { ... }
|
||||
|
||||
=item after_case NAME => \%params, sub { ... }
|
||||
|
||||
=item after_case($NAME, \%PARAMS, \&CODE)
|
||||
|
||||
Same as C<after_each> except it runs right after the case block, and before the
|
||||
test block.
|
||||
|
||||
These ARE NOT inherited by nested describe blocks.
|
||||
|
||||
=item after_all NAME => sub { ... }
|
||||
|
||||
=item after_all NAME => \%params, sub { ... }
|
||||
|
||||
=item after_all($NAME, \%PARAMS, \&CODE)
|
||||
|
||||
Same as C<before_all> except it runs after all test blocks have been run.
|
||||
|
||||
These ARE NOT inherited by nested describe blocks.
|
||||
|
||||
=back
|
||||
|
||||
=head2 SHORTCUTS
|
||||
|
||||
These are shortcuts. Each of these is the same as C<tests()> except some
|
||||
parameters are added for you.
|
||||
|
||||
These are NOT exported by default/.
|
||||
|
||||
=over 4
|
||||
|
||||
=item mini NAME => sub { ... }
|
||||
|
||||
Same as:
|
||||
|
||||
tests NAME => { flat => 1 }, sub { ... }
|
||||
|
||||
=item iso NAME => sub { ... }
|
||||
|
||||
Same as:
|
||||
|
||||
tests NAME => { iso => 1 }, sub { ... }
|
||||
|
||||
=item miso NAME => sub { ... }
|
||||
|
||||
Same as:
|
||||
|
||||
tests NAME => { mini => 1, iso => 1 }, sub { ... }
|
||||
|
||||
=item async NAME => sub { ... }
|
||||
|
||||
Same as:
|
||||
|
||||
tests NAME => { async => 1 }, sub { ... }
|
||||
|
||||
B<Note:> This conflicts with the C<async()> exported from L<threads>. Don't
|
||||
import both.
|
||||
|
||||
=item masync NAME => sub { ... }
|
||||
|
||||
Same as:
|
||||
|
||||
tests NAME => { minit => 1, async => 1 }, sub { ... }
|
||||
|
||||
=back
|
||||
|
||||
=head2 CUSTOM ATTRIBUTE DEFAULTS
|
||||
|
||||
Sometimes you want to apply default attributes to all C<tests()> or C<case()>
|
||||
blocks. This can be done, and is lexical to your describe or package root!
|
||||
|
||||
use Test2::Bundle::Extended;
|
||||
use Test2::Tools::Spec ':ALL';
|
||||
|
||||
# All 'tests' blocks after this declaration will have C<<iso => 1>> by default
|
||||
spec_defaults tests => (iso => 1);
|
||||
|
||||
tests foo => sub { ... }; # isolated
|
||||
|
||||
tests foo, {iso => 0}, sub { ... }; # Not isolated
|
||||
|
||||
spec_defaults tests => (iso => 0); # Turn it off again
|
||||
|
||||
Defaults are inherited by nested describe blocks. You can also override the
|
||||
defaults for the scope of the describe:
|
||||
|
||||
spec_defaults tests => (iso => 1);
|
||||
|
||||
describe foo => sub {
|
||||
spec_defaults tests => (async => 1); # Scoped to this describe and any child describes
|
||||
|
||||
tests bar => sub { ... }; # both iso and async
|
||||
};
|
||||
|
||||
tests baz => sub { ... }; # Just iso, no async.
|
||||
|
||||
You can apply defaults to any type of blocks:
|
||||
|
||||
spec_defaults case => (iso => 1); # All cases are 'iso';
|
||||
|
||||
Defaults are not inherited when a builder's return is captured.
|
||||
|
||||
spec_defaults tests => (iso => 1);
|
||||
|
||||
# Note we are not calling this in void context, that is the key here.
|
||||
my $d = describe foo => {
|
||||
tests bar => sub { ... }; # Not iso
|
||||
};
|
||||
|
||||
=head1 EXECUTION ORDER
|
||||
|
||||
As each function is encountered it executes, just like any other function. The
|
||||
C<describe()> function will immediately execute the codeblock it is given. All
|
||||
other functions will stash their codeblocks to be run later. When
|
||||
C<done_testing()> is run the workflow will be compiled, at which point all
|
||||
other blocks will run.
|
||||
|
||||
Here is an overview of the order in which blocks get called once compiled (at
|
||||
C<done_testing()>).
|
||||
|
||||
before_all
|
||||
for-each-case {
|
||||
before_case
|
||||
case
|
||||
after_case
|
||||
|
||||
# AND/OR nested describes
|
||||
before_each
|
||||
tests
|
||||
after_each
|
||||
}
|
||||
after_all
|
||||
|
||||
=head1 SOURCE
|
||||
|
||||
The source code repository for Test2-Workflow 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
|
||||
|
||||
172
database/perl/vendor/lib/Test2/Tools/Subtest.pm
vendored
Normal file
172
database/perl/vendor/lib/Test2/Tools/Subtest.pm
vendored
Normal file
@@ -0,0 +1,172 @@
|
||||
package Test2::Tools::Subtest;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Test2::API qw/context run_subtest/;
|
||||
use Test2::Util qw/try/;
|
||||
|
||||
our @EXPORT = qw/subtest_streamed subtest_buffered/;
|
||||
use base 'Exporter';
|
||||
|
||||
sub subtest_streamed {
|
||||
my $name = shift;
|
||||
my $params = ref($_[0]) eq 'HASH' ? shift(@_) : {};
|
||||
my $code = shift;
|
||||
|
||||
$params->{buffered} = 0 unless defined $params->{buffered};
|
||||
|
||||
my $ctx = context();
|
||||
my $pass = run_subtest("Subtest: $name", $code, $params, @_);
|
||||
$ctx->release;
|
||||
return $pass;
|
||||
}
|
||||
|
||||
sub subtest_buffered {
|
||||
my $name = shift;
|
||||
my $params = ref($_[0]) eq 'HASH' ? shift(@_) : {};
|
||||
my $code = shift;
|
||||
|
||||
$params->{buffered} = 1 unless defined $params->{buffered};
|
||||
|
||||
my $ctx = context();
|
||||
my $pass = run_subtest($name, $code, $params, @_);
|
||||
$ctx->release;
|
||||
return $pass;
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Subtest - Tools for writing subtests
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This package exports subs that let you write subtests.
|
||||
|
||||
There are two types of subtests, buffered and streamed. Streamed subtests mimic
|
||||
subtests from L<Test::More> in that they render all events as soon as they are
|
||||
produced. Buffered subtests wait until the subtest completes before rendering
|
||||
any results.
|
||||
|
||||
The main difference is that streamed subtests are unreadable when combined with
|
||||
concurrency. Buffered subtests look fine with any number of concurrent threads
|
||||
and processes.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
=head2 BUFFERED
|
||||
|
||||
use Test2::Tools::Subtest qw/subtest_buffered/;
|
||||
|
||||
subtest_buffered my_test => sub {
|
||||
ok(1, "subtest event A");
|
||||
ok(1, "subtest event B");
|
||||
};
|
||||
|
||||
This will produce output like this:
|
||||
|
||||
ok 1 - my_test {
|
||||
ok 1 - subtest event A
|
||||
ok 2 - subtest event B
|
||||
1..2
|
||||
}
|
||||
|
||||
=head2 STREAMED
|
||||
|
||||
The default option is 'buffered'. If you want streamed subtests,
|
||||
the way L<Test::Builder> does it, use this:
|
||||
|
||||
use Test2::Tools::Subtest qw/subtest_streamed/;
|
||||
|
||||
subtest_streamed my_test => sub {
|
||||
ok(1, "subtest event A");
|
||||
ok(1, "subtest event B");
|
||||
};
|
||||
|
||||
This will produce output like this:
|
||||
|
||||
# Subtest: my_test
|
||||
ok 1 - subtest event A
|
||||
ok 2 - subtest event B
|
||||
1..2
|
||||
ok 1 - Subtest: my_test
|
||||
|
||||
=head1 IMPORTANT NOTE
|
||||
|
||||
You can use C<bail_out> or C<skip_all> in a subtest, but not in a BEGIN block
|
||||
or C<use> statement. This is due to the way flow control works within a BEGIN
|
||||
block. This is not normally an issue, but can happen in rare conditions using
|
||||
eval, or script files as subtests.
|
||||
|
||||
=head1 EXPORTS
|
||||
|
||||
=over 4
|
||||
|
||||
=item subtest_streamed $name => $sub
|
||||
|
||||
=item subtest_streamed($name, $sub, @args)
|
||||
|
||||
=item subtest_streamed $name => \%params, $sub
|
||||
|
||||
=item subtest_streamed($name, \%params, $sub, @args)
|
||||
|
||||
Run subtest coderef, stream events as they happen.
|
||||
|
||||
C<\%params> is a hashref with any arguments you wish to pass into hub
|
||||
construction.
|
||||
|
||||
=item subtest_buffered $name => $sub
|
||||
|
||||
=item subtest_buffered($name, $sub, @args)
|
||||
|
||||
=item subtest_buffered $name => \%params, $sub
|
||||
|
||||
=item subtest_buffered($name, \%params, $sub, @args)
|
||||
|
||||
Run subtest coderef, render events all at once when subtest is complete.
|
||||
|
||||
C<\%params> is a hashref with any arguments you wish to pass into hub
|
||||
construction.
|
||||
|
||||
=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
|
||||
118
database/perl/vendor/lib/Test2/Tools/Target.pm
vendored
Normal file
118
database/perl/vendor/lib/Test2/Tools/Target.pm
vendored
Normal file
@@ -0,0 +1,118 @@
|
||||
package Test2::Tools::Target;
|
||||
use strict;
|
||||
use warnings;
|
||||
|
||||
our $VERSION = '0.000139';
|
||||
|
||||
use Carp qw/croak/;
|
||||
|
||||
use Test2::Util qw/pkg_to_file/;
|
||||
|
||||
sub import {
|
||||
my $class = shift;
|
||||
|
||||
my $caller = caller;
|
||||
$class->import_into($caller, @_);
|
||||
}
|
||||
|
||||
sub import_into {
|
||||
my $class = shift;
|
||||
my $into = shift or croak "no destination package provided";
|
||||
|
||||
croak "No targets specified" unless @_;
|
||||
|
||||
my %targets;
|
||||
if (@_ == 1) {
|
||||
if (ref $_[0] eq 'HASH') {
|
||||
%targets = %{ $_[0] };
|
||||
}
|
||||
else {
|
||||
($targets{CLASS}) = @_;
|
||||
}
|
||||
}
|
||||
else {
|
||||
%targets = @_;
|
||||
}
|
||||
|
||||
for my $name (keys %targets) {
|
||||
my $target = $targets{$name};
|
||||
|
||||
my $file = pkg_to_file($target);
|
||||
require $file;
|
||||
|
||||
$name ||= 'CLASS';
|
||||
|
||||
my $const;
|
||||
{
|
||||
my $const_target = "$target";
|
||||
$const = sub() { $const_target };
|
||||
}
|
||||
|
||||
no strict 'refs';
|
||||
*{"$into\::$name"} = \$target;
|
||||
*{"$into\::$name"} = $const;
|
||||
}
|
||||
}
|
||||
|
||||
1;
|
||||
|
||||
__END__
|
||||
|
||||
=pod
|
||||
|
||||
=encoding UTF-8
|
||||
|
||||
=head1 NAME
|
||||
|
||||
Test2::Tools::Target - Alias the testing target package.
|
||||
|
||||
=head1 DESCRIPTION
|
||||
|
||||
This lets you alias the package you are testing into a constant and a package
|
||||
variable.
|
||||
|
||||
=head1 SYNOPSIS
|
||||
|
||||
use Test2::Tools::Target 'Some::Package';
|
||||
|
||||
CLASS()->xxx; # Call 'xxx' on Some::Package
|
||||
$CLASS->xxx; # Same
|
||||
|
||||
Or you can specify names:
|
||||
|
||||
use Test2::Tools::Target pkg => 'Some::Package';
|
||||
|
||||
pkg()->xxx; # Call 'xxx' on Some::Package
|
||||
$pkg->xxx; # Same
|
||||
|
||||
=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
|
||||
Some files were not shown because too many files have changed in this diff Show More
Reference in New Issue
Block a user