Test2-Suite-0.000129/0000755000175000017500000000000013615053353013761 5ustar exodistexodistTest2-Suite-0.000129/lib/0000755000175000017500000000000013615053353014527 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/0000755000175000017500000000000013615053353015530 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/AsyncSubtest/0000755000175000017500000000000013615053353020157 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/AsyncSubtest/Event/0000755000175000017500000000000013615053353021240 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/AsyncSubtest/Event/Attach.pm0000644000175000017500000000327013615053353023004 0ustar exodistexodistpackage Test2::AsyncSubtest::Event::Attach; use strict; use warnings; our $VERSION = '0.000129'; 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. No user serviceable parts inside. =head1 SOURCE The source code repository for Test2-AsyncSubtest can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist7@gmail.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/AsyncSubtest/Event/Detach.pm0000644000175000017500000000330213615053353022764 0ustar exodistexodistpackage Test2::AsyncSubtest::Event::Detach; use strict; use warnings; our $VERSION = '0.000129'; 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. No user serviceable parts inside. =head1 SOURCE The source code repository for Test2-AsyncSubtest can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist7@gmail.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/AsyncSubtest/Formatter.pm0000644000175000017500000000020713615053353022457 0ustar exodistexodistpackage Test2::AsyncSubtest::Formatter; use strict; use warnings; our $VERSION = '0.000129'; die "Should not load this anymore"; 1; Test2-Suite-0.000129/lib/Test2/AsyncSubtest/Hub.pm0000644000175000017500000000324513615053353021237 0ustar exodistexodistpackage Test2::AsyncSubtest::Hub; use strict; use warnings; our $VERSION = '0.000129'; 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 used for async subtests. =head1 SYNOPSIS You should not use this directly. =head1 METHODS =over 4 =item $ast = $hub->ast Get the L object to which this hub is bound. =back =head1 SOURCE The source code repository for Test2-AsyncSubtest can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist7@gmail.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/0000755000175000017500000000000013615053353016745 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Manual/Tooling/0000755000175000017500000000000013615053353020360 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Manual/Tooling/Plugin/0000755000175000017500000000000013615053353021616 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Manual/Tooling/Plugin/ToolCompletes.pm0000644000175000017500000000352013615053353024745 0ustar exodistexodistpackage Test2::Manual::Tooling::Plugin::ToolCompletes; our $VERSION = '0.000129'; 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 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Tooling/Plugin/TestingDone.pm0000644000175000017500000000537513615053353024411 0ustar exodistexodistpackage Test2::Manual::Tooling::Plugin::TestingDone; our $VERSION = '0.000129'; 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 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Tooling/Plugin/ToolStarts.pm0000644000175000017500000000577113615053353024304 0ustar exodistexodistpackage Test2::Manual::Tooling::Plugin::ToolStarts; our $VERSION = '0.000129'; 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 and C callbacks. =item test2_add_callback_context_acquire(sub { ... }) This is where we add our callback for context acquisition. Every time C 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 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Tooling/Plugin/TestExit.pm0000644000175000017500000000440413615053353023727 0ustar exodistexodistpackage Test2::Manual::Tooling::Plugin::TestExit; our $VERSION = '0.000129'; 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 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 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Tooling/TestBuilder.pm0000644000175000017500000000737713615053353023162 0ustar exodistexodistpackage Test2::Manual::Tooling::TestBuilder; our $VERSION = '0.000129'; 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 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 and L. =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 function instead. See L for documentation. =item $tb->todo_start =item $tb->todo_end See L instead. =item $tb->output, $tb->failure_output, and $tb->todo_output These are handled via formatters now. See L and L. =back =head1 LEVEL L 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 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 is also smart enough to honor c<$Test::Builder::Level> if it is set. =head1 TODO L used the C<$TODO> package variable to set the TODO state. This was confusing, and easy to get wrong. See L for the modern way to accomplish a TODO state. =head1 SEE ALSO L - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Tooling/FirstTool.pm0000644000175000017500000000705713615053353022654 0ustar exodistexodistpackage Test2::Manual::Tooling::FirstTool; our $VERSION = '0.000129'; 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 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 function exported by L. C 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 tools. The context object is the primary API for test tools. You B 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 A test function B 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 You B ever store or pass around a I 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 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 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 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 is the place to read up on what methods the context provides. =head1 SEE ALSO L - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Tooling/Formatter.pm0000644000175000017500000000543213615053353022665 0ustar exodistexodistpackage Test2::Manual::Tooling::Formatter; our $VERSION = '0.000129'; 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. =item sub new { bless {}, shift } Formatters need to be instantiable objects, this is a minimal C 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 itself will try to set the encoding to UTF8. =item sub write { ... } The C method is the most important, each event is sent here. =item my ($self, $e, $num, $f) = @_; The C 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Tooling/Testing.pm0000644000175000017500000001064113615053353022335 0ustar exodistexodistpackage Test2::Manual::Tooling::Testing; use strict; use warnings; our $VERSION = '0.000129'; 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 and L 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 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 function completely isolates the tools called within. B Plugins and things that effect global API state may not be fully isolated. C is intended specifically for event isolation. The C 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. 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. If you are going to be writing anything more than the most simple of tools you should know how events work. The L documentation is a good place for further reading. =head2 Test2::Tools::HarnessTester The L can export the C tool. This tool lets you run your event arrayref through L 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 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 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 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Tooling/Subtest.pm0000644000175000017500000000772113615053353022356 0ustar exodistexodistpackage Test2::Manual::Tooling::Subtest; use strict; use warnings; our $VERSION = '0.000129'; 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 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. =head2 SUBTEST WITH USER SUPPLIED CODEREF This example will emulate the C 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 does all the hard work for you. This will issue an L 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 like you used the context. C 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. 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 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 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Tooling/Nesting.pm0000644000175000017500000000707113615053353022332 0ustar exodistexodistpackage Test2::Manual::Tooling::Nesting; use strict; use warnings; our $VERSION = '0.000129'; 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 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 =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 C, not to the line where C 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 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Testing/0000755000175000017500000000000013615053353020362 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Manual/Testing/Introduction.pm0000644000175000017500000001623513615053353023410 0ustar exodistexodistpackage Test2::Manual::Testing::Introduction; use strict; use warnings; our $VERSION = '0.000129'; 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 directory, and end with the C<.t> file extension. C: 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 and C for you. =item done_testing; This should always be at the end of your test files. This tells L that you are done making assertions. This is important as C 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 and call it done, bundles and tools may be moved out of L 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. C lets you assert that a condition is true. ok($CONDITION, "Description of the condition"); Here is a complete C: 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) 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 command line tool is provided by L which you may need to install yourself from cpan. C is the harness written specifically for L. $ 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 command line tool is provided by the L module which comes with most versions of perl. L 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 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 would not run and no plan would be found, forcing a failure. =item plan($COUNT) The C 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 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 bundle provides a lot more than C, C, and C. The biggest tools to note are: =over 4 =item is($a, $b, $description) C 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 is similar to C 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Testing/Migrating.pm0000644000175000017500000002300313615053353022637 0ustar exodistexodistpackage Test2::Manual::Testing::Migrating; use strict; use warnings; our $VERSION = '0.000129'; 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. =head1 LEGACY TEST This tutorial will be converting this example test one section at a time: C: ##################### # 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 is the recommended bundle. In a full migration you will want to replace L with the L bundle. B You should always double check the latest L 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 has been removed. a C statement will throw an exception on failure anyway preventing the test from passing. If you I want/need to assert that the file loaded you can use the L 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 has been removed just like C. There is no L module equivalent here. Just use C. =item Remove strict/warnings (optional) The L 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 you either need to use the C function to set the plan, or use C at the end of the test. If your test already uses C you can keep that and no plan changes are necessary. B We are also changing the plan from 14 to 11, that is because we dropped C, C, and we will be dropping one more later on. This is why C 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 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 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 with C. 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 function provided by L forces both arguments into strings, which makes this a comparison of the reference addresses. L's C 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 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, C and C have been considered deprecated for a very long time, L does not provide them at all. Instead you can just use C: is([1], [1], "array comparison"); is({a => 1}, {a => 1}, "hash comparison"); C is a tad more complicated, see L for an explanation: is([1, 3, 2], bag { item 1; item 2; item 3; end }, "set comparison"); C has a rocky history. There have been arguments about how it should work. L decided to simply not include C to avoid the arguments. You can instead directly use Data::Dumper: use Data::Dumper; note Dumper([1, 2, 3]); C 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 these functions are very confusing, and most people use them wrong! C from L 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 from L is not consistent with C as all arguments after the first are subroutine names. L 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Testing/Planning.pm0000644000175000017500000000413113615053353022465 0ustar exodistexodistpackage Test2::Manual::Testing::Planning; use strict; use warnings; our $VERSION = '0.000129'; 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 function is provided by L. 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 function is provided by L. 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 function is provided by L. 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 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Testing/Todo.pm0000644000175000017500000000536413615053353021635 0ustar exodistexodistpackage Test2::Manual::Testing::Todo; use strict; use warnings; our $VERSION = '0.000129'; 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 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 event has a C field which should have the todo reason. The event also has the C and C fields. The C field is the actual pass/fail value. The C 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 library gets the current L instance and adds a filter. The filter that is added will set the todo and effective pass fields on any L events that pass through the hub. The filter also converts L events into L events. =head1 SEE ALSO L - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Contributing.pm0000644000175000017500000000533213615053353021755 0ustar exodistexodistpackage Test2::Manual::Contributing; our $VERSION = '0.000129'; 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 =item Test2-Suite L =item Test2-Harness L =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, the #perl-qa and #toolchain channels are a good place to find us. There is also a Test2 slack channel: L. =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 namespace has been around for a long time, and has a LOT of tools. The C 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Anatomy/0000755000175000017500000000000013615053353020355 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Manual/Anatomy/Utilities.pm0000644000175000017500000000313413615053353022667 0ustar exodistexodistpackage Test2::Manual::Anatomy::Utilities; use strict; use warnings; our $VERSION = '0.000129'; 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 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 implementation, and constants for things like threading and forking support. =head1 Test2::Util::ExternalMeta L allows you to quickly and easily attach meta-data to an object class. =head1 Test2::Util::Facets2Legacy L 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 is a local copy of L. All object classes provided by L use this to generate methods and accessors. =head1 SEE ALSO L - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Anatomy/EndToEnd.pm0000644000175000017500000002547513615053353022370 0ustar exodistexodistpackage Test2::Manual::Anatomy::EndToEnd; use strict; use warnings; our $VERSION = '0.000129'; 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, or have other global effects that need to be done before the first L is created. Once the first L is created the API will finish initialization. See L for more information. =back =head1 WHAT HAPPENS WHEN I USE A TOOL? This section covers the basic workflow all tools such as C 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 for more information. =item The tool uses the context object to create, send, and return events. See L for more information. my $event = $ctx->send_event('Ok', pass => $bool, name => $name); =item When done the tool MUST release the context. See L 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. 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 method will automatically load any Event package necessary. Normally C will assume the first argument is an event class without the C 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 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 are implemented. If we simply had a destructor call the hooks then we would be unable to write this plugin as a C 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 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 is loaded, but has a different version compared to L. 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 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 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 This only happens if there were test failures. No broken module warnings are produced on a success. =back =head1 SEE ALSO L - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Anatomy/Context.pm0000644000175000017500000000726013615053353022344 0ustar exodistexodistpackage Test2::Manual::Anatomy::Context; use strict; use warnings; our $VERSION = '0.000129'; 1; __END__ =head1 NAME Test2::Manual::Anatomy::Context - Internals documentation for the Context objects. =head1 DESCRIPTION This document explains how the L 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 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 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 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 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 works via a hidden singleton instance of L. 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 has a stack of hubs, the stack can be accessed via L. 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 for details on these hooks and how to use them. =head1 SEE ALSO L - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Anatomy/Event.pm0000644000175000017500000003133613615053353022002 0ustar exodistexodistpackage Test2::Manual::Anatomy::Event; use strict; use warnings; our $VERSION = '0.000129'; 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. 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 which will instead rely on your facet data, and deduce the old API from them. All new events C 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. 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 be lone hashrefs, others C be hashrefs inside an arrayref. The I facet types are as follows: =over 4 =item assert => {details => $name, pass => $bool, no_debug => $bool, number => $maybe_int} Documented in L. 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. 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) =item amnesty => [{details => $string, tag => $short_string, inherited => $bool}] Documented in L. 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. 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. 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. 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. 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. 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. 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 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 Do not worry too much about getting the key/pluralization wrong. Most tools will use L 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 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 you can override this method. This is called B 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 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 to exit 0 when the plan is 'skip_all'. This is also used by L 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Anatomy/Hubs.pm0000644000175000017500000000667213615053353021627 0ustar exodistexodistpackage Test2::Manual::Anatomy::Hubs; use strict; use warnings; our $VERSION = '0.000129'; 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. 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 instance is created and pushed to the stack. Once this is done all calls to C 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 is implemented using the hub stack. The C function will add an L instance to the stack, any calls to L 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. You can access the global hub stack using C. =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) 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Anatomy/IPC.pm0000644000175000017500000000507413615053353021334 0ustar exodistexodistpackage Test2::Manual::Anatomy::IPC; use strict; use warnings; our $VERSION = '0.000129'; 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. 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 and L have some behaviors that trigger if L 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 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. 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. 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Anatomy/API.pm0000644000175000017500000000361513615053353021331 0ustar exodistexodistpackage Test2::Manual::Anatomy::API; use strict; use warnings; our $VERSION = '0.000129'; 1; __END__ =head1 NAME Test2::Manual::Anatomy::API - Internals documentation for the API. =head1 DESCRIPTION This document covers some of the internals of L. =head1 IMPLEMENTATION DETAILS =head2 Test2::API L 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 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 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 could be removed completely, or changed in incompatible ways. Really these details are free to change so long as L is not broken. L is fairly well documented, so no additionally documentation is needed for this manual page. =head1 SEE ALSO L - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Concurrency.pm0000644000175000017500000001015713615053353021601 0ustar exodistexodist=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. =head2 Test::Builder L Did not used to support forking, but now that it is based on L it does. L must be loaded just as with L. =head2 Test2::Suite L tools should all work fine with I 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 is currently support and maintained, though it is no longer necessary thanks to L. 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 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 This only applies to ithreads. =head2 Test2 The core of Test2 supports threading so long as L 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 has had thread support for a long time. With Test2 the mechanism for thread support was switched to L. L should still support threads as much as it did before the switch to Test2. Support includes auto-enabling thread support if L 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 have minimal threading support. Most of these tools do not care/notice threading and simply work because L 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 has been merged into L, so it gets addressed by this policy. L 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 itself. L - Initial tools built using L. L - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Anatomy.pm0000644000175000017500000000337613615053353020724 0ustar exodistexodistpackage Test2::Manual::Anatomy; use strict; use warnings; our $VERSION = '0.000129'; 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 document is an overview of Test2 from load to finish. =head1 EVENTS The L document explains the internals of events. =head1 THE CONTEXT The L document explains how the L object works. =head1 THE API AND THE API INSTANCE The L document explains the inner workings of the Test2 API. =head1 HUBS The L document explains the inner working of the Test2 hub stack, and the hubs therein. =head1 THE IPC SYSTEM The L document describes the IPC system. =head1 INTERNAL UTILITIES The L document describes various utilities provided by the Test2 system. =head1 SEE ALSO L - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Testing.pm0000644000175000017500000001236413615053353020726 0ustar exodistexodistpackage Test2::Manual::Testing; use strict; use warnings; our $VERSION = '0.000129'; 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. =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 bundle (which is an exception to the namespace rule as it does not live under C). 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, specifically things included in L 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 as your dependency. L 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 into their own distributions. One goal of L is to avoid breaking backwards compatibility. Another goal is to always improve by replacing bad designs with better ones. When necessary L 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, and L you should have this in your config: [Prereqs / TestRequires] Test2::V0 = 0.000060 You B do this: [Prereqs / TestRequires] Test2::Suite = 0.000060 Because L might not always be part of L. When writing new tests you should often check L 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 is an introduction to writing tests using the L tools. =head2 MIGRATING FROM TEST::BUILDER and TEST::MORE L Is a tutorial for converting old tests that use L or L to the newer L way of doing things. =head2 ADVANCED PLANNING L is a tutorial on the many ways to set a plan. =head2 TODO TESTS L 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual/Tooling.pm0000644000175000017500000000474713615053353020732 0ustar exodistexodistpackage Test2::Manual::Tooling; use strict; use warnings; our $VERSION = '0.000129'; 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 - Introduction to writing tools by cloning L. =head2 MOVING FROM Test::Builder L - This section maps Test::Builder methods to Test2 concepts. =head2 NESTING TOOLS L - How to call other tools from your tool. =head2 TOOLS WITH SUBTESTS L - How write tools that make use of subtests. =head2 TESTING YOUR TEST TOOLS L - How to write tests for your test tools. =head1 PLUGIN TUTORIALS =head2 TAKING ACTION WHEN A NEW TOOL STARTS L - How to add behaviors that occur when a tool starts work. =head2 TAKING ACTION AFTER A TOOL IS DONE L - How to add behaviors that occur when a tool completes work. =head2 TAKING ACTION AT THE END OF TESTING L - How to add behaviors that occur when testing is complete (IE done_testing, or end of test). =head2 TAKING ACTION JUST BEFORE EXIT L - How to safely add pre-exit behaviors. =head1 WRITING A SIMPLE JSONL FORMATTER L - 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 is the global API. This is primarily used by plugins that provide global behavior. =item In hubs L 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 - Primary index of the manual. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Workflow/0000755000175000017500000000000013615053353017342 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Workflow/Task/0000755000175000017500000000000013615053353020244 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Workflow/Task/Action.pm0000644000175000017500000000142713615053353022023 0ustar exodistexodistpackage Test2::Workflow::Task::Action; use strict; use warnings; our $VERSION = '0.000129'; use base 'Test2::Workflow::Task'; use Test2::Util::HashBase qw/around/; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Workflow::Task::Action - Encapsulation of an action. =head1 SOURCE The source code repository for Test2-Workflow can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist7@gmail.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Workflow/Task/Group.pm0000644000175000017500000000417513615053353021705 0ustar exodistexodistpackage Test2::Workflow::Task::Group; use strict; use warnings; our $VERSION = '0.000129'; use Carp qw/croak/; use Test2::Workflow::Task::Action; use base 'Test2::Workflow::Task'; use Test2::Util::HashBase qw/before after primary rand variant/; sub init { my $self = shift; if (my $take = delete $self->{take}) { $self->{$_} = delete $take->{$_} for ISO, ASYNC, TODO, SKIP; $self->{$_} = $take->{$_} for FLAT, SCAFFOLD, NAME, CODE, FRAME; $take->{+FLAT} = 1; $take->{+SCAFFOLD} = 1; } { local $Carp::CarpLevel = $Carp::CarpLevel + 1; $self->SUPER::init(); } $self->{+BEFORE} ||= []; $self->{+AFTER} ||= []; $self->{+PRIMARY} ||= []; } sub filter { my $self = shift; my ($filter) = @_; return if $self->{+IS_ROOT}; my $result = $self->SUPER::filter($filter); my $child_ok = 0; for my $c (@{$self->{+PRIMARY}}) { next if $c->{+SCAFFOLD}; # A child matches the filter, so we should not be filtered, but also # should not satisfy the filter. my $res = $c->filter($filter); # A child satisfies the filter $child_ok++ if !$res || $res->{satisfied}; last if $child_ok; } # If the filter says we are ok unless($result) { # If we are a variant then allow everything under us to be run return {satisfied => 1} if $self->{+VARIANT} || !$child_ok; # Normal group return; } return if $child_ok; return $result; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Workflow::Task::Group - Encapsulation of a group (describe). =head1 SOURCE The source code repository for Test2-Workflow can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist7@gmail.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Workflow/BlockBase.pm0000644000175000017500000000612013615053353021524 0ustar exodistexodistpackage Test2::Workflow::BlockBase; use strict; use warnings; our $VERSION = '0.000129'; use Test2::Util::HashBase qw/code frame _info _lines/; use Sub::Info qw/sub_info/; use List::Util qw/min max/; use Carp qw/croak/; use Test2::Util::Trace(); BEGIN { local ($@, $!, $SIG{__DIE__}); my $set_name = eval { require Sub::Util; Sub::Util->can('set_subname') } || eval { require Sub::Name; Sub::Name->can('subname') }; *set_subname = $set_name ? sub { my $self = shift; my ($name) = @_; $set_name->($name, $self->{+CODE}); delete $self->{+_INFO}; return 1; } : sub { return 0 }; } sub init { my $self = shift; croak "The 'code' attribute is required" unless $self->{+CODE}; croak "The 'frame' attribute is required" unless $self->{+FRAME}; $self->{+_LINES} = delete $self->{lines} if $self->{lines}; } sub file { shift->info->{file} } sub lines { shift->info->{lines} } sub package { shift->info->{package} } sub subname { shift->info->{name} } sub info { my $self = shift; unless ($self->{+_INFO}) { my $info = sub_info($self->code); my $frame = $self->frame; my $file = $info->{file}; my $all_lines = $info->{all_lines}; my $pre_lines = $self->{+_LINES}; my $lines = $info->{lines} ||= []; if ($pre_lines && @$pre_lines) { @$lines = @$pre_lines; } else { @$lines = ( min(@$all_lines, $frame->[2]), max(@$all_lines, $frame->[2]), ) if $frame->[1] eq $file; } # Adjust for start $lines->[0]-- if $lines->[0] != $lines->[1]; $self->{+_INFO} = $info; } return $self->{+_INFO}; } sub trace { my $self = shift; my ($hub, %params) = @_; croak "'hub' is required" unless $hub; return Test2::Util::Trace->new( frame => $self->frame, detail => $self->debug, buffered => $hub->buffered, nested => $hub->nested, hid => $hub->hid, huuid => $hub->uuid, %params, ); } sub debug { my $self = shift; my $file = $self->file; my $lines = $self->lines; my $line_str = @$lines == 1 ? "around line $lines->[0]" : "around lines $lines->[0] -> $lines->[1]"; return "at $file $line_str."; } sub throw { my $self = shift; my ($msg) = @_; die "$msg " . $self->debug . "\n"; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Workflow::BlockBase - Base class for all workflow blocks. =head1 SOURCE The source code repository for Test2-Workflow can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist7@gmail.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Workflow/Runner.pm0000644000175000017500000003110113615053353021145 0ustar exodistexodistpackage Test2::Workflow::Runner; use strict; use warnings; our $VERSION = '0.000129'; use Test2::API(); use Test2::Todo(); use Test2::AsyncSubtest(); use Test2::Util qw/get_tid CAN_REALLY_FORK/; use Scalar::Util qw/blessed/; use Time::HiRes qw/sleep/; use List::Util qw/shuffle min/; use Carp qw/confess/; use Test2::Util::HashBase qw{ stack no_fork no_threads max slots pid tid rand subtests filter }; use overload( 'fallback' => 1, '&{}' => sub { my $self = shift; sub { @_ = ($self); goto &run; } }, ); sub init { my $self = shift; $self->{+STACK} = []; $self->{+SUBTESTS} = []; $self->{+PID} = $$; $self->{+TID} = get_tid(); $self->{+NO_FORK} ||= $ENV{T2_WORKFLOW_NO_FORK} || !CAN_REALLY_FORK(); my $can_thread = Test2::AsyncSubtest->CAN_REALLY_THREAD(); my $should_thread = ($ENV{T2_WORKFLOW_USE_THREADS} || $ENV{T2_DO_THREAD_TESTS}) && !$ENV{T2_WORKFLOW_NO_THREADS}; $self->{+NO_THREADS} ||= !($can_thread && $should_thread); $self->{+RAND} = 1 unless defined $self->{+RAND}; my @max = grep {defined $_} $self->{+MAX}, $ENV{T2_WORKFLOW_ASYNC}; my $max = @max ? min(@max) : 3; $self->{+MAX} = $max; $self->{+SLOTS} = [] if $max; unless(defined($self->{+FILTER})) { if (my $raw = $ENV{T2_WORKFLOW}) { my ($file, $line, $name); if ($raw =~ m/^(.*)\s+(\d+)$/) { ($file, $line) = ($1, $2); } elsif($raw =~ m/^(\d+)$/) { $line = $1; } else { $name = $raw; } $self->{+FILTER} = { file => $file, line => $line, name => $name, }; } } if (my $task = delete $self->{task}) { $self->push_task($task); } } sub is_local { my $self = shift; return 0 unless $self->{+PID} == $$; return 0 unless $self->{+TID} == get_tid(); return 1; } sub send_event { my $self = shift; my ($type, %params) = @_; my $class; if ($type =~ m/\+(.*)$/) { $class = $1; } else { $class = "Test2::Event::$type"; } my $hub = Test2::API::test2_stack()->top(); my $e = $class->new( trace => Test2::Util::Trace->new( frame => [caller(0)], buffered => $hub->buffered, nested => $hub->nested, hid => $hub->hid, huuid => $hub->uuid, #cid => $self->{+CID}, #uuid => $self->{+UUID}, ), %params, ); $hub->send($e); } sub current_subtest { my $self = shift; my $stack = $self->{+STACK} or return undef; for my $state (reverse @$stack) { next unless $state->{subtest}; return $state->{subtest}; } return undef; } sub run { my $self = shift; my $stack = $self->stack; my $c = 0; while (@$stack) { $self->cull; my $state = $stack->[-1]; my $task = $state->{task}; unless($state->{started}++) { my $skip = $task->skip; my $filter; if (my $f = $self->{+FILTER}) { my $in_var = grep { $_->{filter_satisfied} } @$stack; $filter = $task->filter($f) unless $in_var; $state->{filter_satisfied} = 1 if $filter->{satisfied}; } $skip ||= $filter->{skip} if $filter; if ($skip) { $state->{ended}++; $self->send_event( 'Skip', reason => $skip || $filter, name => $task->name, pass => 1, effective_pass => 1, ); pop @$stack; next; } if ($task->flat) { my $st = $self->current_subtest; my $hub = $st ? $st->hub : Test2::API::test2_stack->top; $state->{todo} = Test2::Todo->new(reason => $task->todo, hub => $hub) if $task->todo; $hub->send($_) for @{$task->events}; } else { my $st = Test2::AsyncSubtest->new( name => $task->name, frame => $task->frame, ); $state->{subtest} = $st; $state->{todo} = Test2::Todo->new(reason => $task->todo, hub => $st->hub) if $task->todo; for my $e (@{$task->events}) { my $hub = $st->hub; $e->trace->{buffered} = $hub->buffered; $e->trace->{nested} = $hub->nested; $e->trace->{hid} = $hub->hid; $e->trace->{huuid} = $hub->uuid; $hub->send($e); } my $slot = $self->isolate($state); # if we forked/threaded then this state has ended here. if (defined($slot)) { push @{$self->{+SUBTESTS}} => [$st, $task] unless $st->finished; $state->{subtest} = undef; $state->{ended} = 1; } } } if ($state->{ended}) { $state->{todo}->end() if $state->{todo}; $state->{subtest}->stop() if $state->{subtest}; return if $state->{in_thread}; if(my $guard = delete $state->{in_fork}) { $state->{subtest}->detach; $guard->dismiss; exit 0; } pop @$stack; next; } if($state->{subtest} && !$state->{subtest_started}++) { push @{$self->{+SUBTESTS}} => [$state->{subtest}, $task]; $state->{subtest}->start(); } if ($task->isa('Test2::Workflow::Task::Action')) { $state->{PID} = $$; my $ok = eval { $task->code->($self); 1 }; unless ($state->{PID} == $$) { print STDERR "Task '" . $task->name . "' started in pid $state->{PID}, but ended in pid $$, did you forget to exit after forking?\n"; exit 255; } $task->exception($@) unless $ok; $state->{ended} = 1; next; } if (!$state->{stage} || $state->{stage} eq 'BEFORE') { $state->{before} = (defined $state->{before}) ? $state->{before} : 0; if (my $add = $task->before->[$state->{before}++]) { if ($add->around) { $state->{PID} = $$; my $ok = eval { $add->code->($self); 1 }; my $err = $@; my $complete = $state->{stage} && $state->{stage} eq 'AFTER'; unless ($state->{PID} == $$) { print STDERR "Task '" . $task->name . "' started in pid $state->{PID}, but ended in pid $$, did you forget to exit after forking?\n"; exit 255; } unless($ok && $complete) { $state->{ended} = 1; $state->{stage} = 'AFTER'; $task->exception($ok ? "'around' task failed to continue into the workflow chain.\n" : $err); } } else { $self->push_task($add); } } else { $state->{stage} = 'VARIANT'; } } elsif ($state->{stage} eq 'VARIANT') { if (my $v = $task->variant) { $self->push_task($v); } $state->{stage} = 'PRIMARY'; } elsif ($state->{stage} eq 'PRIMARY') { unless (defined $state->{order}) { my $rand = defined($task->rand) ? $task->rand : $self->rand; $state->{order} = [0 .. scalar(@{$task->primary}) - 1]; @{$state->{order}} = shuffle(@{$state->{order}}) if $rand; } my $num = shift @{$state->{order}}; if (defined $num) { $self->push_task($task->primary->[$num]); } else { $state->{stage} = 'AFTER'; } } elsif ($state->{stage} eq 'AFTER') { $state->{after} = (defined $state->{after}) ? $state->{after} : 0; if (my $add = $task->after->[$state->{after}++]) { return if $add->around; $self->push_task($add); } else { $state->{ended} = 1; } } } $self->finish; } sub push_task { my $self = shift; my ($task) = @_; confess "No Task!" unless $task; confess "Bad Task ($task)!" unless blessed($task) && $task->isa('Test2::Workflow::Task'); if ($task->isa('Test2::Workflow::Build')) { confess "Can only push a Build instance when initializing the stack" if @{$self->{+STACK}}; $task = $task->compile(); } push @{$self->{+STACK}} => { task => $task, name => $task->name, }; } sub add_mock { my $self = shift; my ($mock) = @_; my $stack = $self->{+STACK}; confess "Nothing on the stack!" unless $stack && @$stack; my ($state) = grep { !$_->{task}->scaffold} reverse @$stack; push @{$state->{mocks}} => $mock; } sub isolate { my $self = shift; my ($state) = @_; return if $state->{task}->skip; my $iso = $state->{task}->iso; my $async = $state->{task}->async; # No need to isolate return undef unless $iso || $async; # Cannot isolate unless($self->{+MAX} && $self->is_local) { # async does not NEED to be isolated return undef unless $iso; } # Wait for a slot, if max is set to 0 then we will not find a slot, instead # we use '0'. We need to return a defined value to let the stack know that # the task has ended. my $slot = 0; while($self->{+MAX} && $self->is_local) { $self->cull; for my $s (1 .. $self->{+MAX}) { my $st = $self->{+SLOTS}->[$s]; next if $st && !$st->finished; $self->{+SLOTS}->[$s] = undef; $slot = $s; last; } last if $slot; sleep(0.02); } my $st = $state->{subtest} or confess "Cannot isolate a task without a subtest"; if (!$self->no_fork) { my $out = $st->fork; if (blessed($out)) { $state->{in_fork} = $out; # drop back out to complete the task. return undef; } else { $self->send_event( 'Note', message => "Forked PID $out to run: " . $state->{task}->name, ); $state->{pid} = $out; } } elsif (!$self->no_threads) { $state->{in_thread} = 1; my $thr = $st->run_thread(\&run, $self); $state->{thread} = $thr; delete $state->{in_thread}; $self->send_event( 'Note', message => "Started Thread-ID " . $thr->tid . " to run: " . $state->{task}->name, ); } else { $st->finish(skip => "No isolation method available"); return 0; } if($slot) { $self->{+SLOTS}->[$slot] = $st; } else { $st->finish; } return $slot; } sub cull { my $self = shift; my $subtests = delete $self->{+SUBTESTS} || return; my @new; # Cull subtests in reverse order, Nested subtests end before their parents. for my $set (reverse @$subtests) { my ($st, $task) = @$set; next if $st->finished; if (!$st->active && $st->ready) { $st->finish(); next; } # Use unshift to preserve order. unshift @new => $set; } $self->{+SUBTESTS} = \@new; return; } sub finish { my $self = shift; while(@{$self->{+SUBTESTS}}) { $self->cull; sleep(0.02) if @{$self->{+SUBTESTS}}; } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Workflow::Runner - Runs the workflows. =head1 SOURCE The source code repository for Test2-Workflow can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist7@gmail.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Workflow/Build.pm0000644000175000017500000000714213615053353020743 0ustar exodistexodistpackage Test2::Workflow::Build; use strict; use warnings; our $VERSION = '0.000129'; use Test2::Workflow::Task::Group; our @BUILD_FIELDS; BEGIN { @BUILD_FIELDS = qw{ primary variant setup teardown variant_setup variant_teardown primary_setup primary_teardown stash }; } use base 'Test2::Workflow::Task'; use Test2::Util::HashBase @BUILD_FIELDS, qw/events defaults stack_stop/; sub init { my $self = shift; { local $Carp::CarpLevel = $Carp::CarpLevel + 1; $self->SUPER::init(); } $self->{$_} ||= [] for @BUILD_FIELDS; $self->{+DEFAULTS} ||= {}; } for my $field (@BUILD_FIELDS) { my $code = sub { my $self = shift; push @{$self->{$field}} => @_; }; no strict 'refs'; *{"add_$field"} = $code; } sub populated { my $self = shift; for my $field (@BUILD_FIELDS) { return 1 if @{$self->{$field}}; } return 0; } sub compile { my $self = shift; warn "Workflow build '$self->{+NAME}' is empty " . $self->debug . "\n" unless $self->populated || $self->{+SKIP}; my ($primary_setup, $primary_teardown) = @_; $primary_setup ||= []; $primary_teardown ||= []; my $variant = $self->{+VARIANT}; my $setup = $self->{+SETUP}; my $teardown = $self->{+TEARDOWN}; my $variant_setup = $self->{+VARIANT_SETUP}; my $variant_teardown = $self->{+VARIANT_TEARDOWN}; $primary_setup = [@$primary_setup, @{$self->{+PRIMARY_SETUP}}]; $primary_teardown = [@{$self->{+PRIMARY_TEARDOWN}}, @$primary_teardown]; # Get primaries in order. my $primary = [ map { $_->isa(__PACKAGE__) ? $_->compile($primary_setup, $primary_teardown) : $_; } @{$self->{+PRIMARY}}, ]; if (@$primary_setup || @$primary_teardown) { $primary = [ map { my $p = $_->clone; $_->isa('Test2::Workflow::Task::Action') ? Test2::Workflow::Task::Group->new( before => $primary_setup, primary => [ $p ], take => $p, after => $primary_teardown, ) : $_; } @$primary ]; } # Build variants if (@$variant) { $primary = [ map { my $v = $_->clone; Test2::Workflow::Task::Group->new( before => $variant_setup, primary => $primary, after => $variant_teardown, variant => $v, take => $v, ); } @$variant ]; } my %params = map { Test2::Workflow::Task::Group->can($_) ? ($_ => $self->{$_}) : () } keys %$self; delete $params{$_} for @BUILD_FIELDS; return Test2::Workflow::Task::Group->new( %params, before => $setup, after => $teardown, primary => $primary, ); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Workflow::Build - Represents a build in progress. =head1 SOURCE The source code repository for Test2-Workflow can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist7@gmail.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Workflow/Task.pm0000644000175000017500000000747113615053353020613 0ustar exodistexodistpackage Test2::Workflow::Task; use strict; use warnings; our $VERSION = '0.000129'; use Test2::API(); use Test2::Event::Exception(); use List::Util qw/min max/; use Scalar::Util qw/blessed/; use Carp qw/croak/; our @CARP_NOT = qw/Test2::Util::HashBase/; use base 'Test2::Workflow::BlockBase'; use Test2::Util::HashBase qw/name flat async iso todo skip scaffold events is_root/; for my $attr (FLAT, ISO, ASYNC, TODO, SKIP, SCAFFOLD) { my $old = __PACKAGE__->can("set_$attr"); my $new = sub { my $self = shift; my $out = $self->$old(@_); $self->verify_scaffold; return $out; }; no strict 'refs'; no warnings 'redefine'; *{"set_$attr"} = $new; } sub init { my $self = shift; $self->{+EVENTS} ||= []; { local $Carp::CarpLevel = $Carp::CarpLevel + 1; $self->SUPER::init(); } $self->throw("the 'name' attribute is required") unless $self->{+NAME}; $self->throw("the 'flat' attribute cannot be combined with 'iso' or 'async'") if $self->{+FLAT} && ($self->{+ISO} || $self->{+ASYNC}); $self->set_subname($self->package . "::<$self->{+NAME}>"); $self->verify_scaffold; } sub clone { my $self = shift; return bless {%$self}, blessed($self); } sub verify_scaffold { my $self = shift; return unless $self->{+SCAFFOLD}; croak "The 'flat' attribute must be true for scaffolding" if defined($self->{+FLAT}) && !$self->{+FLAT}; $self->{+FLAT} = 1; for my $attr (ISO, ASYNC, TODO, SKIP) { croak "The '$attr' attribute cannot be used on scaffolding" if $self->{$attr}; } } sub exception { my $self = shift; my ($err) = @_; my $hub = Test2::API::test2_stack->top; my $trace = $self->trace($hub); $hub->send( Test2::Event::Exception->new( trace => $trace, error => $err, ), ); } sub filter { my $self = shift; my ($filter) = @_; return unless $filter; return if $self->{+IS_ROOT}; return if $self->{+SCAFFOLD}; if (my $name = $filter->{name}) { my $ok = 0; unless(ref($name)) { $ok ||= $self->{+NAME} eq $name; $ok ||= $self->subname eq $name; } if (ref($name) eq 'Regexp') { $ok ||= $self->{+NAME} =~ $name; $ok ||= $self->subname =~ $name; } elsif ($name =~ m{^/}) { my $pattern = eval "qr$name" or die "'$name' does not appear to be a valid pattern"; $ok ||= $self->{+NAME} =~ $pattern; $ok ||= $self->subname =~ $pattern; } return {skip => "Does not match name filter '$name'"} unless $ok; } if (my $file = $filter->{file}) { return {skip => "Does not match file filter '$file'"} unless $self->file eq $file; } if (my $line = $filter->{line}) { my $lines = $self->lines; return {skip => "Does not match line filter '$line' (no lines)"} unless $lines && @$lines; my $min = min(@$lines); my $max = max(@$lines); return {skip => "Does not match line filter '$min <= $line <= $max'"} unless $min <= $line && $max >= $line; } return; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Workflow::Task - Encapsulation of a Task =head1 SOURCE The source code repository for Test2-Workflow can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist7@gmail.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Require/0000755000175000017500000000000013615053353017144 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Require/AuthorTesting.pm0000644000175000017500000000232313615053353022302 0ustar exodistexodistpackage Test2::Require::AuthorTesting; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '0.000129'; 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Require/RealFork.pm0000644000175000017500000000271513615053353021214 0ustar exodistexodistpackage Test2::Require::RealFork; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '0.000129'; 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 Similar to this module, but will allow fork emulation. =item L 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Require/Threads.pm0000644000175000017500000000407513615053353021102 0ustar exodistexodistpackage Test2::Require::Threads; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '0.000129'; 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 Skip the test file if the system does not support forking. =item L Test2::Require::Threads uses L under the hood. =back =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Require/EnvVar.pm0000644000175000017500000000240613615053353020705 0ustar exodistexodistpackage Test2::Require::EnvVar; use strict; use warnings; use Carp qw/confess/; use base 'Test2::Require'; our $VERSION = '0.000129'; 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Require/Module.pm0000644000175000017500000000467513615053353020743 0ustar exodistexodistpackage Test2::Require::Module; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '0.000129'; 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. The difference is that this module is based on L directly, and does not go through L. 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Require/Perl.pm0000644000175000017500000000261113615053353020404 0ustar exodistexodistpackage Test2::Require::Perl; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '0.000129'; 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Require/Fork.pm0000644000175000017500000000444113615053353020406 0ustar exodistexodistpackage Test2::Require::Fork; use strict; use warnings; use base 'Test2::Require'; our $VERSION = '0.000129'; 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 Similar to this module, but will skip on any perl that only has fork emulation. =item L 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/AsyncSubtest.pm0000644000175000017500000004527413615053353020531 0ustar exodistexodistpackage Test2::AsyncSubtest; use strict; use warnings; use Test2::IPC; our $VERSION = '0.000129'; 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 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 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. 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. =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 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 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 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 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. This must only be called in the original process/thread. =item $ctx = $ast->context Get an L 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 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 event. =item silent => 1 This will prevent finish from generating a final L 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 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. It will return a pid in the parent, and an L 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, 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist7@gmail.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/0000755000175000017500000000000013615053353017116 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Compare/OrderedSubset.pm0000644000175000017500000000661713615053353022240 0ustar exodistexodistpackage Test2::Compare::OrderedSubset; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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 { '' } 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<< "" >>. =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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Negatable.pm0000644000175000017500000000432013615053353021335 0ustar exodistexodistpackage Test2::Compare::Negatable; use strict; use warnings; our $VERSION = '0.000129'; 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 subclass will overload C and import C and C. =head1 WHY? Until perl 5.18 the 'fallback' parameter to L 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 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. =back =head1 METHODS =over 4 =item $clone = $obj->clone_negate() Create a shallow copy of the object, and call C 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/EventMeta.pm0000644000175000017500000000317213615053353021347 0ustar exodistexodistpackage Test2::Compare::EventMeta; use strict; use warnings; use base 'Test2::Compare::Meta'; our $VERSION = '0.000129'; 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Wildcard.pm0000644000175000017500000000220713615053353021206 0ustar exodistexodistpackage Test2::Compare::Wildcard; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/DeepRef.pm0000644000175000017500000000370613615053353020774 0ustar exodistexodistpackage Test2::Compare::DeepRef; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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 { '' } 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Pattern.pm0000644000175000017500000000326113615053353021073 0ustar exodistexodistpackage Test2::Compare::Pattern; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Custom.pm0000644000175000017500000000616013615053353020731 0ustar exodistexodistpackage Test2::Compare::Custom; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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} ||= ''; $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 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 exists at all. If C is false then it means C 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Scalar.pm0000644000175000017500000000377313615053353020673 0ustar exodistexodistpackage Test2::Compare::Scalar; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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 { '' } 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Number.pm0000644000175000017500000000507213615053353020710 0ustar exodistexodistpackage Test2::Compare::Number; use strict; use warnings; use Carp qw/confess/; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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: This will fail if the received value is undefined. It must be a number. B: 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/String.pm0000644000175000017500000000344613615053353020731 0ustar exodistexodistpackage Test2::Compare::String; use strict; use warnings; use Carp qw/confess/; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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: 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Object.pm0000644000175000017500000001412213615053353020662 0ustar exodistexodistpackage Test2::Compare::Object; use strict; use warnings; use Test2::Util qw/try/; use Test2::Compare::Meta(); use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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 { '' } 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. =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. This method just delegates. =item $obj->add_field(...) Add a hash-field to check, see L. This method just delegates. =item $obj->add_item(...) Add an array item to check, see L. 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Float.pm0000644000175000017500000000775613615053353020540 0ustar exodistexodistpackage Test2::Compare::Float; use strict; use warnings; use Carp qw/confess/; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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: This will fail if the received value is undefined. It must be a number. B: 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Andrew Grangaard Espazm@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Event.pm0000644000175000017500000000251013615053353020533 0ustar exodistexodistpackage Test2::Compare::Event; use strict; use warnings; use Scalar::Util qw/blessed/; use Test2::Compare::EventMeta(); use base 'Test2::Compare::Object'; our $VERSION = '0.000129'; use Test2::Util::HashBase qw/etype/; sub name { my $self = shift; my $etype = $self->etype; return ""; } 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Delta.pm0000644000175000017500000003223513615053353020512 0ustar exodistexodistpackage Test2::Compare::Delta; use strict; use warnings; our $VERSION = '0.000129'; 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 }}, ); 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 ""; } my $dne = $self->{+DNE}; return '' if $dne && $dne eq 'got'; my $got = $self->{+GOT}; return '' 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 '' if $dne && $dne eq 'check'; my $check = $self->{+CHK}; return '' 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} " 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 $xxx = Dumper($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 $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), @diag ); use Data::Dumper; my $table = Test2::EventFacet::Info::Table->new( %$table_args, rows => $rows, as_string => $render, xxx => $xxx, ); 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. 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, C, C, C, and C. =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 and C 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Undef.pm0000644000175000017500000000242413615053353020517 0ustar exodistexodistpackage Test2::Compare::Undef; use strict; use warnings; use Carp qw/confess/; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; use Test2::Util::HashBase; # Overloads '!' for us. use Test2::Compare::Negatable; sub name { '' } 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Array.pm0000644000175000017500000001775313615053353020547 0ustar exodistexodistpackage Test2::Compare::Array; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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 { '' } 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 that there is no validation when using C, it is better to use the C 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 that there is no validation when using C, it is better to use the C interface. =item $name = $arr->name() Always returns the string C<< "" >>. =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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Regex.pm0000644000175000017500000000302613615053353020527 0ustar exodistexodistpackage Test2::Compare::Regex; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Meta.pm0000644000175000017500000000554713615053353020355 0ustar exodistexodistpackage Test2::Compare::Meta; use strict; use warnings; use Test2::Compare::Delta(); use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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 { '' } 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); 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_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 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Base.pm0000644000175000017500000001314613615053353020333 0ustar exodistexodistpackage Test2::Compare::Base; use strict; use warnings; our $VERSION = '0.000129'; 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 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Bool.pm0000644000175000017500000000351413615053353020352 0ustar exodistexodistpackage Test2::Compare::Bool; use strict; use warnings; use Carp qw/confess/; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Hash.pm0000644000175000017500000001337413615053353020347 0ustar exodistexodistpackage Test2::Compare::Hash; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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 { '' } 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Bag.pm0000644000175000017500000001265013615053353020151 0ustar exodistexodistpackage Test2::Compare::Bag; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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 { '' } 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 that there is no validation when using C, it is better to use the C interface. =item $name = $arr->name() Always returns the string C<< "" >>. =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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =item Gianni Ceccarelli Edakkar@thenautilus.netE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =item Gianni Ceccarelli Edakkar@thenautilus.netE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. Copyright 2018 Gianni Ceccarelli Edakkar@thenautilus.netE This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Set.pm0000644000175000017500000000564013615053353020214 0ustar exodistexodistpackage Test2::Compare::Set; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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 { '' } 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 function in the L plugin. =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare/Ref.pm0000644000175000017500000000365513615053353020201 0ustar exodistexodistpackage Test2::Compare::Ref; use strict; use warnings; use base 'Test2::Compare::Base'; our $VERSION = '0.000129'; 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Bundle/0000755000175000017500000000000013615053353016741 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Bundle/Extended.pm0000644000175000017500000001663713615053353021054 0ustar exodistexodistpackage Test2::Bundle::Extended; use strict; use warnings; use Test2::V0; our $VERSION = '0.000129'; 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, 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 itself. =head1 SYNOPSIS use Test2::Bundle::Extended ':v1'; ok(1, "pass"); ... done_testing; =head1 RESOLVING CONFLICTS WITH MOOSE use Test2::Bundle::Extended '!meta'; L and L both export very different C 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 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 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 =item ok => {-as => 'my_ok'} Actually, go ahead and import C but under the name C. =back If you did not add the C<'!ok'> argument then you would have both C and C =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 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 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 plugin, see the L section for details. B C<< -no_pragmas => 1 >> will turn off the entire plugin. =head1 PLUGINS =head2 SRAND See L. 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. 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. This plugin has no configuration. =head1 API FUNCTIONS See L for these =over 4 =item $ctx = context() =item $events = intercept { ... } =back =head1 TOOLS =head2 TARGET See L. You can specify a target class with the C<-target> import argument. If you do not provide a target then C<$CLASS> and C 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. =over 4 =item def $func => @args; =item do_def() =back =head2 BASIC See L. =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. =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 = 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. =over 4 =item cmp_ok($got, $op, $want, $name) =back =head2 SUBTEST See L. =over 4 =item subtest $name => sub { ... } (Note: This is called C in the Tools module.) =back =head2 CLASS See L. =over 4 =item can_ok($thing, @methods) =item isa_ok($thing, @classes) =item DOES_ok($thing, @roles) =back =head2 ENCODING See L. =over 4 =item set_encoding($encoding) =back =head2 EXPORTS See L. =over 4 =item imported_ok('function', '$scalar', ...) =item not_imported_ok('function', '$scalar', ...) =back =head2 REF See L. =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. =over 4 =item $control = mock ... =item $bool = mocked($thing) =back =head2 EXCEPTION See L. =over 4 =item $exception = dies { ... } =item $bool = lives { ... } =item $bool = try_ok { ... } =back =head2 WARNINGS See L. =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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Bundle/Simple.pm0000644000175000017500000000374213615053353020536 0ustar exodistexodistpackage Test2::Bundle::Simple; use strict; use warnings; our $VERSION = '0.000129'; 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. 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. =head1 TOOLS These are all from L. =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 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, C, or C for your planning. =back =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Bundle/More.pm0000644000175000017500000000761213615053353020207 0ustar exodistexodistpackage Test2::Bundle::More; use strict; use warnings; our $VERSION = '0.000129'; 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. 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. =head1 TOOLS These are from L. See L 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. See L 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. See L for details. =over 4 =item isa_ok($thing, @classes) =item can_ok($thing, @subs) =back This is from L. It is called C 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 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, C, or C for your planning. =item isa_ok accepts different arguments C in Test::More was: isa_ok($thing, $isa, $alt_thing_name); This was very inconsistent with tools like C. In Test2::Bundle::More, C 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. =item use_ok() =item require_ok() These are not necessary. Use C and C 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. (See explain in L vs L. 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Plugin/0000755000175000017500000000000013615053353016766 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Plugin/ExitSummary.pm0000644000175000017500000000361613615053353021621 0ustar exodistexodistpackage Test2::Plugin::ExitSummary; use strict; use warnings; our $VERSION = '0.000129'; 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 generally expect these diagnostics. =head1 SYNOPSIS use Test2::Plugin::ExitSummary; =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Plugin/BailOnFail.pm0000644000175000017500000000272613615053353021273 0ustar exodistexodistpackage Test2::Plugin::BailOnFail; use strict; use warnings; our $VERSION = '0.000129'; 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, 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Plugin/DieOnFail.pm0000644000175000017500000000266713615053353021131 0ustar exodistexodistpackage Test2::Plugin::DieOnFail; use strict; use warnings; our $VERSION = '0.000129'; 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, 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Plugin/Times.pm0000644000175000017500000000611313615053353020406 0ustar exodistexodistpackage 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.000129'; 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 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Plugin/SRand.pm0000644000175000017500000001007413615053353020335 0ustar exodistexodistpackage Test2::Plugin::SRand; use strict; use warnings; our $VERSION = '0.000129'; 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 (@_) { ($SEED) = @_; $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 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 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 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Plugin/UTF8.pm0000644000175000017500000000537213615053353020061 0ustar exodistexodistpackage Test2::Plugin::UTF8; use strict; use warnings; our $VERSION = '0.000129'; 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 enable 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 weather 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. =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/0000755000175000017500000000000013615053353016630 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Tools/ClassicCompare.pm0000644000175000017500000002743413615053353022070 0ustar exodistexodistpackage Test2::Tools::ClassicCompare; use strict; use warnings; our $VERSION = '0.000129'; 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 : ''], ['orig', $got_ref, '', $exp_ref], ], ); } else { @table = table( header => ['GOT', 'OP', 'CHECK'], rows => [[$display_got, $op, $lived ? $display_exp : '']], ); } $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, unlike the L 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 if you want an C 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, 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. 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. =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 with some other stuff to make it more sane. This is useful for comparing numbers, overloaded objects, etc. B 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. B If the comparison results in an exception then the test will fail and the exception will be shown. C 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/AsyncSubtest.pm0000644000175000017500000000735213615053353021624 0ustar exodistexodistpackage Test2::Tools::AsyncSubtest; use strict; use warnings; our $VERSION = '0.000129'; 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; $ast3->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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist7@gmail.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Exception.pm0000644000175000017500000000720013615053353021123 0ustar exodistexodistpackage Test2::Tools::Exception; use strict; use warnings; our $VERSION = '0.000129'; 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 implementation of code used to test exceptions. This is similar to L, 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 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 sets C<$Test::Builder::Level> such that failing tests inside the exception block will report to the line where C is called. I disagree with this, and think the actual line of the failing test is more important. Ultimately, though L cannot be changed, people probably already depend on that behavior. =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Encoding.pm0000644000175000017500000000305313615053353020715 0ustar exodistexodistpackage Test2::Tools::Encoding; use strict; use warnings; use Carp qw/croak/; use Test2::API qw/test2_stack/; use base 'Exporter'; our $VERSION = '0.000129'; our @EXPORT = qw/set_encoding/; sub set_encoding { my $enc = shift; my $format = test2_stack->top->format; unless ($format && eval { $format->can('encoding') }) { $format = '' 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 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Warnings.pm0000644000175000017500000000556613615053353020772 0ustar exodistexodistpackage Test2::Tools::Warnings; use strict; use warnings; our $VERSION = '0.000129'; use Test2::API qw/context/; our @EXPORT = qw/warns warning warnings no_warnings/; use base 'Exporter'; sub warns(&) { my $code = shift; my $warnings = 0; local $SIG{__WARN__} = sub { $warnings++ }; $code->(); return $warnings; } sub no_warnings(&) { return !&warns(@_) } sub warning(&) { my $code = shift; my @warnings; { local $SIG{__WARN__} = sub { push @warnings => @_ }; $code->(); return unless @warnings; } if (@warnings > 1) { my $ctx = context(); $ctx->alert("Extra warnings in warning { ... }"); $ctx->note($_) for @warnings; $ctx->release; } return $warnings[0]; } sub warnings(&) { my $code = shift; my @warnings; local $SIG{__WARN__} = sub { push @warnings => @_ }; $code->(); return \@warnings; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Tools::Warnings - Tools to verify warnings. =head1 DESCRIPTION This is a collection of tools that can be used to test code that issues warnings. =head1 SYNOPSIS use Test2::Tools::Warnings qw/warns warning warnings no_warnings/; ok(warns { warn 'a' }, "the code warns"); ok(!warns { 1 }, "The code does not warn"); is(warns { warn 'a'; warn 'b' }, 2, "got 2 warnings"); ok(no_warnings { ... }, "code did not warn"); like( warning { warn 'xxx' }, qr/xxx/, "Got expected warning" ); is( warnings { warn "a\n"; warn "b\n" }, [ "a\n", "b\n", ], "Got 2 specific warnings" ); =head1 EXPORTS All subs are exported by default. =over 4 =item $count = warns { ... } Returns the count of warnings produced by the block. This will always return 0, or a positive integer. =item $warning = warning { ... } Returns the first warning generated by the block. If the block produces more than one warning, they will all be shown as notes, and an actual warning will tell you about it. =item $warnings_ref = warnings { ... } Returns an arrayref with all the warnings produced by the block. This will always return an array reference. If there are no warnings, this will return an empty array reference. =item $bool = no_warnings { ... } Return true if the block has no warnings. Returns false if there are warnings. =back =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Exports.pm0000644000175000017500000000761413615053353020642 0ustar exodistexodistpackage Test2::Tools::Exports; use strict; use warnings; our $VERSION = '0.000129'; 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 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 and C cannot see package scalars declared using C 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 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/GenTemp.pm0000644000175000017500000000462513615053353020534 0ustar exodistexodistpackage Test2::Tools::GenTemp; use strict; use warnings; our $VERSION = '0.000129'; 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, 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Compare.pm0000644000175000017500000013173613615053353020567 0ustar exodistexodistpackage Test2::Tools::Compare; use strict; use warnings; our $VERSION = '0.000129'; use Carp qw/croak/; use Scalar::Util qw/reftype/; use Test2::API qw/context/; use Test2::Util::Ref qw/rtype/; use Test2::Compare qw{ compare get_build push_build pop_build build strict_convert relaxed_convert }; use Test2::Compare::Array(); use Test2::Compare::Bag(); use Test2::Compare::Bool(); use Test2::Compare::Custom(); use Test2::Compare::Event(); use Test2::Compare::Float(); 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::DeepRef(); use Test2::Compare::Regex(); use Test2::Compare::Scalar(); use Test2::Compare::Set(); use Test2::Compare::String(); use Test2::Compare::Undef(); use Test2::Compare::Wildcard(); %Carp::Internal = ( %Carp::Internal, 'Test2::Tools::Compare' => 1, 'Test2::Compare::Array' => 1, 'Test2::Compare::Bag' => 1, 'Test2::Compare::Bool' => 1, 'Test2::Compare::Custom' => 1, 'Test2::Compare::Event' => 1, 'Test2::Compare::Float' => 1, 'Test2::Compare::Hash' => 1, 'Test2::Compare::Meta' => 1, 'Test2::Compare::Number' => 1, 'Test2::Compare::Object' => 1, 'Test2::Compare::Pattern' => 1, 'Test2::Compare::Ref' => 1, 'Test2::Compare::Regex' => 1, 'Test2::Compare::Scalar' => 1, 'Test2::Compare::Set' => 1, 'Test2::Compare::String' => 1, 'Test2::Compare::Undef' => 1, 'Test2::Compare::Wildcard' => 1, 'Test2::Compare::OrderedSubset' => 1, ); our @EXPORT = qw/is like/; our @EXPORT_OK = qw{ is like isnt unlike match mismatch validator hash array bag object meta meta_check number float rounded within string subset bool in_set not_in_set check_set item field call call_list call_hash prop check all_items all_keys all_vals all_values etc end filter_items T F D DF DNE FDNE E U event fail_events exact_ref }; use base 'Exporter'; sub is($$;$@) { my ($got, $exp, $name, @diag) = @_; my $ctx = context(); 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 old behavior was to default to etc() when inside is().", "The old behavior was a bug.", "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; } sub isnt($$;$@) { my ($got, $exp, $name, @diag) = @_; my $ctx = context(); my $delta = compare($got, $exp, \&strict_convert); if ($delta) { $ctx->ok(1, $name); } else { $ctx->ok(0, $name, ["Comparison matched (it should not).", @diag]); } $ctx->release; return $delta ? 1 : 0; } sub like($$;$@) { my ($got, $exp, $name, @diag) = @_; my $ctx = context(); my $delta = compare($got, $exp, \&relaxed_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, \&relaxed_convert); if ($delta) { $ctx->ok(1, $name); } else { $ctx->ok(0, $name, ["Comparison matched (it should not).", @diag]); } $ctx->release; return $delta ? 1 : 0; } sub meta(&) { build('Test2::Compare::Meta', @_) } sub meta_check(&) { build('Test2::Compare::Meta', @_) } sub hash(&) { build('Test2::Compare::Hash', @_) } sub array(&) { build('Test2::Compare::Array', @_) } sub bag(&) { build('Test2::Compare::Bag', @_) } sub object(&) { build('Test2::Compare::Object', @_) } sub subset(&) { build('Test2::Compare::OrderedSubset', @_) } sub U() { my @caller = caller; Test2::Compare::Custom->new( code => sub { defined $_ ? 0 : 1 }, name => 'UNDEFINED', operator => '!DEFINED()', file => $caller[1], lines => [$caller[2]], ); } sub D() { my @caller = caller; Test2::Compare::Custom->new( code => sub { defined $_ ? 1 : 0 }, name => 'DEFINED', operator => 'DEFINED()', file => $caller[1], lines => [$caller[2]], ); } sub DF() { my @caller = caller; Test2::Compare::Custom->new( code => sub { defined $_ && ( ! ref $_ && ! $_ ) ? 1 : 0 }, name => 'DEFINED BUT FALSE', operator => 'DEFINED() && FALSE()', file => $caller[1], lines => [$caller[2]], ); } sub DNE() { my @caller = caller; Test2::Compare::Custom->new( code => sub { my %p = @_; $p{exists} ? 0 : 1 }, name => '', operator => '!exists', file => $caller[1], lines => [$caller[2]], ); } sub E() { my @caller = caller; Test2::Compare::Custom->new( code => sub { my %p = @_; $p{exists} ? 1 : 0 }, name => '', operator => '!exists', file => $caller[1], lines => [$caller[2]], ); } sub F() { my @caller = caller; Test2::Compare::Custom->new( code => sub { my %p = @_; $p{got} ? 0 : $p{exists} }, name => 'FALSE', operator => 'FALSE()', file => $caller[1], lines => [$caller[2]], ); } sub FDNE() { my @caller = caller; Test2::Compare::Custom->new( code => sub { defined $_ && ( ref $_ || $_ ) ? 0 : 1 }, name => 'FALSE', operator => 'FALSE() || !exists', file => $caller[1], lines => [$caller[2]], ); } sub T() { my @caller = caller; Test2::Compare::Custom->new( code => sub { defined $_ && ( ref $_ || $_ ) ? 1 : 0 }, name => 'TRUE', operator => 'TRUE()', file => $caller[1], lines => [$caller[2]], ); } sub exact_ref($) { my @caller = caller; return Test2::Compare::Ref->new( file => $caller[1], lines => [$caller[2]], input => $_[0], ); } sub match($) { my @caller = caller; return Test2::Compare::Pattern->new( file => $caller[1], lines => [$caller[2]], pattern => $_[0], ); } sub mismatch($) { my @caller = caller; return Test2::Compare::Pattern->new( file => $caller[1], lines => [$caller[2]], negate => 1, pattern => $_[0], ); } sub validator { my $code = pop; my $cname = pop; my $op = pop; my @caller = caller; return Test2::Compare::Custom->new( file => $caller[1], lines => [$caller[2]], code => $code, name => $cname, operator => $op, ); } sub number($;@) { my ($num, @args) = @_; my @caller = caller; return Test2::Compare::Number->new( file => $caller[1], lines => [$caller[2]], input => $num, @args, ); } sub float($;@) { my ($num, @args) = @_; my @caller = caller; return Test2::Compare::Float->new( file => $caller[1], lines => [$caller[2]], input => $num, @args, ); } sub rounded($$) { my ($num, $precision) = @_; my @caller = caller; return Test2::Compare::Float->new( file => $caller[1], lines => [$caller[2]], input => $num, precision => $precision, ); } sub within($;$) { my ($num, $tolerance) = @_; my @caller = caller; return Test2::Compare::Float->new( file => $caller[1], lines => [$caller[2]], input => $num, defined $tolerance ? ( tolerance => $tolerance ) : (), ); } sub bool($;@) { my ($bool, @args) = @_; my @caller = caller; return Test2::Compare::Bool->new( file => $caller[1], lines => [$caller[2]], input => $bool, @args, ); } sub string($;@) { my ($str, @args) = @_; my @caller = caller; return Test2::Compare::String->new( file => $caller[1], lines => [$caller[2]], input => $str, @args, ); } sub filter_items(&) { defined( my $build = get_build() ) or croak "No current build!"; croak "'$build' does not support filters" unless $build->can('add_filter'); croak "'filter_items' should only ever be called in void context" if defined wantarray; $build->add_filter(@_); } sub all_items { defined( my $build = get_build() ) or croak "No current build!"; croak "'$build' does not support all-items" unless $build->can('add_for_each'); croak "'all_items' should only ever be called in void context" if defined wantarray; $build->add_for_each(@_); } sub all_keys { defined( my $build = get_build() ) or croak "No current build!"; croak "'$build' does not support all-keys" unless $build->can('add_for_each_key'); croak "'all_keys' should only ever be called in void context" if defined wantarray; $build->add_for_each_key(@_); } *all_vals = *all_values; sub all_values { defined( my $build = get_build() ) or croak "No current build!"; croak "'$build' does not support all-values" unless $build->can('add_for_each_val'); croak "'all_values' should only ever be called in void context" if defined wantarray; $build->add_for_each_val(@_); } sub end() { defined( my $build = get_build() ) or croak "No current build!"; croak "'$build' does not support 'ending'" unless $build->can('ending'); croak "'end' should only ever be called in void context" if defined wantarray; $build->set_ending(1); } sub etc() { defined( my $build = get_build() ) or croak "No current build!"; croak "'$build' does not support 'ending'" unless $build->can('ending'); croak "'etc' should only ever be called in void context" if defined wantarray; $build->set_ending(0); } my $_call = sub { my ($name, $expect, $context, $func_name) = @_; defined( my $build = get_build() ) or croak "No current build!"; croak "'$build' does not support method calls" unless $build->can('add_call'); croak "'$func_name' should only ever be called in void context" if defined wantarray; my @caller = caller; $build->add_call( $name, Test2::Compare::Wildcard->new( expect => $expect, file => $caller[1], lines => [$caller[2]], ), undef, $context, ); }; sub call($$) { $_call->(@_,'scalar','call') } sub call_list($$) { $_call->(@_,'list','call_list') } sub call_hash($$) { $_call->(@_,'hash','call_hash') } sub prop($$) { my ($name, $expect) = @_; defined( my $build = get_build() ) or croak "No current build!"; croak "'$build' does not support meta-checks" unless $build->can('add_prop'); croak "'prop' should only ever be called in void context" if defined wantarray; my @caller = caller; $build->add_prop( $name, Test2::Compare::Wildcard->new( expect => $expect, file => $caller[1], lines => [$caller[2]], ), ); } sub item($;$) { my @args = @_; my $expect = pop @args; defined( my $build = get_build() ) or croak "No current build!"; croak "'$build' does not support array item checks" unless $build->can('add_item'); croak "'item' should only ever be called in void context" if defined wantarray; my @caller = caller; push @args => Test2::Compare::Wildcard->new( expect => $expect, file => $caller[1], lines => [$caller[2]], ); $build->add_item(@args); } sub field($$) { my ($name, $expect) = @_; defined( my $build = get_build() ) or croak "No current build!"; croak "'$build' does not support hash field checks" unless $build->can('add_field'); croak "'field' should only ever be called in void context" if defined wantarray; my @caller = caller; $build->add_field( $name, Test2::Compare::Wildcard->new( expect => $expect, file => $caller[1], lines => [$caller[2]], ), ); } sub check($) { my ($check) = @_; defined( my $build = get_build() ) or croak "No current build!"; croak "'$build' is not a check-set" unless $build->can('add_check'); croak "'check' should only ever be called in void context" if defined wantarray; my @caller = caller; my $wc = Test2::Compare::Wildcard->new( expect => $check, file => $caller[1], lines => [$caller[2]], ); $build->add_check($wc); } sub check_set { return _build_set('all' => @_) } sub in_set { return _build_set('any' => @_) } sub not_in_set { return _build_set('none' => @_) } sub _build_set { my $redux = shift; my ($builder) = @_; my $btype = reftype($builder) || ''; my $set; if ($btype eq 'CODE') { $set = build('Test2::Compare::Set', $builder); $set->set_builder($builder); } else { $set = Test2::Compare::Set->new(checks => [@_]); } $set->set_reduction($redux); return $set; } sub fail_events($;$) { my $event = &event(@_); my $diag = event('Diag'); return ($event, $diag) if defined wantarray; defined( my $build = get_build() ) or croak "No current build!"; $build->add_item($event); $build->add_item($diag); } sub event($;$) { my ($intype, $spec) = @_; my @caller = caller; croak "type is required" unless $intype; my $type; if ($intype =~ m/^\+(.*)$/) { $type = $1; } else { $type = "Test2::Event::$intype"; } my $event; if (!$spec) { $event = Test2::Compare::Event->new( etype => $intype, file => $caller[1], lines => [$caller[2]], ending => 0, ); } elsif (!ref $spec) { croak "'$spec' is not a valid event specification"; } elsif (reftype($spec) eq 'CODE') { $event = build('Test2::Compare::Event', $spec); $event->set_etype($intype); $event->set_builder($spec); $event->set_ending(0) unless defined $event->ending; } else { my $refcheck = Test2::Compare::Hash->new( inref => $spec, file => $caller[1], lines => [$caller[2]], ); $event = Test2::Compare::Event->new( refcheck => $refcheck, file => $caller[1], lines => [$caller[2]], etype => $intype, ending => 0, ); } $event->add_prop('blessed' => $type); return $event if defined wantarray; defined( my $build = get_build() ) or croak "No current build!"; $build->add_item($event); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Tools::Compare - Tools for comparing deep data structures. =head1 DESCRIPTION L had C. This library is the L version that can be used to compare data structures, but goes a step further in that it provides tools for building a data structure specification against which you can verify your data. There are both 'strict' and 'relaxed' versions of the tools. =head1 SYNOPSIS use Test2::Tools::Compare; # Hash for demonstration purposes my $some_hash = {a => 1, b => 2, c => 3}; # Strict checking, everything must match is( $some_hash, {a => 1, b => 2, c => 3}, "The hash we got matches our expectations" ); # Relaxed Checking, only fields we care about are checked, and we can use a # regex to approximate a field. like( $some_hash, {a => 1, b => qr/[0-9]+/}, "'a' is 1, 'b' is an integer, we don't care about 'c'." ); =head2 ADVANCED Declarative hash, array, and objects builders are available that allow you to generate specifications. These are more verbose than simply providing a hash, but have the advantage that every component you specify has a line number associated. This is helpful for debugging as the failure output will tell you not only which fields was incorrect, but also the line on which you declared the field. use Test2::Tools::Compare qw{ is like isnt unlike match mismatch validator hash array bag object meta number float rounded within string subset bool in_set not_in_set check_set item field call call_list call_hash prop check all_items all_keys all_vals all_values etc end filter_items T F D DNE FDNE E event fail_events exact_ref }; is( $some_hash, hash { field a => 1; field b => 2; field c => 3; }, "Hash matches spec" ); =head1 COMPARISON TOOLS =over 4 =item $bool = is($got, $expect) =item $bool = is($got, $expect, $name) =item $bool = is($got, $expect, $name, @diag) C<$got> is the data structure you want to check. C<$expect> is what you want C<$got> to look like. C<$name> is an optional name for the test. C<@diag> is optional diagnostics messages that will be printed to STDERR in event of failure, they will not be displayed when the comparison is successful. The boolean true/false result of the comparison is returned. This is the strict checker. The strict checker requires a perfect match between C<$got> and C<$expect>. All hash fields must be specified, all array items must be present, etc. All non-scalar/hash/array/regex references must be identical (same memory address). Scalar, hash and array references will be traversed and compared. Regex references will be compared to see if they have the same pattern. is( $some_hash, {a => 1, b => 2, c => 3}, "The hash we got matches our expectations" ); The only exception to strictness is when it is given an C<$expect> object that was built from a specification, in which case the specification determines the strictness. Strictness only applies to literal values/references that are provided and converted to a specification for you. is( $some_hash, hash { # Note: the hash function is not exported by default field a => 1; field b => match(qr/[0-9]+/); # Note: The match function is not exported by default # Don't care about other fields. }, "The hash comparison is not strict" ); This works for both deep and shallow structures. For instance you can use this to compare two strings: is('foo', 'foo', "strings match"); B: This is not the tool to use if you want to check if two references are the same exact reference, use C from the L plugin instead. I of the time this will work as well, however there are problems if your reference contains a cycle and refers back to itself at some point. If this happens, an exception will be thrown to break an otherwise infinite recursion. B: Non-reference values will be compared as strings using C, so that means '2.0' and '2' will match. =item $bool = isnt($got, $expect) =item $bool = isnt($got, $expect, $name) =item $bool = isnt($got, $expect, $name, @diag) Opposite of C. Does all the same checks, but passes when there is a mismatch. =item $bool = like($got, $expect) =item $bool = like($got, $expect, $name) =item $bool = like($got, $expect, $name, @diag) C<$got> is the data structure you want to check. C<$expect> is what you want C<$got> to look like. C<$name> is an optional name for the test. C<@diag> is optional diagnostics messages that will be printed to STDERR in event of failure, they will not be displayed when the comparison is successful. The boolean true/false result of the comparison is returned. This is the relaxed checker. This will ignore hash keys or array indexes that you do not actually specify in your C<$expect> structure. In addition regex and sub references will be used as validators. If you provide a regex using C, the regex itself will be used to validate the corresponding value in the C<$got> structure. The same is true for coderefs, the value is passed in as the first argument (and in C<$_>) and the sub should return a boolean value. In this tool regexes will stringify the thing they are checking. like( $some_hash, {a => 1, b => qr/[0-9]+/}, "'a' is 1, 'b' is an integer, we don't care about other fields" ); This works for both deep and shallow structures. For instance you can use this to compare two strings: like('foo bar', qr/^foo/, "string matches the pattern"); =item $bool = unlike($got, $expect) =item $bool = unlike($got, $expect, $name) =item $bool = unlike($got, $expect, $name, @diag) Opposite of C. Does all the same checks, but passes when there is a mismatch. =back =head2 QUICK CHECKS B Quick checks are a way to quickly generate a common value specification. These can be used in structures passed into C and C through the C<$expect> argument. Example: is($foo, T(), '$foo has a true value'); =over 4 =item $check = T() This verifies that the value in the corresponding C<$got> structure is true, any true value will do. is($foo, T(), '$foo has a true value'); is( { a => 'xxx' }, { a => T() }, "The 'a' key is true" ); =item $check = F() This verifies that the value in the corresponding C<$got> structure is false, any false value will do, B. is($foo, F(), '$foo has a false value'); is( { a => 0 }, { a => F() }, "The 'a' key is false" ); It is important to note that a nonexistent value does not count as false. This check will generate a failing test result: is( { a => 1 }, { a => 1, b => F() }, "The 'b' key is false" ); This will produce the following output: not ok 1 - The b key is false # Failed test "The 'b' key is false" # at some_file.t line 10. # +------+------------------+-------+---------+ # | PATH | GOT | OP | CHECK | # +------+------------------+-------+---------+ # | {b} | | FALSE | FALSE() | # +------+------------------+-------+---------+ In Perl, you can have behavior that is different for a missing key vs. a false key, so it was decided not to count a completely absent value as false. See the C shortcut below for checking that a field is missing. If you want to check for false and/or DNE use the C check. =item $check = D() This is to verify that the value in the C<$got> structure is defined. Any value other than C will pass. This will pass: is('foo', D(), 'foo is defined'); This will fail: is(undef, D(), 'foo is defined'); =item $check = U() This is to verify that the value in the C<$got> structure is undefined. This will pass: is(undef, U(), 'not defined'); This will fail: is('foo', U(), 'not defined'); =item $check = DF() This is to verify that the value in the C<$got> structure is defined but false. Any false value other than C will pass. This will pass: is(0, DF(), 'foo is defined but false'); These will fail: is(undef, DF(), 'foo is defined but false'); is(1, DF(), 'foo is defined but false'); =item $check = E() This can be used to check that a value exists. This is useful to check that an array has more values, or to check that a key exists in a hash, even if the value is undefined. These pass: is(['a', 'b', undef], ['a', 'b', E()], "There is a third item in the array"); is({a => 1, b => 2}, {a => 1, b => E()}, "The 'b' key exists in the hash"); These will fail: is(['a', 'b'], ['a', 'b', E()], "Third item exists"); is({a => 1}, {a => 1, b => E()}, "'b' key exists"); =item $check = DNE() This can be used to check that no value exists. This is useful to check the end bound of an array, or to check that a key does not exist in a hash. These pass: is(['a', 'b'], ['a', 'b', DNE()], "There is no third item in the array"); is({a => 1}, {a => 1, b => DNE()}, "The 'b' key does not exist in the hash"); These will fail: is(['a', 'b', 'c'], ['a', 'b', DNE()], "No third item"); is({a => 1, b => 2}, {a => 1, b => DNE()}, "No 'b' key"); =item $check = FDNE() This is a combination of C and C. This will pass for a false value, or a nonexistent value. =back =head2 VALUE SPECIFICATIONS B =over 4 =item $check = string "..." Verify that the value matches the given string using the C operator. =item $check = !string "..." Verify that the value does not match the given string using the C operator. =item $check = number ...; Verify that the value matches the given number using the C<==> operator. =item $check = !number ...; Verify that the value does not match the given number using the C operator. =item $check = float ...; Verify that the value is approximately equal to the given number. If a 'precision' parameter is specified, both operands will be rounded to 'precision' number of fractional decimal digits and compared with C. is($near_val, float($val, precision = 4), "Near 4 decimal digits"); Otherwise, the check will be made within a range of +/- 'tolerance', with a default 'tolerance' of 1e-08. is( $near_val, float($val, tolerance = 0.01), "Almost there..."); See also C and C. =item $check = !float ...; Verify that the value is not approximately equal to the given number. If a 'precision' parameter is specified, both operands will be rounded to 'precision' number of fractional decimal digits and compared with C. Otherwise, the check will be made within a range of +/- 'tolerance', with a default 'tolerance' of 1e-08. See also C and C. =item $check = within($num, $tolerance); Verify that the value approximately matches the given number, within a range of +/- C<$tolerance>. Compared using the C<==> operator. C<$tolerance> is optional and defaults to 1e-08. =item $check = !within($num, $tolerance); Verify that the value does not approximately match the given number within a range of +/- C<$tolerance>. Compared using the C operator. C<$tolerance> is optional and defaults to 1e-08. =item $check = rounded($num, $precision); Verify that the value approximately matches the given number, when both are rounded to C<$precision> number of fractional digits. Compared using the C operator. =item $check = !rounded($num, $precision); Verify that the value does not approximately match the given number, when both are rounded to C<$precision> number of fractional digits. Compared using the C operator. =item $check = bool ...; Verify the value has the same boolean value as the given argument (XNOR). =item $check = !bool ...; Verify the value has a different boolean value from the given argument (XOR). =item $check = match qr/.../ =item $check = !mismatch qr/.../ Verify that the value matches the regex pattern. This form of pattern check will B stringify references being checked. B C is documented for completion, please do not use it. =item $check = !match qr/.../ =item $check = mismatch qr/.../ Verify that the value does not match the regex pattern. This form of pattern check will B stringify references being checked. B C was created before overloading of C for C was a thing. =item $check = validator(sub{ ... }) =item $check = validator($NAME => sub{ ... }) =item $check = validator($OP, $NAME, sub{ ... }) The coderef is the only required argument. The coderef should check that the value is what you expect and return a boolean true or false. Optionally, you can specify a name and operator that are used in diagnostics. They are also provided to the sub itself as named parameters. Check the value using this sub. The sub gets the value in C<$_>, and it receives the value and several other items as named parameters. my $check = validator(sub { my %params = @_; # These both work: my $got = $_; my $got = $params{got}; # Check if a value exists at all my $exists = $params{exists} # What $OP (if any) did we specify when creating the validator my $operator = $params{operator}; # What name (if any) did we specify when creating the validator my $name = $params{name}; ... return $bool; } =item $check = exact_ref($ref) Check that the value is exactly the same reference as the one provided. =back =head2 SET BUILDERS B =over 4 =item my $check = check_set($check1, $check2, ...) Check that the value matches ALL of the specified checks. =item my $check = in_set($check1, $check2, ...) Check that the value matches ONE OR MORE of the specified checks. =item not_in_set($check1, $check2, ...) Check that the value DOES NOT match ANY of the specified checks. =item check $thing Check that the value matches the specified thing. =back =head2 HASH BUILDER B $check = hash { field foo => 1; field bar => 2; # Ensure the 'baz' keys does not even exist in the hash. field baz => DNE(); # Ensure the key exists, but is set to undef field bat => undef; # Any check can be used field boo => $check; # Set checks that apply to all keys or values. Can be done multiple # times, and each call can define multiple checks, all will be run. all_vals match qr/a/, match qr/b/; # All keys must have an 'a' and a 'b' all_keys match qr/x/; # All keys must have an 'x' ... end(); # optional, enforces that no other keys are present. }; =over 4 =item $check = hash { ... } This is used to define a hash check. =item field $NAME => $VAL =item field $NAME => $CHECK Specify a field check. This will check the hash key specified by C<$NAME> and ensure it matches the value in C<$VAL>. You can put any valid check in C<$VAL>, such as the result of another call to C, C, etc. B This function can only be used inside a hash builder sub, and must be called in void context. =item all_keys($CHECK1, $CHECK2, ...) Add checks that apply to all keys. You can put this anywhere in the hash block, and can call it any number of times with any number of arguments. =item all_vals($CHECK1, $CHECK2, ...) =item all_values($CHECK1, $CHECK2, ...) Add checks that apply to all values. You can put this anywhere in the hash block, and can call it any number of times with any number of arguments. =item end() Enforce that no keys are found in the hash other than those specified. This is essentially the C of a hash check. This can be used anywhere in the hash builder, though typically it is placed at the end. =item etc() Ignore any extra keys found in the hash. This is the opposite of C. This can be used anywhere in the hash builder, though typically it is placed at the end. =item DNE() This is a handy check that can be used with C to ensure that a field (D)oes (N)ot (E)xist. field foo => DNE(); =back =head2 ARRAY BUILDER B $check = array { # Uses the next index, in this case index 0; item 'a'; # Gets index 1 automatically item 'b'; # Specify the index item 2 => 'c'; # We skipped index 3, which means we don't care what it is. item 4 => 'e'; # Gets index 5. item 'f'; # Remove any REMAINING items that contain 0-9. filter_items { grep {!m/[0-9]/} @_ }; # Set checks that apply to all items. Can be done multiple times, and # each call can define multiple checks, all will be run. all_items match qr/a/, match qr/b/; all_items match qr/x/; # Of the remaining items (after the filter is applied) the next one # (which is now index 6) should be 'g'. item 6 => 'g'; item 7 => DNE; # Ensure index 7 does not exist. end(); # Ensure no other indexes exist. }; =over 4 =item $check = array { ... } =item item $VAL =item item $CHECK =item item $IDX, $VAL =item item $IDX, $CHECK Add an expected item to the array. If C<$IDX> is not specified it will automatically calculate it based on the last item added. You can skip indexes, which means you do not want them to be checked. You can provide any value to check in C<$VAL>, or you can provide any valid check object. B Items MUST be added in order. B This function can only be used inside an array, bag or subset builder sub, and must be called in void context. =item filter_items { my @remaining = @_; ...; return @filtered } This function adds a filter, all items remaining in the array from the point the filter is reached will be passed into the filter sub as arguments, the sub should return only the items that should be checked. B This function can only be used inside an array builder sub, and must be called in void context. =item all_items($CHECK1, $CHECK2, ...) Add checks that apply to all items. You can put this anywhere in the array block, and can call it any number of times with any number of arguments. =item end() Enforce that there are no indexes after the last one specified. This will not force checking of skipped indexes. =item etc() Ignore any extra items found in the array. This is the opposite of C. This can be used anywhere in the array builder, though typically it is placed at the end. =item DNE() This is a handy check that can be used with C to ensure that an index (D)oes (N)ot (E)xist. item 5 => DNE(); =back =head2 BAG BUILDER B $check = bag { item 'a'; item 'b'; end(); # Ensure no other elements exist. }; A bag is like an array, but we don't care about the order of the items. In the example, C<$check> would match both C<['a','b']> and C<['b','a']>. =over 4 =item $check = bag { ... } =item item $VAL =item item $CHECK Add an expected item to the bag. You can provide any value to check in C<$VAL>, or you can provide any valid check object. B This function can only be used inside an array, bag or subset builder sub, and must be called in void context. =item all_items($CHECK1, $CHECK2, ...) Add checks that apply to all items. You can put this anywhere in the bag block, and can call it any number of times with any number of arguments. =item end() Enforce that there are no more items after the last one specified. =item etc() Ignore any extra items found in the array. This is the opposite of C. This can be used anywhere in the bag builder, though typically it is placed at the end. =back =head2 ORDERED SUBSET BUILDER B $check = subset { item 'a'; item 'b'; item 'c'; # Doesn't matter if the array has 'd', the check will skip past any # unknown items until it finds the next one in our subset. item 'e'; item 'f'; }; =over 4 =item $check = subset { ... } =item item $VAL =item item $CHECK Add an expected item to the subset. You can provide any value to check in C<$VAL>, or you can provide any valid check object. B Items MUST be added in order. B This function can only be used inside an array, bag or subset builder sub, and must be called in void context. =back =head2 META BUILDER B my $check = meta { prop blessed => 'My::Module'; # Ensure value is blessed as our package prop reftype => 'HASH'; # Ensure value is a blessed hash prop size => 4; # Check the number of hash keys prop this => ...; # Check the item itself }; =over 4 =item meta { ... } =item meta_check { ... } Build a meta check. If you are using L then the C function would conflict with the one exported by L, in such cases C is available. Neither is exported by default. =item prop $NAME => $VAL =item prop $NAME => $CHECK Check the property specified by C<$name> against the value or check. Valid properties are: =over 4 =item 'blessed' What package (if any) the thing is blessed as. =item 'reftype' Reference type (if any) the thing is. =item 'this' The thing itself. =item 'size' For array references this returns the number of elements. For hashes this returns the number of keys. For everything else this returns undef. =back =back =head2 OBJECT BUILDER B my $check = object { call foo => 1; # Call the 'foo' method, check the result. # Call the specified sub-ref as a method on the object, check the # result. This is useful for wrapping methods that return multiple # values. call sub { [ shift->get_list ] } => [...]; # This can be used to ensure a method does not exist. call nope => DNE(); # Check the hash key 'foo' of the underlying reference, this only works # on blessed hashes. field foo => 1; # Check the value of index 4 on the underlying reference, this only # works on blessed arrays. item 4 => 'foo'; # Check the meta-property 'blessed' of the object. prop blessed => 'My::Module'; # Ensure only the specified hash keys or array indexes are present in # the underlying hash. Has no effect on meta-property checks or method # checks. end(); }; =over 4 =item $check = object { ... } Specify an object check for use in comparisons. =item call $METHOD_NAME => $RESULT =item call $METHOD_NAME => $CHECK =item call [$METHOD_NAME, @METHOD_ARGS] => $RESULT =item call [$METHOD_NAME, @METHOD_ARGS] => $CHECK =item call sub { ... }, $RESULT =item call sub { ... }, $CHECK Call the specified method (or coderef) and verify the result. If you pass an arrayref, the first element must be the method name, the others are the arguments it will be called with. The coderef form is useful if you need to do something more complex. my $ref = sub { local $SOME::GLOBAL::THING = 3; return [shift->get_values_for('thing')]; }; call $ref => ...; =item call_list $METHOD_NAME => $RESULT =item call_list $METHOD_NAME => $CHECK =item call_list [$METHOD_NAME, @METHOD_ARGS] => $RESULT =item call_list [$METHOD_NAME, @METHOD_ARGS] => $CHECK =item call_list sub { ... }, $RESULT =item call_list sub { ... }, $CHECK Same as C, but the method is invoked in list context, and the result is always an arrayref. call_list get_items => [ ... ]; =item call_hash $METHOD_NAME => $RESULT =item call_hash $METHOD_NAME => $CHECK =item call_hash [$METHOD_NAME, @METHOD_ARGS] => $RESULT =item call_hash [$METHOD_NAME, @METHOD_ARGS] => $CHECK =item call_hash sub { ... }, $RESULT =item call_hash sub { ... }, $CHECK Same as C, but the method is invoked in list context, and the result is always a hashref. This will warn if the method returns an odd number of values. call_hash get_items => { ... }; =item field $NAME => $VAL Works just like it does for hash checks. =item item $VAL =item item $IDX, $VAL Works just like it does for array checks. =item prop $NAME => $VAL =item prop $NAME => $CHECK Check the property specified by C<$name> against the value or check. Valid properties are: =over 4 =item 'blessed' What package (if any) the thing is blessed as. =item 'reftype' Reference type (if any) the thing is. =item 'this' The thing itself. =item 'size' For array references this returns the number of elements. For hashes this returns the number of keys. For everything else this returns undef. =back =item DNE() Can be used with C, or C to ensure the hash field or array index does not exist. Can also be used with C to ensure a method does not exist. =item end() Turn on strict array/hash checking, ensuring that no extra keys/indexes are present. =item etc() Ignore any extra items found in the hash/array. This is the opposite of C. This can be used anywhere in the builder, though typically it is placed at the end. =back =head2 EVENT BUILDERS B Check that we got an event of a specified type: my $check = event 'Ok'; Check for details about the event: my $check = event Ok => sub { # Check for a failure call pass => 0; # Effective pass after TODO/SKIP are accounted for. call effective_pass => 1; # Check the diagnostics call diag => [ match qr/Failed test foo/ ]; # Check the file the event reports to prop file => 'foo.t'; # Check the line number the event reports o prop line => '42'; # You can check the todo/skip values as well: prop skip => 'broken'; prop todo => 'fixme'; # Thread-id and process-id where event was generated prop tid => 123; prop pid => 123; }; You can also provide a fully qualified event package with the '+' prefix: my $check = event '+My::Event' => sub { ... } You can also provide a hashref instead of a sub to directly check hash values of the event: my $check = event Ok => { pass => 1, ... }; =head3 USE IN OTHER BUILDERS You can use these all in other builders, simply use them in void context to have their value(s) appended to the build. my $check = array { event Ok => { ... }; event Note => { ... }; fail_events Ok => { pass => 0 }; # Get a Diag for free. }; =head3 SPECIFICS =over 4 =item $check = event $TYPE; =item $check = event $TYPE => sub { ... }; =item $check = event $TYPE => { ... }; This works just like an object builder. In addition to supporting everything the object check supports, you also have to specify the event type, and many extra meta-properties are available. Extra properties are: =over 4 =item 'file' File name to which the event reports (for use in diagnostics). =item 'line' Line number to which the event reports (for use in diagnostics). =item 'package' Package to which the event reports (for use in diagnostics). =item 'subname' Sub that was called to generate the event (example: C). =item 'skip' Set to the skip value if the result was generated by skipping tests. =item 'todo' Set to the todo value if TODO was set when the event was generated. =item 'trace' The C string that will be used in diagnostics. =item 'tid' Thread ID in which the event was generated. =item 'pid' Process ID in which the event was generated. =back B: Event checks have an implicit C added. This means you need to use C if you want to fail on unexpected hash keys or array indexes. This implicit C extends to all forms, including builder, hashref, and no argument. =item @checks = fail_events $TYPE; =item @checks = fail_events $TYPE => sub { ... }; =item @checks = fail_events $TYPE => { ... }; Just like C documented above. The difference is that this produces two events, the one you specify, and a C after it. There are no extra checks in the Diag. Use this to validate a simple failure where you do not want to be bothered with the default diagnostics. It only adds a single Diag check, so if your failure has custom diagnostics you will need to add checks for them. =back =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Subtest.pm0000644000175000017500000000725313615053353020626 0ustar exodistexodistpackage Test2::Tools::Subtest; use strict; use warnings; our $VERSION = '0.000129'; 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 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 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 or C in a subtest, but not in a BEGIN block or C 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Tester.pm0000644000175000017500000001425613615053353020444 0ustar exodistexodistpackage Test2::Tools::Tester; use strict; use warnings; our $VERSION = '0.000129'; use Carp qw/croak/; use Module::Pluggable search_path => ['Test2::EventFacet'], require => 1; use Test2::Util::Ref qw/rtype/; use Importer Importer => 'import'; our @EXPORT_OK = qw{ facets filter_events event_groups }; my %TYPES; for my $class (__PACKAGE__->plugins) { my $type = $class; $type =~ s/^Test2::EventFacet:://g; next unless $class->isa('Test2::EventFacet'); my $key; $key = $class->facet_key if $class->can('facet_key'); $key = lc($type) unless defined $key; $TYPES{$type} = $class; $TYPES{lc($type)} = $class; $TYPES{$key} = $class; } sub filter_events { my $events = shift; my @match = map { rtype($_) eq 'REGEXP' ? $_ : qr/^\Q$_\E::/} @_; my @out; for my $e (@$events) { my $trace = $e->facet_data->{trace} or next; next unless grep { $trace->{frame}->[3] =~ $_ } @match; push @out => $e; } return \@out; } sub event_groups { my $events = shift; my $out = {}; for my $e (@$events) { my $trace = $e->facet_data->{trace}; my $tool = ($trace && $trace->{frame} && $trace->{frame}->[3]) ? $trace->{frame}->[3] : undef; unless ($tool) { push @{$out->{__NA__}} => $e; next; } my ($pkg, $sub) = ($tool =~ m/^(.*)(?:::|')([^:']+)$/); push @{$out->{$pkg}->{$sub}} => $e; push @{$out->{$pkg}->{__ALL__}} => $e; } return $out; } sub facets { my ($type, $events) = @_; my ($key, $is_list); my $class = $TYPES{$type}; if ($class) { $key = $class->facet_key || lc($type); $is_list = $class->is_list; } else { $key = lc($type); } my @out; for my $e (@$events) { my $fd = $e->facet_data; my $f = $fd->{$key} or next; my $list = defined($is_list) ? $is_list : rtype($f) eq 'ARRAY'; if ($list) { push @out => map { $class ? $class->new($_) : $_ } @$f; } else { push @out => $class ? $class->new($f) : $f; } } return \@out; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Tools::Tester - Tools to help you test other testing tools. =head1 DESCRIPTION This is a collection of tools that are useful when testing other test tools. =head1 SYNOPSIS use Test2::Tools::Tester qw/event_groups filter_events facets/; use Test2::Tools::Basic qw/plan pass ok/; use Test2::Tools::Compare qw/is like/; my $events = intercept { plan 11; pass('pass'); ok(1, 'pass'); is(1, 1, "pass"); like(1, 1, "pass"); }; # Grab events generated by tools in Test2::Tools::Basic my $basic = filter $events => 'Test2::Tools::Basic'; # Grab events generated by Test2::Tools::Basic; my $compare = filter $events => 'Test2::Tools::Compare'; # Grab events generated by tools named 'ok'. my $oks = filter $events => qr/.*::ok$/; my $grouped = group_events $events; # Breaks events into this structure: { '__NA__' => [ ... ], 'Test2::Tools::Basic' => { '__ALL__' => [ $events->[0], $events->[1], $events->[2] ], plan => [ $events->[0] ], pass => [ $events->[1] ], ok => [ $events->[2] ], }, Test2::Tools::Compare => { ... }, } # Get an arrayref of all the assert facets from the list of events. my $assert_facets = facets assert => $events; # [ # bless({ details => 'pass', pass => 1}, 'Test2::EventFacet::Assert'), # bless({ details => 'pass', pass => 1}, 'Test2::EventFacet::Assert'), # ] # Same, but for info facets my $info_facets = facets info => $events; =head1 EXPORTS No subs are exported by default. =over 4 =item $array_ref = filter $events => $PACKAGE =item $array_ref = filter $events => $PACKAGE1, $PACKAGE2 =item $array_ref = filter $events => qr/match/ =item $array_ref = filter $events => qr/match/, $PACKAGE This function takes an arrayref of events as the first argument. All additional arguments must either be a package name, or a regex. Any event that is generated by a tool in any of the package, or by a tool that matches any of the regexes, will be returned in an arrayref. =item $grouped = group_events($events) This function iterates all the events in the argument arrayref and splits them into groups. The resulting data structure is: { PACKAGE => { SUBNAME => [ $EVENT1, $EVENT2, ... }} If the package of an event is not known it will be put into and arrayref under the '__NA__' key at the root of the structure. If a sub name is not known it will typically go under the '__ANON__' key in under the package name. In addition there is an '__ALL__' key under each package which stores all of the events sorted into that group. A more complete example: { '__NA__' => [ $event->[3] ], 'Test2::Tools::Basic' => { '__ALL__' => [ $events->[0], $events->[1], $events->[2] ], plan => [ $events->[0] ], pass => [ $events->[1] ], ok => [ $events->[2] ], }, } =item $arrayref = facets TYPE => $events This function will compile a list of all facets of the specified type that are found in the arrayref of events. If the facet has a C package available then the facet will be constructed into an instance of the class, otherwise it is left as a hashref. Facet Order is preserved. my $assert_facets = facets assert => $events; # [ # bless({ details => 'pass', pass => 1}, 'Test2::EventFacet::Assert'), # bless({ details => 'pass', pass => 1}, 'Test2::EventFacet::Assert'), # ] =back =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Target.pm0000644000175000017500000000376613615053353020430 0ustar exodistexodistpackage Test2::Tools::Target; use strict; use warnings; our $VERSION = '0.000129'; 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Class.pm0000644000175000017500000001135713615053353020242 0ustar exodistexodistpackage Test2::Tools::Class; use strict; use warnings; our $VERSION = '0.000129'; 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" : ""; $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'" : ''; $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 based tools for validating classes and objects. These are similar to some tools from L, 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 This uses the C<< $class->DOES(...) >> method, not the C method Moose provides. B Not all perls have the C 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Event.pm0000644000175000017500000000333613615053353020254 0ustar exodistexodistpackage Test2::Tools::Event; use strict; use warnings; our $VERSION = '0.000129'; 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 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, you can prefix C<$TYPE> with a '+' to drop the assumption. An L will be generated using C 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Defer.pm0000644000175000017500000000651113615053353020216 0ustar exodistexodistpackage Test2::Tools::Defer; use strict; use warnings; our $VERSION = '0.000129'; 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 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 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Basic.pm0000644000175000017500000001563113615053353020215 0ustar exodistexodistpackage Test2::Tools::Basic; use strict; use warnings; our $VERSION = '0.000129'; 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 based implementation of the more basic tools originally provided by L. Not all L 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. 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Spec.pm0000644000175000017500000004043213615053353020063 0ustar exodistexodistpackage Test2::Tools::Spec; use strict; use warnings; our $VERSION = '0.000129'; 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 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 function is also used. C is an alias to C. 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) 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 block is run. These will run AFTER C blocks but before C 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, except these blocks run BEFORE C 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 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 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 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 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 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 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 This conflicts with the C exported from L. 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 or C 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< 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 function will immediately execute the codeblock it is given. All other functions will stash their codeblocks to be run later. When C 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). 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist7@gmail.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Grab.pm0000644000175000017500000000463013615053353020044 0ustar exodistexodistpackage Test2::Tools::Grab; use strict; use warnings; our $VERSION = '0.000129'; use Test2::Util::Grabber; our @EXPORT = qw/grab/; use base 'Exporter'; sub grab { Test2::Util::Grabber->new() } 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, 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 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 turned off, C 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 - The object constructed and returned by this tool. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools/Mock.pm0000644000175000017500000003113213615053353020057 0ustar exodistexodistpackage 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.000129'; 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, but with an improved API. This plugin is also intended to play well with other plugins in ways L 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) will be returned. =item $mock = mock $class => ( ... ); =item $mock = mock $instance => ( ... ) =item $mock = mock 'class', $class => ( ... ) These forms delegate to C 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 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. The second form calls the specified method on the current build. This second form delegates to C. =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 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 section). =item $mock = mock_class $class => ( ... ) =item $mock = mock_class $instance => ( ... ) =item $mock = mock_class ... => sub { ... } This will create a new instance of L 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 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 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. See it for their methods. =head1 SOURCE The source code repository for Test2-Suite can be found at L. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut Test2-Suite-0.000129/lib/Test2/Tools/Ref.pm0000644000175000017500000000717013615053353017707 0ustar exodistexodistpackage Test2::Tools::Ref; use strict; use warnings; our $VERSION = '0.000129'; 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 = '' unless defined $got; $exp = '' 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 = '' unless defined $got; $exp = '' 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Util/0000755000175000017500000000000013615053353016445 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Util/Table/0000755000175000017500000000000013615053353017474 5ustar exodistexodistTest2-Suite-0.000129/lib/Test2/Util/Table/LineBreak.pm0000644000175000017500000000211013615053353021660 0ustar exodistexodistpackage Test2::Util::Table::LineBreak; use strict; use warnings; our $VERSION = '0.000129'; use base 'Term::Table::LineBreak'; 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::Table::LineBreak - Break up lines for use in tables. =head1 DESCRIPTION This is meant for internal use. This package takes long lines of text and splits them so that they fit in table rows. =head1 SYNOPSIS use Test2::Util::Table::LineBreak; my $lb = Test2::Util::Table::LineBreak->new(string => $STRING); $lb->break($SIZE); while (my $part = $lb->next) { ... } =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Util/Table/Cell.pm0000644000175000017500000000017313615053353020712 0ustar exodistexodistpackage Test2::Util::Table::Cell; use strict; use warnings; our $VERSION = '0.000129'; use base 'Term::Table::Cell'; 1; Test2-Suite-0.000129/lib/Test2/Util/Grabber.pm0000644000175000017500000001221213615053353020345 0ustar exodistexodistpackage Test2::Util::Grabber; use strict; use warnings; our $VERSION = '0.000129'; use Test2::Hub::Interceptor(); use Test2::Util::Trace(); use Test2::API qw/test2_stack test2_ipc/; use Test2::Util::HashBase qw/hub finished _events term_size/; sub init { my $self = shift; # Make sure we have a hub on the stack test2_stack->top(); my $hub = test2_stack->new_hub( class => 'Test2::Hub::Interceptor', formatter => undef, no_ending => 1, ); $self->{+HUB} = $hub; my @events; $hub->listen(sub { push @events => $_[1] }); $self->{+_EVENTS} = \@events; $self->{+TERM_SIZE} = $ENV{TS_TERM_SIZE}; $ENV{TS_TERM_SIZE} = 80; } sub flush { my $self = shift; my $out = [@{$self->{+_EVENTS}}]; @{$self->{+_EVENTS}} = (); return $out; } sub events { my $self = shift; # Copy return [@{$self->{+_EVENTS}}]; } sub finish { my ($self) = @_; # Do not shift; $_[0] = undef; if (defined $self->{+TERM_SIZE}) { $ENV{TS_TERM_SIZE} = $self->{+TERM_SIZE}; } else { delete $ENV{TS_TERM_SIZE}; } my $hub = $self->{+HUB}; $self->{+FINISHED} = 1; test2_stack()->pop($hub); my $dbg = Test2::Util::Trace->new( frame => [caller(0)], ); $hub->finalize($dbg, 1) if !$hub->no_ending && !$hub->state->ended; return $self->flush; } sub DESTROY { my $self = shift; return if $self->{+FINISHED}; test2_stack->pop($self->{+HUB}); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::Grabber - Object used to temporarily intercept all events. =head1 DESCRIPTION Once created this object will intercept and stash all events sent to the shared L object. Once the object is destroyed, events will once again be sent to the shared hub. =head1 SYNOPSIS use Test2 qw/Core 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"); # Same as flush, except it destroys the grab object. my $events_b = $grab->finish; After calling C the grab object is destroyed and C<$grab> is set to undef. C<$events_a> is an arrayref with the first two events. C<$events_b> is an arrayref with the second two events. =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'); # $grab is magically undef after this. my $events = $grab->finish; is(@$events, 2, "grabbed two events."); When you call C the C<$grab> object will automagically undef itself, but only for the reference used in the method call. If you have other references to the C<$grab> object they will not be set to undef. If the C<$grab> object is destroyed without calling C, 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 set to true. This will prevent the hub from enforcing that you issued a plan and ran at least one test. You can turn enforcement back one like this: $grab->hub->set_no_ending(0); With C turned off, C 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 METHODS =over 4 =item $grab = $class->new() Create a new grab object, immediately starts intercepting events. =item $ar = $grab->flush() Get an arrayref of all the events so far, clearing the grab objects internal list. =item $ar = $grab->events() Get an arrayref of all events so far. Does not clear the internal list. =item $ar = $grab->finish() Get an arrayref of all the events, then destroy the grab object. =item $hub = $grab->hub() Get the hub that is used by the grab event. =back =head1 ENDING BEHAVIOR By default the hub used has C set to true. This will prevent the hub from enforcing that you issued a plan and ran at least one test. You can turn enforcement back one like this: $grab->hub->set_no_ending(0); With C turned off, C 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. =head1 SEE ALSO L - Accomplish the same thing, but using blocks instead. =head1 SOURCE The source code repository for Test2 can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Util/Table.pm0000644000175000017500000001144013615053353020032 0ustar exodistexodistpackage Test2::Util::Table; use strict; use warnings; our $VERSION = '0.000129'; use base 'Term::Table'; use Importer Importer => 'import'; our @EXPORT_OK = qw/table/; our %EXPORT_GEN = ( '&term_size' => sub { require Carp; Carp::cluck "term_size should be imported from Test2::Util::Term, not " . __PACKAGE__; Test2::Util::Term->can('term_size'); }, ); sub table { my %params = @_; $params{collapse} ||= 0; $params{sanitize} ||= 0; $params{mark_tail} ||= 0; $params{show_header} ||= 0 unless $params{header} && @{$params{header}}; __PACKAGE__->new(%params)->render; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::Table - Format a header and rows into a table =head1 DESCRIPTION This is used by some failing tests to provide diagnostics about what has gone wrong. This module is able to generic format rows of data into tables. =head1 SYNOPSIS use Test2::Util::Table qw/table/; my @table = table( max_width => 80, collapse => 1, # Do not show empty columns header => [ 'name', 'age', 'hair color' ], rows => [ [ 'Fred Flinstone', 2000000, 'black' ], [ 'Wilma Flinstone', 1999995, 'red' ], ..., ], ); # The @table array contains each line of the table, no newlines added. say $_ for @table; This prints a table like this: +-----------------+---------+------------+ | name | age | hair color | +-----------------+---------+------------+ | Fred Flinstone | 2000000 | black | | Wilma Flinstone | 1999995 | red | | ... | ... | ... | +-----------------+---------+------------+ =head1 EXPORTS =head2 @rows = table(...) The function returns a list of lines, lines do not have the newline C<\n> character appended. Options: =over 4 =item header => [ ... ] If you want a header specify it here. This takes an arrayref with each columns heading. =item rows => [ [...], [...], ... ] This should be an arrayref containing an arrayref per row. =item collapse => $bool Use this if you want to hide empty columns, that is any column that has no data in any row. Having a header for the column will not effect collapse. =item max_width => $num Set the maximum width of the table, the table may not be this big, but it will be no bigger. If none is specified it will attempt to find the width of your terminal and use that, otherwise it falls back to C<80>. =item sanitize => $bool This will sanitize all the data in the table such that newlines, control characters, and all whitespace except for ASCII 20 C<' '> are replaced with escape sequences. This prevents newlines, tabs, and similar whitespace from disrupting the table. B newlines are marked as '\n', but a newline is also inserted into the data so that it typically displays in a way that is useful to humans. Example: my $field = "foo\nbar\nbaz\n"; print join "\n" => table( sanitize => 1, rows => [ [$field, 'col2' ], ['row2 col1', 'row2 col2'] ] ); Prints: +-----------------+-----------+ | foo\n | col2 | | bar\n | | | baz\n | | | | | | row2 col1 | row2 col2 | +-----------------+-----------+ So it marks the newlines by inserting the escape sequence, but it also shows the data across as many lines as it would normally display. =item mark_tail => $bool This will replace the last whitespace character of any trailing whitespace with its escape sequence. This makes it easier to notice trailing whitespace when comparing values. =back =head2 my $cols = term_size() Attempts to find the width in columns (characters) of the current terminal. Returns 80 as a safe bet if it cannot find it another way. =head1 NOTE ON UNICODE/WIDE CHARACTERS Some unicode characters, such as C<婧> (C) are wider than others. These will render just fine if you C as necessary, and L is installed, however if the module is not installed there will be anomalies in the table: +-----+-----+---+ | a | b | c | +-----+-----+---+ | 婧 | x | y | | x | y | z | | x | 婧 | z | +-----+-----+---+ =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Util/Times.pm0000644000175000017500000000613513615053353020071 0ustar exodistexodistpackage Test2::Util::Times; use strict; use warnings; use List::Util qw/sum/; our $VERSION = '0.000129'; our @EXPORT_OK = qw/render_bench render_duration/; use base 'Exporter'; sub render_duration { my $time; if (@_ == 1) { ($time) = @_; } else { my ($start, $end) = @_; $time = $end - $start; } return sprintf('%1.5fs', $time) if $time < 10; return sprintf('%2.4fs', $time) if $time < 60; my $msec = substr(sprintf('%0.2f', $time - int($time)), -2, 2); my $secs = $time % 60; my $mins = int($time / 60) % 60; my $hours = int($time / 60 / 60) % 24; my $days = int($time / 60 / 60 / 24); my @units = (qw/d h m/, ''); my $duration = ''; for my $t ($days, $hours, $mins, $secs) { my $u = shift @units; next unless $t || $duration; $duration = join ':' => grep { length($_) } $duration, sprintf('%02u%s', $t, $u); } $duration ||= '0'; $duration .= ".$msec" if int($msec); $duration .= 's'; return $duration; } sub render_bench { my ($start, $end, $user, $system, $cuser, $csystem) = @_; my $duration = render_duration($start, $end); my $bench = sprintf( "%s on wallclock (%5.2f usr %5.2f sys + %5.2f cusr %5.2f csys = %5.2f CPU)", $duration, $user, $system, $cuser, $csystem, sum($user, $system, $cuser, $csystem), ); $bench =~ s/\s+/ /g; $bench =~ s/(\(|\))\s+/$1/g; return $bench; } 1; =pod =encoding UTF-8 =head1 NAME Test2::Util::Times - Format timing/benchmark information. =head1 DESCRIPTION This modules exports tools for rendering timing data at the end of tests. =head1 EXPORTS All exports are optional. You must specify subs to import. =over 4 =item $str = render_bench($start, $end, $user, $system, $cuser, $csystem) =item $str = render_bench($start, time(), times()) This will produce a string like one of these (Note these numbers are completely made up). I 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) The first 2 arguments are the C<$start> and C<$end> times in seconds (as returned by C or C). The last 4 arguments are timing information as returned by the C function. =back =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Util/Stash.pm0000644000175000017500000001322013615053353020063 0ustar exodistexodistpackage Test2::Util::Stash; use strict; use warnings; our $VERSION = '0.000129'; use Carp qw/croak/; use B; our @EXPORT_OK = qw{ get_stash get_glob get_symbol parse_symbol purge_symbol slot_to_sig sig_to_slot }; use base 'Exporter'; my %SIGMAP = ( '&' => 'CODE', '$' => 'SCALAR', '%' => 'HASH', '@' => 'ARRAY', ); my %SLOTMAP = reverse %SIGMAP; sub slot_to_sig { $SLOTMAP{$_[0]} || croak "unsupported slot: '$_[0]'" } sub sig_to_slot { $SIGMAP{$_[0]} || croak "unsupported sigil: $_[0]" } sub get_stash { my $package = shift || caller; no strict 'refs'; return \%{"${package}\::"}; } sub get_glob { my $sym = _parse_symbol(scalar(caller), @_); no strict 'refs'; no warnings 'once'; return \*{"$sym->{package}\::$sym->{name}"}; } sub parse_symbol { _parse_symbol(scalar(caller), @_) } sub _parse_symbol { my ($caller, $symbol, $package) = @_; if (ref($symbol)) { my $pkg = $symbol->{package}; croak "Symbol package ($pkg) and package argument ($package) do not match" if $pkg && $package && $pkg ne $package; $symbol->{package} ||= $caller; return $symbol; } utf8::downgrade($symbol) if $] == 5.010000; # prevent crash on 5.10.0 my ($sig, $pkg, $name) = ($symbol =~ m/^(\W?)(.*::)?([^:]+)$/) or croak "Invalid symbol: '$symbol'"; # Normalize package, '::' becomes 'main', 'Foo::' becomes 'Foo' $pkg = $pkg ? $pkg eq '::' ? 'main' : substr($pkg, 0, -2) : undef; croak "Symbol package ($pkg) and package argument ($package) do not match" if $pkg && $package && $pkg ne $package; $sig ||= '&'; my $type = $SIGMAP{$sig} || croak "unsupported sigil: '$sig'"; my $real_package = $package || $pkg || $caller; return { name => $name, sigil => $sig, type => $type, symbol => "${sig}${real_package}::${name}", package => $real_package, }; } sub get_symbol { my $sym = _parse_symbol(scalar(caller), @_); my $name = $sym->{name}; my $type = $sym->{type}; my $package = $sym->{package}; my $symbol = $sym->{symbol}; my $stash = get_stash($package); return undef unless exists $stash->{$name}; my $glob = get_glob($sym); return *{$glob}{$type} if $type ne 'SCALAR' && defined(*{$glob}{$type}); if ($] < 5.010) { return undef unless defined(*{$glob}{$type}); { local ($@, $!); local $SIG{__WARN__} = sub { 1 }; return *{$glob}{$type} if eval "package $package; my \$y = $symbol; 1"; } return undef unless defined *{$glob}{$type}; return *{$glob}{$type} if defined ${*{$glob}{$type}}; return undef; } my $sv = B::svref_2object($glob)->SV; return *{$glob}{$type} if $sv->isa('B::SV'); return undef unless $sv->isa('B::SPECIAL'); return *{$glob}{$type} if $B::specialsv_name[$$sv] ne 'Nullsv'; return undef; } sub purge_symbol { my $sym = _parse_symbol(scalar(caller), @_); local *GLOBCLONE = *{get_glob($sym)}; delete get_stash($sym->{package})->{$sym->{name}}; my $new_glob = get_glob($sym); for my $type (qw/CODE SCALAR HASH ARRAY FORMAT IO/) { next if $type eq $sym->{type}; my $ref = get_symbol({type => $type, name => 'GLOBCLONE', sigil => $SLOTMAP{$type}}, __PACKAGE__); next unless $ref; *$new_glob = $ref; } return *GLOBCLONE{$sym->{type}}; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::Stash - Utilities for manipulating stashes and globs. =head1 DESCRIPTION This is a collection of utilities for manipulating and inspecting package stashes and globs. =head1 EXPORTS =over 4 =item $stash = get_stash($package) Gets the package stash. This is the same as C<$stash = \%Package::Name::>. =item $sym_spec = parse_symbol($symbol) =item $sym_spec = parse_symbol($symbol, $package) Parse a symbol name, and return a hashref with info about the symbol. C<$symbol> can be a simple name, or a fully qualified symbol name. The sigil is optional, and C<&> is assumed if none is provided. If C<$symbol> is fully qualified, and C<$package> is also provided, then the package of the symbol must match the C<$package>. Returns a structure like this: return { name => 'BAZ', sigil => '$', type => 'SCALAR', symbol => '&Foo::Bar::BAZ', package => 'Foo::Bar', }; =item $glob_ref = get_glob($symbol) =item $glob_ref = get_glob($symbol, $package) Get a glob ref. Arguments are the same as for C. =item $ref = get_symbol($symbol) =item $ref = get_symbol($symbol, $package) Get a reference to the symbol. Arguments are the same as for C. =item $ref = purge_symbol($symbol) =item $ref = purge_symbol($symbol, $package) Completely remove the symbol from the package symbol table. Arguments are the same as for C. A reference to the removed symbol is returned. =item $sig = slot_to_sig($slot) Convert a slot (like 'SCALAR') to a sigil (like '$'). =item $slot = sig_to_slot($sig) Convert a sigil (like '$') to a slot (like 'SCALAR'). =back =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Util/Term.pm0000644000175000017500000000040713615053353017713 0ustar exodistexodistpackage Test2::Util::Term; use strict; use warnings; use Term::Table::Util qw/term_size USE_GCS USE_TERM_READKEY uni_length/; our $VERSION = '0.000129'; use Importer Importer => 'import'; our @EXPORT_OK = qw/term_size USE_GCS USE_TERM_READKEY uni_length/; 1; Test2-Suite-0.000129/lib/Test2/Util/Sub.pm0000644000175000017500000000711513615053353017540 0ustar exodistexodistpackage Test2::Util::Sub; use strict; use warnings; our $VERSION = '0.000129'; use Carp qw/croak carp/; use B(); use Sub::Info; our @EXPORT_OK = qw{ sub_info sub_name gen_reader gen_writer gen_accessor }; use base 'Exporter'; sub gen_reader { my $field = shift; return sub { $_[0]->{$field} }; } sub gen_writer { my $field = shift; return sub { $_[0]->{$field} = $_[1] }; } sub gen_accessor { my $field = shift; return sub { my $self = shift; ($self->{$field}) = @_ if @_; return $self->{$field}; }; } sub sub_name { my ($sub) = @_; croak "sub_name requires a coderef as its only argument" unless ref($sub) eq 'CODE'; my $cobj = B::svref_2object($sub); my $name = $cobj->GV->NAME; return $name; } sub sub_info { carp "Test2::Util::Sub::sub_info() is deprecated, use Sub::Info::sub_info() instead"; Sub::Info::sub_info(@_); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::Sub - Tools for inspecting and manipulating subs. =head1 DESCRIPTION Utilities used by Test2::Tools to inspect and manipulate subroutines. =head1 EXPORTS All exports are optional, you must specify subs to import. =over 4 =item $name = sub_name(\&sub) Get the name of the sub. =item my $hr = sub_info(\&code) This returns a hashref with information about the sub: { ref => \&code, cobj => $cobj, name => "Some::Mod::code", file => "Some/Mod.pm", package => "Some::Mod", # Note: These have been adjusted based on guesswork. start_line => 22, end_line => 42, lines => [22, 42], # Not a bug, these lines are different! all_lines => [23, 25, ..., 39, 41], }; =over 4 =item $info->{ref} => \&code This is the original sub passed to C. =item $info->{cobj} => $cobj This is the c-object representation of the coderef. =item $info->{name} => "Some::Mod::code" This is the name of the coderef. For anonymous coderefs this may end with C<'__ANON__'>. Also note that the package 'main' is special, and 'main::' may be omitted. =item $info->{file} => "Some/Mod.pm" The file in which the sub was defined. =item $info->{package} => "Some::Mod" The package in which the sub was defined. =item $info->{start_line} => 22 =item $info->{end_line} => 42 =item $info->{lines} => [22, 42] These three fields are the I start line, end line, and array with both. It is important to note that these lines have been adjusted and may not be accurate. The lines are obtained by walking the ops. As such, the first line is the line of the first statement, and the last line is the line of the last statement. This means that in multi-line subs the lines are usually off by 1. The lines in these keys will be adjusted for you if it detects a multi-line sub. =item $info->{all_lines} => [23, 25, ..., 39, 41] This is an array with the lines of every statement in the sub. Unlike the other line fields, these have not been adjusted for you. =back =back =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =item Kent Fredric Ekentnl@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Util/Ref.pm0000644000175000017500000000427113615053353017523 0ustar exodistexodistpackage Test2::Util::Ref; use strict; use warnings; our $VERSION = '0.000129'; use Scalar::Util qw/reftype blessed refaddr/; our @EXPORT_OK = qw/rtype render_ref/; use base 'Exporter'; sub rtype { my ($thing) = @_; return '' unless defined $thing; my $rf = ref $thing; my $rt = reftype $thing; return '' unless $rf || $rt; return 'REGEXP' if $rf =~ m/Regex/i; return 'REGEXP' if $rt =~ m/Regex/i; return $rt || ''; } sub render_ref { my ($in) = @_; return 'undef' unless defined($in); my $type = rtype($in); return "$in" unless $type; # Look past overloading my $class = blessed($in) || ''; my $it = sprintf('0x%x', refaddr($in)); my $ref = "$type($it)"; return $ref unless $class; return "$class=$ref"; } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Util::Ref - Tools for inspecting or manipulating references. =head1 DESCRIPTION These are used by L to inspect, render, or manipulate references. =head1 EXPORTS All exports are optional. You must specify subs to import. =over 4 =item $type = rtype($ref) A normalization between C and C. Always returns a string. Returns C<'REGEXP'> for regex types Returns C<''> for non-refs Otherwise returns what C returns. =item $addr_str = render_ref($ref) Always returns a string. For unblessed references this returns something like C<"SCALAR(0x...)">. For blessed references it returns C<"My::Thing=SCALAR(0x...)">. The only difference between this and C<$add_str = "$thing"> is that it ignores any overloading to ensure it is always the ref address. =back =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =item Kent Fredric Ekentnl@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Workflow.pm0000644000175000017500000001620013615053353017677 0ustar exodistexodistpackage Test2::Workflow; use strict; use warnings; our $VERSION = '0.000129'; our @EXPORT_OK = qw/parse_args current_build build root_build init_root build_stack/; use base 'Exporter'; use Test2::Workflow::Build; use Test2::Workflow::Task::Group; use Test2::API qw/intercept/; use Scalar::Util qw/blessed/; sub parse_args { my %input = @_; my $args = delete $input{args}; my %out; my %props; my $caller = $out{frame} = $input{caller} || caller(defined $input{level} ? $input{level} : 1); delete @input{qw/caller level/}; for my $arg (@$args) { if (my $r = ref($arg)) { if ($r eq 'HASH') { %props = (%props, %$arg); } elsif ($r eq 'CODE') { die "Code is already set, did you provide multiple code blocks at $caller->[1] line $caller->[2].\n" if $out{code}; $out{code} = $arg } else { die "Not sure what to do with $arg at $caller->[1] line $caller->[2].\n"; } next; } if ($arg =~ m/^\d+$/) { push @{$out{lines}} => $arg; next; } die "Name is already set to '$out{name}', cannot set to '$arg', did you specify multiple names at $caller->[1] line $caller->[2].\n" if $out{name}; $out{name} = $arg; } die "a name must be provided, and must be truthy at $caller->[1] line $caller->[2].\n" unless $out{name}; die "a codeblock must be provided at $caller->[1] line $caller->[2].\n" unless $out{code}; return { %props, %out, %input }; } { my %ROOT_BUILDS; my @BUILD_STACK; sub root_build { $ROOT_BUILDS{$_[0]} } sub current_build { @BUILD_STACK ? $BUILD_STACK[-1] : undef } sub build_stack { @BUILD_STACK } sub init_root { my ($pkg, %args) = @_; $ROOT_BUILDS{$pkg} ||= Test2::Workflow::Build->new( name => $pkg, flat => 1, iso => 0, async => 0, is_root => 1, %args, ); return $ROOT_BUILDS{$pkg}; } sub build { my %params = @_; my $args = parse_args(%params); my $build = Test2::Workflow::Build->new(%$args); return $build if $args->{skip}; push @BUILD_STACK => $build; my ($ok, $err); my $events = intercept { my $todo = $args->{todo} ? Test2::Todo->new(reason => $args->{todo}) : undef; $ok = eval { $args->{code}->(); 1 }; $err = $@; $todo->end if $todo; }; # Clear the stash $build->{stash} = []; $build->set_events($events); pop @BUILD_STACK; unless($ok) { my $hub = Test2::API::test2_stack->top; my $count = @$events; my $list = $count ? "Overview of unseen events:\n" . join "" => map " " . blessed($_) . " " . $_->trace($hub)->debug . "\n", @$events : ""; die <<" EOT"; Exception in build '$args->{name}' with $count unseen event(s). $err $list EOT } return $build; } } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::Workflow - A test workflow is a way of structuring tests using composable units. =head1 DESCRIPTION A test workflow is a way of structuring tests using composable units. A well known example of a test workflow is L. RSPEC is implemented using Test2::Workflow in L along with several extensions. =head1 IMPORTANT CONCEPTS =head2 BUILD L A Build is used to compose tasks. Usually a build object is pushed to the stack before running code that adds tasks to the build. Once the build sub is complete the build is popped and returned. Usually a build is converted into a root task or task group. =head2 RUNNER L A runner takes the composed tasks and executes them in the proper order. =head2 TASK L A task is a unit of work to accomplish. There are 2 main types of task. =head3 ACTION An action is the most simple unit used in composition. An action is essentially a name and a codeblock to run. =head3 GROUP A group is a task that is composed of other tasks. =head1 EXPORTS All exports are optional, you must request the ones you want. =over 4 =item $parsed = parse_args(args => \@args) =item $parsed = parse_args(args => \@args, level => $L) =item $parsed = parse_args(args => \@args, caller => [caller($L)]) This will parse a "typical" task builders arguments. The C<@args> array MUST contain a name (plain scalar containing text) and also a single CODE reference. The C<@args> array MAY also contain any quantity of line numbers or hashrefs. The resulting data structure will be a single hashref with all the provided hashrefs squashed together, and the 'name', 'code', 'lines' and 'frame' keys set from other arguments. { # All hashrefs from @args get squashed together: %squashed_input_hashref_data, # @args must have exactly 1 plaintext scalar that is not a number, it # is considered the name: name => 'name from input args' # Integer values are treated as line numbers lines => [ 35, 44 ], # Exactly 1 coderef must be provided in @args: code => \&some_code, # 'frame' contains the 'caller' data. This may be passed in directly, # obtained from the 'level' parameter, or automatically deduced. frame => ['A::Package', 'a_file.pm', 42, ...], } =item $build = init_root($pkg, %args) This will initialize (or return the existing) a build for the specified package. C<%args> get passed into the L constructor. This uses the following defaults (which can be overridden using C<%args>): name => $pkg, flat => 1, iso => 0, async => 0, is_root => 1, Note that C<%args> is completely ignored if the package build has already been initialized. =item $build = root_build($pkg) This will return the root build for the specified package. =item $build = current_build() This will return the build currently at the top of the build stack (or undef). =item $build = build($name, \%params, sub { ... }) This will push a new build object onto the build stash then run the provided codeblock. Once the codeblock has finished running the build will be popped off the stack and returned. See C for details about argument processing. =back =head1 SEE ALSO =over 4 =item Test2::Tools::Spec L is an implementation of RSPEC using this library. =back =head1 SOURCE The source code repository for Test2-Workflow can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist7@gmail.comE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Require.pm0000644000175000017500000000523313615053353017505 0ustar exodistexodistpackage Test2::Require; use strict; use warnings; our $VERSION = '0.000129'; 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 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 simply needs to implement a C 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 then you should write an C 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Compare.pm0000644000175000017500000002704013615053353017457 0ustar exodistexodistpackage Test2::Compare; use strict; use warnings; our $VERSION = '0.000129'; 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 and C. =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 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 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 and C 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 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 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 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 subclass into one. This tool will use the C<\&convert> function on the specification, and then produce an L 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 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 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 function provided by this package contains all the specification behavior of C and C. 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 subclass. =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Bundle.pm0000644000175000017500000000302113615053353017273 0ustar exodistexodistpackage Test2::Bundle; use strict; use warnings; our $VERSION = '0.000129'; 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 and L. =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Plugin.pm0000644000175000017500000000351713615053353017332 0ustar exodistexodistpackage Test2::Plugin; use strict; use warnings; our $VERSION = '0.000129'; 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, or writing L. Plugins alter behavior, or cause desirable side-effects. To accomplish this you typically need a custom C method that calls one or more functions provided by the L package. If you want to write a plugin you should look at existing plugins, as well as the L and L 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Manual.pm0000644000175000017500000000276413615053353017314 0ustar exodistexodistpackage Test2::Manual; use strict; use warnings; our $VERSION = '0.000129'; 1; __END__ =head1 NAME Test2::Manual - Documentation hub for Test2 and Test2-Suite. =head1 DESCRIPTION This is the hub for L and L documentation. =head1 WRITING TESTS The L POD is the hub for documentation related to writing tests. =head1 WRITING TOOLS The L POD is the hub for documentation related to writing new tools. =head1 GUTS AND INNER WORKINGS The L 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 POD documents the concurrency support policy for L. =head1 CONTRIBUTING The L POD is for people who want to contribute to L or L directly. =head1 SEE ALSO L - Test2 itself. L - Initial tools built using L. =head1 SOURCE The source code repository for Test2-Manual can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Tools.pm0000644000175000017500000000501013615053353017162 0ustar exodistexodistpackage Test2::Tools; use strict; use warnings; our $VERSION = '0.000129'; 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 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. =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 for documentation on what the C<$ctx> object can do. =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Suite.pm0000644000175000017500000002240613615053353017163 0ustar exodistexodistpackage Test2::Suite; use strict; use warnings; our $VERSION = '0.000129'; 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 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 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 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. 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 section below, except for L. This bundle provides most of what anyone writing tests could need. This is also the preferred bundle/toolset of the L author. See L for complete documentation. =item Extended B<** Deprecated **> See L 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 section below, except for L. This bundle provides most of what anyone writing tests could need. This is also the preferred bundle/toolset of the L author. See L 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 drop-in replacement for L. There are some notable differences to be aware of however. Some exports are missing: C, C, C, C<$TODO>, C, C, C. 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 function. Planning is done using C, C, or C. See L for complete documentation. =item Simple use Test2::Bundle::Simple; use strict; use warnings; plan 1; ok(...); This bundle is meant to be a I drop-in replacement for L. See L for complete documentation. =back =head1 INCLUDED TOOLS =over 4 =item Basic Basic provides most of the essential tools previously found in L. However it does not export any tools used for comparison. The basic C, C, C functions are present, as are functions for planning. See L for complete documentation. =item Compare This provides C, C, C, C, and several additional helpers. B These are all I comparison tools and work like a combination of L's C and C. See L for complete documentation. =item ClassicCompare This provides L flavored C, C, C, C, and C. It also provides C. See L for complete documentation. =item Class This provides functions for testing objects and classes, things like C. See L 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 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 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 for complete documentation. =item Mock This provides tools for mocking objects and classes. This is based largely on L, but several interface improvements have been added that cannot be added to Mock::Quick itself without breaking backwards compatibility. See L for complete documentation. =item Ref This exports tools for validating and comparing references. See L for complete documentation. =item Spec This is an RSPEC implementation with concurrency support. See L for more details. =item Subtest This exports tools for running subtests. See L 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 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 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 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 for complete documentation. =item SRand Use this to set the random seed to a specific seed, or to the current date. See L 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 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 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 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 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 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 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 for complete documentation. =item Threads Using this package will cause the test file to be skipped unless the system has threading enabled. B This will not turn threading on for you. See L for complete documentation. =back =head1 SEE ALSO See the L documentation for a namespace map. Everything in this distribution uses L. L is the Test2 Manual. =head1 CONTACTING US Many Test2 developers and users lurk on L. We also have a slack team that can be joined by anyone with an C<@cpan.org> email address L If you do not have an C<@cpan.org> email you can ask for a slack invite by emailing Chad Granum Eexodist@cpan.orgE. =head1 SOURCE The source code repository for Test2-Suite can be found at F. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Todo.pm0000644000175000017500000000742313615053353017001 0ustar exodistexodistpackage 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.000129'; 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 function provided by L. =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. This filter will set the C and C attributes on all events as they come in. When the instance is destroyed, or C 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, it will not set C 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/lib/Test2/Mock.pm0000644000175000017500000005327313615053353016771 0ustar exodistexodistpackage Test2::Mock; use strict; use warnings; our $VERSION = '0.000129'; 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 <{\$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 <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 that manages mocking for the specified C<$CLASS>. Any C 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 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 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 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 and C are the primary ways to add/modify methods for a class. Both accept the exact same type of arguments. The difference is that C will fail unless the symbol you are overriding already exists, C on the other hand will fail if the symbol does already exist. C 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 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 as a pop operation to go back to the previous mock. C 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 as a push operation, and C 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 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 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 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 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 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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See L =cut Test2-Suite-0.000129/lib/Test2/V0.pm0000644000175000017500000002523013615053353016355 0ustar exodistexodistpackage Test2::V0; use strict; use warnings; use Importer; our $VERSION = '0.000129'; use Carp qw/croak/; use Test2::Plugin::SRand(); use Test2::Plugin::UTF8(); use Test2::Tools::Target(); use Test2::Plugin::ExitSummary; use Test2::API qw/intercept context/; use Test2::Tools::Event qw/gen_event/; use Test2::Tools::Defer qw/def do_def/; use Test2::Tools::Basic qw{ ok pass fail diag note todo skip plan skip_all done_testing bail_out }; use Test2::Tools::Compare qw{ is like isnt unlike match mismatch validator hash array bag object meta meta_check number float rounded within string subset bool in_set not_in_set check_set item field call call_list call_hash prop check all_items all_keys all_vals all_values etc end filter_items T F D DF E DNE FDNE U event fail_events exact_ref }; use Test2::Tools::Warnings qw{ warns warning warnings no_warnings }; use Test2::Tools::ClassicCompare qw/cmp_ok/; use Importer 'Test2::Tools::Subtest' => ( subtest_buffered => { -as => 'subtest' }, ); use Test2::Tools::Class qw/can_ok isa_ok DOES_ok/; use Test2::Tools::Encoding qw/set_encoding/; use Test2::Tools::Exports qw/imported_ok not_imported_ok/; use Test2::Tools::Ref qw/ref_ok ref_is ref_is_not/; use Test2::Tools::Mock qw/mock mocked/; use Test2::Tools::Exception qw/try_ok dies lives/; our @EXPORT = qw{ ok pass fail diag note todo skip plan skip_all done_testing bail_out intercept context gen_event def do_def cmp_ok warns warning warnings no_warnings subtest can_ok isa_ok DOES_ok set_encoding imported_ok not_imported_ok ref_ok ref_is ref_is_not mock mocked dies lives try_ok is like isnt unlike match mismatch validator hash array bag object meta meta_check number float rounded within string subset bool in_set not_in_set check_set item field call call_list call_hash prop check all_items all_keys all_vals all_values etc end filter_items T F D DF E DNE FDNE U event fail_events exact_ref }; my $SRAND; sub import { my $class = shift; my $caller = caller; my (@exports, %options); while (my $arg = shift @_) { push @exports => $arg and next unless substr($arg, 0, 1) eq '-'; $options{$arg} = shift @_; } # SRand handling my $srand = delete $options{'-srand'}; my $no_srand = exists $options{'-no_srand'}; delete $options{'-no_srand'} if $no_srand; croak "Cannot combine '-srand' and '-no_srand' options" if $no_srand && defined($srand); if ( !$no_srand ) { Test2::Plugin::SRand->import($srand ? $srand : ()) if defined($srand) || !$SRAND++; } # Pragmas my $no_pragmas = delete $options{'-no_pragmas'}; my $no_strict = delete $options{'-no_strict'} || $no_pragmas; my $no_warnings = delete $options{'-no_warnings'} || $no_pragmas; my $no_utf8 = delete $options{'-no_utf8'} || $no_pragmas; strict->import() unless $no_strict; 'warnings'->import() unless $no_warnings; Test2::Plugin::UTF8->import() unless $no_utf8; my $target = delete $options{'-target'}; Test2::Tools::Target->import_into($caller, $target) if $target; croak "Unknown option(s): " . join(', ', sort keys %options) if keys %options; Importer->import_into($class, $caller, @exports); } 1; __END__ =pod =encoding UTF-8 =head1 NAME Test2::V0 - 0Th edition of the Test2 recommended bundle. =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 itself. =head1 NAMING, USING, DEPENDING This bundle should not change in a I incompatible way. Some minor breaking changes, specially bugfixes, may be allowed. If breaking changes are needed then a new C module should be released instead. As new C modules are released old ones I be moved to different cpan distributions. You should always use a specific bundle version and list that version in your distributions testing requirements. You should never simply list L as your modules dep, instead list the specific bundle, or tools and plugins you use directly in your metadata. =head1 SYNOPSIS use Test2::V0; ok(1, "pass"); ... done_testing; =head1 RESOLVING CONFLICTS WITH MOOSE use Test2::V0 '!meta'; L and L both export very different C 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 so you can use that spelling as an alternative. =head2 TAGS =over 4 =item :DEFAULT The following are both identical: use Test2::V0; use Test2::V0 ':DEFAULT'; =back =head2 RENAMING ON IMPORT use Test2::V0 ':DEFAULT', '!ok', ok => {-as => 'my_ok'}; This bundle uses L for exporting, as such you can use any arguments it accepts. Explanation: =over 4 =item '!ok' Do not export C =item ok => {-as => 'my_ok'} Actually, go ahead and import C but under the name C. =back If you did not add the C<'!ok'> argument then you would have both C and C =head1 PRAGMAS All of these can be disabled via individual import arguments, or by the C<-no_pragmas> argument. use Test2::V0 -no_pragmas => 1; =head2 STRICT L is turned on for you. You can disable this with the C<-no_strict> or C<-no_pragmas> import arguments: use Test2::V0 -no_strict => 1; =head2 WARNINGS L are turned on for you. You can disable this with the C<-no_warnings> or C<-no_pragmas> import arguments: use Test2::V0 -no_warnings => 1; =head2 UTF8 This is actually done via the L plugin, see the L section for details. B C<< -no_pragmas => 1 >> will turn off the entire plugin. =head1 PLUGINS =head2 SRAND See L. This will set the random seed to today's date. You can provide an alternate seed with the C<-srand> import option: use Test2::V0 -srand => 1234; =head2 UTF8 See L. 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::V0 -no_utf8 => 1; =head2 EXIT SUMMARY See L. This plugin has no configuration. =head1 API FUNCTIONS See L for these =over 4 =item $ctx = context() =item $events = intercept { ... } =back =head1 TOOLS =head2 TARGET See L. You can specify a target class with the C<-target> import argument. If you do not provide a target then C<$CLASS> and C will not be imported. use Test2::V0 -target => 'My::Class'; print $CLASS; # My::Class print CLASS(); # My::Class Or you can specify names: use Test2::V0 -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. =over 4 =item def $func => @args; =item do_def() =back =head2 BASIC See L. =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. =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 = 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. =over 4 =item cmp_ok($got, $op, $want, $name) =back =head2 SUBTEST See L. =over 4 =item subtest $name => sub { ... }; (Note: This is called C in the Tools module.) =back =head2 CLASS See L. =over 4 =item can_ok($thing, @methods) =item isa_ok($thing, @classes) =item DOES_ok($thing, @roles) =back =head2 ENCODING See L. =over 4 =item set_encoding($encoding) =back =head2 EXPORTS See L. =over 4 =item imported_ok('function', '$scalar', ...) =item not_imported_ok('function', '$scalar', ...) =back =head2 REF See L. =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. =over 4 =item $control = mock ... =item $bool = mocked($thing) =back =head2 EXCEPTION See L. =over 4 =item $exception = dies { ... } =item $bool = lives { ... } =item $bool = try_ok { ... } =back =head2 WARNINGS See L. =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. =head1 MAINTAINERS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 AUTHORS =over 4 =item Chad Granum Eexodist@cpan.orgE =back =head1 COPYRIGHT Copyright 2018 Chad Granum Eexodist@cpan.orgE. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See F =cut Test2-Suite-0.000129/t/0000755000175000017500000000000013615053353014224 5ustar exodistexodistTest2-Suite-0.000129/t/regression/0000755000175000017500000000000013615053353016404 5ustar exodistexodistTest2-Suite-0.000129/t/regression/27-3-Test2-Tools-ClassicCompare.t0000644000175000017500000000031113615053353024137 0ustar exodistexodistuse Test2::Tools::ClassicCompare; use strict; use warnings; is_deeply({a => [1]}, {a => [1]}, "is_deeply() works, stuff is loaded"); require Test2::Tools::Basic; Test2::Tools::Basic::done_testing(); Test2-Suite-0.000129/t/regression/async_subtest_missing_parent.t0000644000175000017500000000073213615053353024563 0ustar exodistexodistuse Test2::V0; use Test2::Tools::AsyncSubtest; my $err; my $events = intercept { my $ast; subtest outer => sub { plan 2; ok(1); $ast = async_subtest 'foo'; $ast->run(sub { ok(1, 'pass') }); }; $err = dies { $ast->finish }; }; like( $err, qr/Attempt to close AsyncSubtest when original parent hub \(a non async-subtest\?\) has ended/, "Throw an error when a subtest finishes without a parent" ); done_testing; Test2-Suite-0.000129/t/regression/27-2-Test2-Tools-Compare.t0000644000175000017500000000026413615053353022643 0ustar exodistexodistuse Test2::Tools::Compare; use strict; use warnings; is({a => [1]}, {a => [1]}, "is() works, stuff is loaded"); require Test2::Tools::Basic; Test2::Tools::Basic::done_testing(); Test2-Suite-0.000129/t/regression/27-1-Test2-Bundle-More.t0000644000175000017500000000021413615053353022262 0ustar exodistexodistuse Test2::Bundle::More; use strict; use warnings; is_deeply({a => [1]}, {a => [1]}, "is_deeply() works, stuff is loaded"); done_testing; Test2-Suite-0.000129/t/regression/Test2-Tools-Class.t0000644000175000017500000000071213615053353021733 0ustar exodistexodistuse Test2::Tools::Class; use strict; use warnings; { package My::Object; use overload 'bool' => sub {$_[0]->{value}} } my $true_value = bless {value => 1}, 'My::Object'; my $false_value = bless {value => 0}, 'My::Object'; isa_ok($true_value, ['My::Object'], 'isa_ok when object overloads to true'); isa_ok($false_value, ['My::Object'], 'isa_ok when object overloads to false'); require Test2::Tools::Basic; Test2::Tools::Basic::done_testing(); Test2-Suite-0.000129/t/regression/todo_and_facets.t0000644000175000017500000000176713615053353021720 0ustar exodistexodistuse strict; use warnings; use Test2::API qw/context/; use Test::More(); use Test2::Tools::Basic qw/todo done_testing/; BEGIN { *tm_ok = \&Test::More::ok; *tm_pass = \&Test::More::pass; *tm_fail = \&Test::More::fail; *bas_ok = \&Test2::Tools::Basic::ok; } use vars qw/$TODO/; sub leg_ok($;$@) { my ($bool, $name, @diag); my $ctx = context(); $ctx->ok($bool, $name, \@diag); $ctx->release; return $bool; } sub new_ok($;$@) { my ($bool, $name, @diag) = @_; my $ctx = context(); return $ctx->pass_and_release($name) if $bool; return $ctx->fail_and_release($name, @diag); } { local $TODO = "Testing TODO"; tm_ok(0, "tm_ok fail"); tm_fail('tm_fail'); leg_ok(0, "legacy ok fail"); new_ok(0, "new ok fail"); bas_ok(0, "basic ok fail"); } todo new_todo_test => sub { tm_ok(0, "tm_ok fail"); tm_fail('tm_fail'); leg_ok(0, "legacy ok fail"); new_ok(0, "new ok fail"); bas_ok(0, "basic ok fail"); }; done_testing; Test2-Suite-0.000129/t/regression/43-bag-on-empty.t0000644000175000017500000000056513615053353021322 0ustar exodistexodistuse Test2::Bundle::Extended; my $got = intercept { my $check = bag { item 'a'; item 'b'; end(); # Ensure no other elements exist. }; is([], $check, 'All of the elements from bag found!'); # passes but shouldn't }; like( $got, array { event Fail => sub {}; }, "Bag check on empty array" ); done_testing; Test2-Suite-0.000129/t/regression/10-set_and_dne.t0000644000175000017500000000100013615053353021241 0ustar exodistexodistuse Test2::Bundle::Extended; my $check = hash { field first => 42; field second => undef; field third => DNE(); field fourth => in_set(42, undef); field fifth => in_set(42, undef); field sixth => in_set(42, DNE()); field seventh => in_set(42, DNE()); field eighth => not_in_set(DNE()); }; is( { first => 42, second => undef, # third DNE fourth => 42, fifth => undef, sixth => 42, # seventh DNE eighth => 42, }, $check ); done_testing; Test2-Suite-0.000129/t/regression/Test2-Mock.t0000644000175000017500000000141113615053353020456 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Mock; my $mock; ok( lives { $mock = Test2::Mock->new( class => 'Fake', add => [ foo => 'string', bar => undef, ], ); }, 'Did not die when adding plain value' ); isa_ok( $mock, 'Test2::Mock' ); is( Fake::foo(), 'string', 'Correct value returned for add when plain string given' ); is( Fake::bar(), undef, 'Correct value returned for add when undef given' ); $mock->override(foo => undef, bar => 'string'); is( Fake::foo(), undef, 'Correct value returned for override when undef given' ); is( Fake::bar(), 'string', 'Correct value returned for override when plain string given' ); done_testing; Test2-Suite-0.000129/t/regression/utf8-mock.t0000644000175000017500000000056313615053353020412 0ustar exodistexodistuse Test2::Plugin::UTF8; use Test2::Bundle::More; use Test2::Mock; use Test2::Require::Module 'ExtUtils::MakeMaker'; use ExtUtils::MakeMaker; ok 1; my $mock = Test2::Mock->new( class => 'ExtUtils::MakeMaker', ); subtest 'user says yes' => sub { my($msg, $def); $mock->override(prompt => sub ($;$) { ($msg,$def) = @_; return 'y' }); ok 1; }; done_testing; Test2-Suite-0.000129/t/regression/132-bool.t0000644000175000017500000000246713615053353020040 0ustar exodistexodistuse Test2::Require::AuthorTesting; use Test2::Require::Perl 'v5.20'; use Test2::V0; use Test2::Plugin::BailOnFail; opendir(my $dh, 'lib/Test2/Compare/') or die "Could not open compare lib dir: $!"; for my $file (readdir($dh)) { next unless $file =~ m/.pm$/; next if $file eq 'Delta.pm'; require "Test2/Compare/$file"; my $name = $file; $name =~ s/\.pm$//g; my $mod = "Test2::Compare::$name"; my $test = "./t/modules/Compare/$name.t"; next unless -f $test; eval <<" EOT" or die $@; package $mod; require Test2::Tools::Basic; require Carp; use overload bool => sub { Carp::confess( 'illegal use of overloaded bool') } ; use overload '""' => sub { \$_[0] }; my \$err; main::subtest($name => sub { package Test::$mod; local \$@; main::like( main::dies(sub { if(bless({}, "$mod")) { die "oops" }}), qr/illegal use of overloaded bool/, "Override for $mod is in place", ); do "$test"; \$err = \$@; 1; }); eval <<" ETT" or die $@; no overload 'bool'; no overload '""'; 1; ETT die \$err if \$err; 1; EOT } done_testing; Test2-Suite-0.000129/t/lib/0000755000175000017500000000000013615053353014772 5ustar exodistexodistTest2-Suite-0.000129/t/lib/MyTest/0000755000175000017500000000000013615053353016217 5ustar exodistexodistTest2-Suite-0.000129/t/lib/MyTest/Target.pm0000644000175000017500000000024213615053353020001 0ustar exodistexodistpackage MyTest::Target; use Carp qw/confess/; use overload bool => sub { confess( 'illegal use of overloaded bool') } ; use overload '""' => sub { $_[0] }; 1; Test2-Suite-0.000129/t/behavior/0000755000175000017500000000000013615053353016023 5ustar exodistexodistTest2-Suite-0.000129/t/behavior/no_leaks_no_threads.t0000644000175000017500000000131713615053353022213 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Tools::Spec -no_threads => 1; use Test2::Util qw/get_tid/; my $x; tests a => {async => 1, iso => 1}, sub { ok(!$x, "a $$ " . get_tid); $x = "a"}; tests b => {async => 1, iso => 1}, sub { ok(!$x, "b $$ " . get_tid); $x = "b"}; tests c => {async => 1, iso => 1}, sub { ok(!$x, "c $$ " . get_tid); $x = "c"}; tests d => {async => 1, iso => 1}, sub { ok(!$x, "d $$ " . get_tid); $x = "d"}; tests e => {async => 1, iso => 1}, sub { ok(!$x, "e $$ " . get_tid); $x = "e"}; tests f => {async => 1, iso => 1}, sub { ok(!$x, "f $$ " . get_tid); $x = "f"}; tests g => {async => 1, iso => 1}, sub { ok(!$x, "g $$ " . get_tid); $x = "g"}; done_testing; die "Ooops, we leaked |$x|" if $x; Test2-Suite-0.000129/t/behavior/no_leaks_no_fork.t0000644000175000017500000000131413615053353021517 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Tools::Spec -no_fork => 1; use Test2::Util qw/get_tid/; my $x; tests a => {async => 1, iso => 1}, sub { ok(!$x, "a $$ " . get_tid); $x = "a"}; tests b => {async => 1, iso => 1}, sub { ok(!$x, "b $$ " . get_tid); $x = "b"}; tests c => {async => 1, iso => 1}, sub { ok(!$x, "c $$ " . get_tid); $x = "c"}; tests d => {async => 1, iso => 1}, sub { ok(!$x, "d $$ " . get_tid); $x = "d"}; tests e => {async => 1, iso => 1}, sub { ok(!$x, "e $$ " . get_tid); $x = "e"}; tests f => {async => 1, iso => 1}, sub { ok(!$x, "f $$ " . get_tid); $x = "f"}; tests g => {async => 1, iso => 1}, sub { ok(!$x, "g $$ " . get_tid); $x = "g"}; done_testing; die "Ooops, we leaked |$x|" if $x; Test2-Suite-0.000129/t/behavior/no_leaks_no_iso.t0000644000175000017500000000133613615053353021354 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Tools::Spec -no_threads => 1, -no_fork => 1; use Test2::Util qw/get_tid/; my $x; tests a => {async => 1, iso => 1}, sub { ok(!$x, "a $$ " . get_tid); $x = "a"}; tests b => {async => 1, iso => 1}, sub { ok(!$x, "b $$ " . get_tid); $x = "b"}; tests c => {async => 1, iso => 1}, sub { ok(!$x, "c $$ " . get_tid); $x = "c"}; tests d => {async => 1, iso => 1}, sub { ok(!$x, "d $$ " . get_tid); $x = "d"}; tests e => {async => 1, iso => 1}, sub { ok(!$x, "e $$ " . get_tid); $x = "e"}; tests f => {async => 1, iso => 1}, sub { ok(!$x, "f $$ " . get_tid); $x = "f"}; tests g => {async => 1, iso => 1}, sub { ok(!$x, "g $$ " . get_tid); $x = "g"}; done_testing; die "Ooops, we leaked |$x|" if $x; Test2-Suite-0.000129/t/behavior/no_done_testing.t0000644000175000017500000000101313615053353021361 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Tools::Spec; # Get a non-canon context for the root hub. my $ctx = sub { my $ctx = context(); my $out = $ctx->snapshot; $ctx->release; return $out; }->(); tests foo => sub { # This ok is part of the subtest and goes to the subtest hub ok(1, "pass"); # Use the non-canon root hub context to set a plan. We do this here so that # no plan is ever set if the test block does not run. $ctx->plan(1); }; # done_testing intentionally omitted, see #3 Test2-Suite-0.000129/t/behavior/no_leaks_any.t0000644000175000017500000000141313615053353020651 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Tools::Spec; use Test2::Util qw/get_tid/; my $x; tests a => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "a $$ " . get_tid); $x = "a"}; tests b => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "b $$ " . get_tid); $x = "b"}; tests c => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "c $$ " . get_tid); $x = "c"}; tests d => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "d $$ " . get_tid); $x = "d"}; tests e => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "e $$ " . get_tid); $x = "e"}; tests f => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "f $$ " . get_tid); $x = "f"}; tests g => {mini => 1, async => 1, iso => 1}, sub { ok(!$x, "g $$ " . get_tid); $x = "g"}; done_testing; die "Ooops, we leaked |$x|" if $x; Test2-Suite-0.000129/t/behavior/async_trace.t0000644000175000017500000000364513615053353020513 0ustar exodistexodistuse Test2::Tools::Tiny qw/ok done_testing tests/; use Test2::Tools::AsyncSubtest; use Test2::API qw/intercept test2_add_uuid_via/; our %CNT; test2_add_uuid_via(sub { my $type = shift; $CNT{$type} ||= 1; $type . '-' . $CNT{$type}++; }); my $events = intercept { local %CNT = (); tests foo => sub { ok(1, "pass"); }; local %CNT = (); my $ast = async_subtest foo => sub { ok(1, "pass"); }; $ast->finish; }; tests regular => sub { ok($events->[0]->subtest_uuid, "subtest got a subtest uuid"); ok($events->[0]->trace->{cid}, "subtest trace got a cid"); ok($events->[0]->trace->{hid}, "subtest trace got a hid"); ok($events->[0]->trace->{uuid}, "subtest trace got a uuid"); ok($events->[0]->trace->{huuid}, "subtest trace got a huuid"); ok($events->[0]->subevents->[-1]->trace->{cid}, "subtest plan trace got a cid"); ok($events->[0]->subevents->[-1]->trace->{hid}, "subtest plan trace got a hid"); ok($events->[0]->subevents->[-1]->trace->{uuid}, "subtest plan trace got a uuid"); ok($events->[0]->subevents->[-1]->trace->{huuid}, "subtest plan trace got a huuid"); }; tests async => sub { ok($events->[1]->subtest_uuid, "async subtest got a subtest uuid"); ok($events->[1]->trace->{cid}, "async subtest trace got a cid"); ok($events->[1]->trace->{hid}, "async subtest trace got a hid"); ok($events->[1]->trace->{uuid}, "async subtest trace got a uuid"); ok($events->[1]->trace->{huuid}, "async subtest trace got a huuid"); ok($events->[1]->subevents->[-1]->trace->{cid}, "async subtest plan trace got a cid"); ok($events->[1]->subevents->[-1]->trace->{hid}, "async subtest plan trace got a hid"); ok($events->[1]->subevents->[-1]->trace->{uuid}, "async subtest plan trace got a uuid"); ok($events->[1]->subevents->[-1]->trace->{huuid}, "async subtest plan trace got a huuid"); }; done_testing; __END__ Test2-Suite-0.000129/t/behavior/filtering.t0000644000175000017500000006151113615053353020177 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Tools::Spec -rand => 0; use Test2::Workflow::Runner; my %LINES; sub example { my $unit = describe root => {flat => 1}, sub { before_all 'root_before_all' => sub { note "root_before_all" }; after_all 'root_after_all' => sub { note 'root_after_all' }; before_each 'root_before_each' => sub { note 'root_before_each' }; after_each 'root_after_each' => sub { note 'root_after_each' }; around_all 'root_around_all' => sub { note 'root_around_all_prefix'; $_[0]->(); note 'root_around_all_postfix'; }; around_each 'root_around_each' => sub { note 'root_around_each_prefix'; $_[0]->(); note 'root_around_each_postfix'; }; case root_x => sub { note 'root case x' }; BEGIN { $LINES{root_x} = __LINE__ } case root_y => sub { note 'root case y' }; BEGIN { $LINES{root_y} = __LINE__ } tests 'root_a' => sub { ok(1, 'root_a') }; BEGIN { $LINES{root_a} = __LINE__ } tests 'root_b' => sub { ok(1, 'root_b') }; BEGIN { $LINES{root_b} = __LINE__ } tests 'root_long' => sub { ok(1, 'root_long_1'); BEGIN { $LINES{root_long} = __LINE__ } # Intentional space ok(1, 'root_long_2'); }; tests dup_name => sub { ok(1, 'dup_name') }; describe nested => sub { before_all 'nested_before_all' => sub { note "nested_before_all" }; after_all 'nested_after_all' => sub { note 'nested_after_all' }; before_each 'nested_before_each' => sub { note 'nested_before_each' }; after_each 'nested_after_each' => sub { note 'nested_after_each' }; around_all 'nested_around_all' => sub { note 'nested_around_all_prefix'; $_[0]->(); note 'nested_around_all_postfix'; }; around_each 'nested_around_each' => sub { note 'nested_around_each_prefix'; $_[0]->(); note 'nested_around_each_postfix'; }; BEGIN { $LINES{nested} = __LINE__ } case nested_x => sub { note 'nested case x' }; BEGIN { $LINES{nested_x} = __LINE__ } case nested_y => sub { note 'nested case y' }; BEGIN { $LINES{nested_y} = __LINE__ } tests 'nested_a' => sub { ok(1, 'nested_a') }; BEGIN { $LINES{nested_a} = __LINE__ } tests 'nested_b' => sub { ok(1, 'nested_b') }; BEGIN { $LINES{nested_b} = __LINE__ } tests 'nested_long' => sub { ok(1, 'nested_long_1'); BEGIN { $LINES{nested_long} = __LINE__ } # Intentional space ok(1, 'nested_long_2'); }; tests dup_name => sub { ok(1, 'dup_name') }; }; }; return $unit; }; describe root_test => sub { my $filter; my $type; case line => {flat => 1}, sub { $type = 'line'; $filter = {line => $LINES{root_long}} }; case name => {flat => 1}, sub { $type = 'name'; $filter = {name => 'root_long'} }; tests root => {flat => 1}, sub { my $unit = example(); my $events = intercept { Test2::Workflow::Runner->new( rand => 0, task => $unit, filter => $filter )->run(); }; is( $events, array { event Note => { message => 'root_before_all' }; event Note => { message => 'root_around_all_prefix' }; event Subtest => sub { call name => "root_$_"; call subevents => array { event Note => { message => "root case $_" }; event Skip => {}; event Skip => {}; event Subtest => sub { call name => 'root_long'; call subevents => array { event Note => { message => 'root_before_each' }; event Note => { message => 'root_around_each_prefix' }; event Ok => { name => 'root_long_1' }; event Ok => { name => 'root_long_2' }; event Note => { message => 'root_after_each' }; event Note => { message => 'root_around_each_postfix' }; event Plan => { max => 2 }; }; }; event Skip => {}; event Skip => {}; event Plan => { max => 5 }; }; } for qw/x y/; event Note => { message => 'root_after_all' }; event Note => { message => 'root_around_all_postfix' }; }, "Got only the events that match the $type filter" ); }; }; describe nested_test => sub { my $filter; my $type; case line => {flat => 1}, sub { $type = 'line'; $filter = {line => $LINES{nested_long}} }; case name => {flat => 1}, sub { $type = 'name'; $filter = {name => 'nested_long'} }; tests nested => {flat => 1}, sub { my $unit = example(); my $events = intercept { Test2::Workflow::Runner->new( rand => 0, task => $unit, filter => $filter )->run(); }; is( $events, array { event Note => { message => 'root_before_all' }; event Note => { message => 'root_around_all_prefix' }; event Subtest => sub { call name => "root_$_"; call subevents => array { event Note => { message => "root case $_" }; event Skip => {}; event Skip => {}; event Skip => {}; event Skip => {}; event Subtest => sub { call name => 'nested'; call subevents => array { event Note => { message => 'nested_before_all' }; event Note => { message => 'nested_around_all_prefix' }; event Subtest => sub { call name => "nested_$_"; call subevents => array { event Note => { message => "nested case $_" }; event Skip => {}; event Skip => {}; event Subtest => sub { call name => 'nested_long'; call subevents => array { event Note => { message => 'root_before_each' }; event Note => { message => 'root_around_each_prefix' }; event Note => { message => 'nested_before_each' }; event Note => { message => 'nested_around_each_prefix' }; event Ok => { name => 'nested_long_1' }; event Ok => { name => 'nested_long_2' }; event Note => { message => 'nested_after_each' }; event Note => { message => 'nested_around_each_postfix' }; event Note => { message => 'root_after_each' }; event Note => { message => 'root_around_each_postfix' }; event Plan => { max => 2 }; }; }; event Skip => {}; event Plan => { max => 4 }; }; } for qw/x y/; event Note => { message => 'nested_after_all' }; event Note => { message => 'nested_around_all_postfix' }; event Plan => { max => 2 }; }; }; event Plan => { max => 5 }; }; } for qw/x y/; event Note => { message => 'root_after_all' }; event Note => { message => 'root_around_all_postfix' }; }, "Got only the events that match the $type filter" ); }; }; describe group => sub { my $filter; my $type; case line => {flat => 1}, sub { $type = 'line'; $filter = {line => $LINES{nested}} }; case name => {flat => 1}, sub { $type = 'name'; $filter = {name => 'nested'} }; tests nested => {flat => 1}, sub { my $unit = example(); my $events = intercept { Test2::Workflow::Runner->new( rand => 0, task => $unit, filter => $filter )->run(); }; is( $events, array { event Note => { message => 'root_before_all' }; event Note => { message => 'root_around_all_prefix' }; event Subtest => sub { call name => "root_$_"; call subevents => array { event Note => { message => "root case $_" }; event Skip => {}; event Skip => {}; event Skip => {}; event Skip => {}; event Subtest => sub { call name => 'nested'; call subevents => array { event Note => { message => 'nested_before_all' }; event Note => { message => 'nested_around_all_prefix' }; event Subtest => sub { call name => "nested_$_"; call subevents => array { event Note => { message => "nested case $_" }; event Subtest => sub { call name => $_; call subevents => array { event Note => { message => 'root_before_each' }; event Note => { message => 'root_around_each_prefix' }; event Note => { message => 'nested_before_each' }; event Note => { message => 'nested_around_each_prefix' }; if ($_ eq 'nested_long') { event Ok => { name => 'nested_long_1' }; event Ok => { name => 'nested_long_2' }; } else { event Ok => { name => $_ }; } event Note => { message => 'nested_after_each' }; event Note => { message => 'nested_around_each_postfix' }; event Note => { message => 'root_after_each' }; event Note => { message => 'root_around_each_postfix' }; event Plan => { max => T() }; }; } for qw/nested_a nested_b nested_long dup_name/; event Plan => { max => 4 }; }; } for qw/x y/; event Note => { message => 'nested_after_all' }; event Note => { message => 'nested_around_all_postfix' }; event Plan => { max => 2 }; }; }; event Plan => { max => 5 }; }; } for qw/x y/; event Note => { message => 'root_after_all' }; event Note => { message => 'root_around_all_postfix' }; }, "Got only the events that match the $type filter" ); }; }; tests dup_name => sub { my $unit = example(); my $events = intercept { Test2::Workflow::Runner->new( rand => 0, task => $unit, filter => {name => 'dup_name'} )->run(); }; is( $events, array { event Note => { message => 'root_before_all' }; event Note => { message => 'root_around_all_prefix' }; event Subtest => sub { call name => "root_$_"; call subevents => array { event Note => { message => "root case $_" }; event Skip => {}; event Skip => {}; event Skip => {}; event Subtest => sub { call name => 'dup_name'; call subevents => array { event Note => { message => 'root_before_each' }; event Note => { message => 'root_around_each_prefix' }; event Ok => { name => 'dup_name' }; event Note => { message => 'root_after_each' }; event Note => { message => 'root_around_each_postfix' }; event Plan => { max => 1 }; }; }; event Subtest => sub { call name => 'nested'; call subevents => array { event Note => { message => 'nested_before_all' }; event Note => { message => 'nested_around_all_prefix' }; event Subtest => sub { call name => "nested_$_"; call subevents => array { event Note => { message => "nested case $_" }; event Skip => {}; event Skip => {}; event Skip => {}; event Subtest => sub { call name => 'dup_name'; call subevents => array { event Note => { message => 'root_before_each' }; event Note => { message => 'root_around_each_prefix' }; event Note => { message => 'nested_before_each' }; event Note => { message => 'nested_around_each_prefix' }; event Ok => { name => 'dup_name' }; event Note => { message => 'nested_after_each' }; event Note => { message => 'nested_around_each_postfix' }; event Note => { message => 'root_after_each' }; event Note => { message => 'root_around_each_postfix' }; event Plan => { max => 1 }; }; }; event Plan => { max => 4 }; }; } for qw/x y/; event Note => { message => 'nested_after_all' }; event Note => { message => 'nested_around_all_postfix' }; event Plan => { max => 2 }; }; }; event Plan => { max => 5 }; }; } for qw/x y/; event Note => { message => 'root_after_all' }; event Note => { message => 'root_around_all_postfix' }; }, "Got only the events that match the dup_name filter" ); }; tests root_case => sub { my $unit = example(); my $events = intercept { Test2::Workflow::Runner->new( rand => 0, task => $unit, filter => {name => 'root_x'} )->run(); }; is( $events, array { event Note => { message => 'root_before_all' }; event Note => { message => 'root_around_all_prefix' }; event Subtest => sub { call name => "root_x"; call subevents => array { event Note => { message => "root case x" }; event Subtest => sub { call name => $_; call subevents => array { event Note => { message => 'root_before_each' }; event Note => { message => 'root_around_each_prefix' }; if ($_ eq 'root_long') { event Ok => { name => 'root_long_1' }; event Ok => { name => 'root_long_2' }; } else { event Ok => { name => $_ }; } event Note => { message => 'root_after_each' }; event Note => { message => 'root_around_each_postfix' }; event Plan => { max => T() }; }; } for qw/root_a root_b root_long dup_name/; event Subtest => sub { call name => 'nested'; call subevents => array { event Note => { message => 'nested_before_all' }; event Note => { message => 'nested_around_all_prefix' }; event Subtest => sub { call name => "nested_$_"; call subevents => array { event Note => { message => "nested case $_" }; event Subtest => sub { call name => $_; call subevents => array { event Note => { message => 'root_before_each' }; event Note => { message => 'root_around_each_prefix' }; event Note => { message => 'nested_before_each' }; event Note => { message => 'nested_around_each_prefix' }; if ($_ eq 'nested_long') { event Ok => { name => 'nested_long_1' }; event Ok => { name => 'nested_long_2' }; } else { event Ok => { name => $_ }; } event Note => { message => 'nested_after_each' }; event Note => { message => 'nested_around_each_postfix' }; event Note => { message => 'root_after_each' }; event Note => { message => 'root_around_each_postfix' }; event Plan => { max => T() }; }; } for qw/nested_a nested_b nested_long dup_name/; event Plan => { max => 4 }; }; } for qw/x y/; event Note => { message => 'nested_after_all' }; event Note => { message => 'nested_around_all_postfix' }; event Plan => { max => 2 }; }; }; event Plan => { max => 5 }; }; }; event Skip => {}; event Note => { message => 'root_after_all' }; event Note => { message => 'root_around_all_postfix' }; }, "Got only the events that match the case filter" ); }; tests nested_case => sub { my $unit = example(); my $events = intercept { Test2::Workflow::Runner->new( rand => 0, task => $unit, filter => {name => 'nested_x'} )->run(); }; is( $events, array { event Note => { message => 'root_before_all' }; event Note => { message => 'root_around_all_prefix' }; event Subtest => sub { call name => "root_$_"; call subevents => array { event Note => { message => "root case $_" }; event Skip => {}; event Skip => {}; event Skip => {}; event Skip => {}; event Subtest => sub { call name => 'nested'; call subevents => array { event Note => { message => 'nested_before_all' }; event Note => { message => 'nested_around_all_prefix' }; event Subtest => sub { call name => "nested_x"; call subevents => array { event Note => { message => "nested case x" }; event Subtest => sub { call name => $_; call subevents => array { event Note => { message => 'root_before_each' }; event Note => { message => 'root_around_each_prefix' }; event Note => { message => 'nested_before_each' }; event Note => { message => 'nested_around_each_prefix' }; if ($_ eq 'nested_long') { event Ok => { name => 'nested_long_1' }; event Ok => { name => 'nested_long_2' }; } else { event Ok => { name => $_ }; } event Note => { message => 'nested_after_each' }; event Note => { message => 'nested_around_each_postfix' }; event Note => { message => 'root_after_each' }; event Note => { message => 'root_around_each_postfix' }; event Plan => { max => T() }; }; } for qw/nested_a nested_b nested_long dup_name/; event Plan => { max => 4 }; }; }; event Skip => {}; event Note => { message => 'nested_after_all' }; event Note => { message => 'nested_around_all_postfix' }; event Plan => { max => 2 }; }; }; event Plan => { max => 5 }; }; } for qw/x y/; event Note => { message => 'root_after_all' }; event Note => { message => 'root_around_all_postfix' }; }, "Got only the events that match the nested case filter" ); }; done_testing; Test2-Suite-0.000129/t/behavior/Mocking.t0000644000175000017500000000242313615053353017600 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Workflow'; use Test2::Tools::Spec; describe mock_spec => sub { mock Fake1 => ( add => [ check => sub { 1 } ] ); before_all ba => sub { mock Fake2 => ( add => [ check => sub { 2 } ])}; before_each be => sub { mock Fake3 => ( add => [ check => sub { 3 } ])}; is( Fake1->check, 1, "mock applies to describe block"); around_each ae => sub { my $inner = shift; mock Fake4 => ( add => [check => sub { 4 } ]); $inner->(); }; tests the_test => sub { mock Fake5 => ( add => [check => sub { 5 } ]); is( Fake1->check, 1, "mock 1"); is( Fake2->check, 2, "mock 2"); is( Fake3->check, 3, "mock 3"); is( Fake4->check, 4, "mock 4"); is( Fake5->check, 5, "mock 5"); }; describe nested => sub { tests inner => sub { is( Fake1->check, 1, "mock 1"); is( Fake2->check, 2, "mock 2"); is( Fake3->check, 3, "mock 3"); is( Fake4->check, 4, "mock 4"); ok(!Fake5->can('check'), "mock 5 did not leak"); }; }; }; tests post => sub { ok(!"Fake$_"->can('check'), "mock $_ did not leak") for 1 .. 5; }; ok(!"Fake$_"->can('check'), "mock $_ did not leak") for 1 .. 5; done_testing; Test2-Suite-0.000129/t/behavior/simple.t0000644000175000017500000000026313615053353017502 0ustar exodistexodistuse strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::AsyncSubtest; my $ast = async_subtest foo => sub { ok(1, "Simple"); }; $ast->finish; done_testing; Test2-Suite-0.000129/t/acceptance/0000755000175000017500000000000013615053353016312 5ustar exodistexodistTest2-Suite-0.000129/t/acceptance/Workflow-Acceptance3.t0000644000175000017500000000025013615053353022415 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Tools::Spec; # This is a test that things are ok if you do not use the spec after loading # it. ok(1, "blah"); done_testing; Test2-Suite-0.000129/t/acceptance/Workflow-Acceptance4.t0000644000175000017500000000037113615053353022422 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Tools::Spec; use Test2::API qw/intercept/; my $unit = tests simple => sub { ok(1, "inside simple"); }; my $runner = Test2::Workflow::Runner->new; $runner->push_task($unit); $runner->run; done_testing; Test2-Suite-0.000129/t/acceptance/Workflow-Acceptance2.t0000644000175000017500000000042413615053353022417 0ustar exodistexodistuse strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Spec; describe outer => sub { tests foo => sub { ok(1, 'foo') }; describe inner => sub { tests bar => sub { ok(1, 'bar') }; }; }; tests foo => sub { ok(1, 'foo') }; done_testing; Test2-Suite-0.000129/t/acceptance/Workflow-Acceptance5.t0000644000175000017500000000170413615053353022424 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Tools::Spec qw/:ALL/; use Test2::Util qw/get_tid/; sub get_ids { return { pid => $$, tid => get_tid(), }; } my $orig = get_ids(); spec_defaults case => (iso => 1, async => 1); spec_defaults tests => (iso => 1, async => 1); tests outside => sub { isnt(get_ids(), $orig, "In child (lexial)"); }; describe wrapper => sub { case foo => sub { isnt(get_ids(), $orig, "In child (inherited)") }; case 'bar', {iso => 0, async => 0} => sub { is(get_ids(), $orig, "In orig (overriden)") }; tests a => sub { ok(1, 'stub') }; tests b => sub { ok(1, 'stub') }; my $x = describe nested => sub { tests nested_t => sub { ok(0, 'Should not see this') }; }; tests nested => sub { ok(!$x->primary->[0]->iso, "Did not inherit when captured"); ok(!$x->primary->[0]->async, "Did not inherit when captured"); }; }; done_testing; Test2-Suite-0.000129/t/acceptance/Workflow-Acceptance.t0000644000175000017500000007462513615053353022353 0ustar exodistexodistuse strict; use warnings; use Test2::Bundle::Extended; use Test2::Tools::Spec qw/:DEFAULT include_workflow/; use Test2::Workflow::Runner; use Test2::API qw/intercept/; use Test2::Util qw/get_tid/; my $B = describe foo => sub { before_all start => sub { ok(1, 'start') }; around_all al => sub { my $cont = shift; ok(1, 'al start'); $cont->(); ok(1, 'al end'); }; after_all end => sub { ok(1, 'end') }; before_each bef => sub { ok(1, 'a') }; around_each arr => sub { my $cont = shift; ok(1, 'ar start'); $cont->(); ok(1, 'ar end'); }; after_each aft => sub { ok(1, 'z') }; case c1 => sub { ok(1, 'in c1') }; case c2 => sub { ok(1, 'in c2') }; before_case bc => sub { ok(1, 'in bc') }; around_case arc => sub { my $cont = shift; ok(1, 'arc start'); $cont->(); ok(1, 'arc end'); }; after_case ac => sub { ok(1, 'in ac') }; tests bar => {iso => 1}, sub { ok(1, "inside bar pid $$ - tid " . get_tid()); }; tests baz => sub { ok(1, "inside baz pid $$ - tid " . get_tid()); }; tests uhg => sub { my $todo = todo "foo todo"; ok(0, 'xxx'); }; tests bug => {todo => 'a bug'}, sub { ok(0, 'fail'); }; tests broken => {skip => 'will break things'}, sub { warn "\n\n**** You should not see this! ****\n\n"; print STDERR Carp::longmess('here'); print "not ok - You should not see this\n"; exit 255; }; describe nested => {iso => 1}, sub { before_each n1_be => sub { ok(1, 'nested before') }; after_each n1_ae => sub { ok(1, 'nested after') }; tests n1 => sub { ok(1, 'nested 1') }; tests n2 => sub { ok(1, 'nested 2') }; }; }; my $r1 = Test2::Workflow::Runner->new(task => $B, no_threads => 1); $r1->run; my $r2 = Test2::Workflow::Runner->new(task => $B, no_fork => 1); $r2->run; my $r3 = Test2::Workflow::Runner->new(task => $B, no_fork => 1, no_threads => 1); $r3->run; tests on_root => sub { ok(1, "in root") }; { package Foo::Bar; sub foo { 'xxx' } } describe in_root => {flat => 1}, sub { is(Foo::Bar->foo, 'xxx', "not mocked"); mock 'Foo::Bar' => ( override => [ foo => sub { 'foo' }, ], ); is(Foo::Bar->foo, 'foo', "mocked"); tests on_root_a => sub { ok(1, "in root"); is(Foo::Bar->foo, 'foo', "mocked"); }; describe 'iso-in-iso' => {iso => 1}, sub { tests on_root_b => {iso => 1}, sub { ok(1, "in root") }; tests on_root_c => {iso => 1}, sub { ok(1, "in root") }; tests on_root_d => {iso => 1}, sub { ok(1, "in root") }; }; my $B = describe included => sub { tests inside => sub { ok(1, "xxx") }; }; include_workflow($B); }; is(Foo::Bar->foo, 'xxx', "not mocked"); describe todo_desc => {todo => 'cause'}, sub { ok(0, "not ready"); tests foo => sub { ok(0, "not ready nested"); } }; describe skip_desc => {skip => 'cause'}, sub { print STDERR "Should not see this!\n"; print "not ok - You should not see this\n"; exit 255; }; eval { describe dies => sub { ok(1, 'xxx'); ok(1, 'xxx'); die "xxx"; }; 1; }; like( $@, check_set( qr/^Exception in build 'dies' with 2 unseen event\(s\)\.$/m, qr{^xxx at .*Acceptance\.t line \d+\.$}m, qr/^Overview of unseen events:/m, qr/^ Test2::Event::Ok at .*Acceptance\.t line \d+$/m, qr/^ Test2::Event::Ok at .*Acceptance\.t line \d+/m, ), "Error is as expected" ); my $events = intercept { my $r = Test2::Workflow::Runner->new(task => $B, no_fork => 1, no_threads => 1, rand => 0); $r->run; }; is( $events, array { event Subtest => sub { call name => 'foo'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 77; call subevents => array { event Ok => sub { call name => 'start'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 12; }; event Ok => sub { call name => 'al start'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 16; }; event Subtest => sub { call name => 'c1'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 34; call subevents => array { event Ok => sub { call name => 'in bc'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 37; }; event Ok => sub { call name => 'arc start'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 40; }; event Ok => sub { call name => 'in c1'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 34; }; event Skip => sub { call name => 'bar'; call pass => 1; call effective_pass => 1; call reason => 'No isolation method available'; prop file => match qr{\QAcceptance.t\E$}; prop line => 48; }; event Subtest => sub { call name => 'baz'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 52; call subevents => array { event Ok => sub { call name => 'a'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 23; }; event Ok => sub { call name => 'ar start'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 27; }; event Ok => sub { call name => match qr/inside baz pid/; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 51; }; event Ok => sub { call name => 'ar end'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 29; }; event Ok => sub { call name => 'z'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 32; }; event Plan => sub { call max => 5; prop file => match qr{\QAcceptance.t\E$}; prop line => 52; }; end(); }; }; event Subtest => sub { call name => 'uhg'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 57; call subevents => array { event Ok => sub { call name => 'a'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 23; }; event Ok => sub { call name => 'ar start'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 27; }; event Ok => sub { call name => 'xxx'; call pass => 0; call effective_pass => 1; call todo => 'foo todo'; prop file => match qr{\QAcceptance.t\E$}; prop line => 56; }; event Note => sub { call message => match qr{^\n?Failed test}; prop file => match qr{\QAcceptance.t\E$}; prop line => 56; }; event Ok => sub { call name => 'ar end'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 29; }; event Ok => sub { call name => 'z'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 32; }; event Plan => sub { call max => 5; prop file => match qr{\QAcceptance.t\E$}; prop line => 57; }; end(); }; }; event Subtest => sub { call name => 'bug'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 61; call subevents => array { event Ok => sub { call name => 'a'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 23; }; event Ok => sub { call name => 'ar start'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 27; }; event Ok => sub { call name => 'fail'; call pass => 0; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 60; }; event Note => sub { call message => match qr{^\n?Failed test}; prop file => match qr{\QAcceptance.t\E$}; prop line => 60; }; event Ok => sub { call name => 'ar end'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 29; }; event Ok => sub { call name => 'z'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 32; }; event Plan => sub { call max => 5; prop file => match qr{\QAcceptance.t\E$}; prop line => 61; }; end(); }; }; event Skip => sub { call name => 'broken'; call pass => 1; call effective_pass => 1; call reason => 'will break things'; prop file => match qr{\QRunner.pm\E$}; }; event Skip => sub { call name => 'nested'; call pass => 1; call effective_pass => 1; call reason => 'No isolation method available'; prop file => match qr{\QAcceptance.t\E$}; prop line => 76; }; event Ok => sub { call name => 'arc end'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 42; }; event Ok => sub { call name => 'in ac'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 44; }; event Plan => sub { call max => 11; prop file => match qr{\QAcceptance.t\E$}; prop line => 34; }; end(); }; }; event Subtest => sub { call name => 'c2'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 35; call subevents => array { event Ok => sub { call name => 'in bc'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 37; }; event Ok => sub { call name => 'arc start'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 40; }; event Ok => sub { call name => 'in c2'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 35; }; event Skip => sub { call name => 'bar'; call pass => 1; call effective_pass => 1; call reason => 'No isolation method available'; prop file => match qr{\QAcceptance.t\E$}; prop line => 48; }; event Subtest => sub { call name => 'baz'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 52; call subevents => array { event Ok => sub { call name => 'a'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 23; }; event Ok => sub { call name => 'ar start'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 27; }; event Ok => sub { call name => match qr/inside baz pid/; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 51; }; event Ok => sub { call name => 'ar end'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 29; }; event Ok => sub { call name => 'z'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 32; }; event Plan => sub { call max => 5; prop file => match qr{\QAcceptance.t\E$}; prop line => 52; }; end(); }; }; event Subtest => sub { call name => 'uhg'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 57; call subevents => array { event Ok => sub { call name => 'a'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 23; }; event Ok => sub { call name => 'ar start'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 27; }; event Ok => sub { call name => 'xxx'; call pass => 0; call effective_pass => 1; call todo => 'foo todo'; prop file => match qr{\QAcceptance.t\E$}; prop line => 56; }; event Note => sub { call message => match qr{^\n?Failed test}; prop file => match qr{\QAcceptance.t\E$}; prop line => 56; }; event Ok => sub { call name => 'ar end'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 29; }; event Ok => sub { call name => 'z'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 32; }; event Plan => sub { call max => 5; prop file => match qr{\QAcceptance.t\E$}; prop line => 57; }; end(); }; }; event Subtest => sub { call name => 'bug'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 61; call subevents => array { event Ok => sub { call name => 'a'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 23; }; event Ok => sub { call name => 'ar start'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 27; }; event Ok => sub { call name => 'fail'; call pass => 0; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 60; }; event Note => sub { call message => match qr{^\n?Failed test}; prop file => match qr{\QAcceptance.t\E$}; prop line => 60; }; event Ok => sub { call name => 'ar end'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 29; }; event Ok => sub { call name => 'z'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 32; }; event Plan => sub { call max => 5; prop file => match qr{\QAcceptance.t\E$}; prop line => 61; }; end(); }; }; event Skip => sub { call name => 'broken'; call pass => 1; call effective_pass => 1; call reason => 'will break things'; prop file => match qr{\QRunner.pm\E$}; }; event Skip => sub { call name => 'nested'; call pass => 1; call effective_pass => 1; call reason => 'No isolation method available'; prop file => match qr{\QAcceptance.t\E$}; prop line => 76; }; event Ok => sub { call name => 'arc end'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 42; }; event Ok => sub { call name => 'in ac'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 44; }; event Plan => sub { call max => 11; prop file => match qr{\QAcceptance.t\E$}; prop line => 35; }; end(); }; }; event Ok => sub { call name => 'al end'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 18; }; event Ok => sub { call name => 'end'; call pass => 1; call effective_pass => 1; prop file => match qr{\QAcceptance.t\E$}; prop line => 21; }; event Plan => sub { call max => 6; prop file => match qr{\QAcceptance.t\E$}; prop line => 77; }; end(); }; }; end(); }, "Events look correct" ); done_testing; 1; Test2-Suite-0.000129/t/acceptance/Tools.t0000644000175000017500000000165413615053353017605 0ustar exodistexodistuse strict; use warnings; use Test2::Util qw/get_tid CAN_REALLY_FORK/; use Test2::Bundle::Extended; use Test2::Tools::AsyncSubtest; imported_ok qw/async_subtest fork_subtest thread_subtest/; sub DO_THREADS { return 0 unless $ENV{AUTHOR_TESTING} || $ENV{T2_DO_THREAD_TESTS}; return Test2::AsyncSubtest->CAN_REALLY_THREAD; } my $ast = async_subtest foo => sub { ok(1, "Simple"); }; $ast->finish; if (CAN_REALLY_FORK) { my $f_ast = fork_subtest foo => sub { ok(1, "forked $$"); my $f2_ast = fork_subtest bar => sub { ok(1, "forked again $$"); }; $f2_ast->finish; }; $f_ast->finish; } if (DO_THREADS()) { my $t_ast = thread_subtest foo => sub { ok(1, "threaded " . get_tid); my $t2_ast = thread_subtest bar => sub { ok(1, "threaded again " . get_tid); }; $t2_ast->finish; }; $t_ast->finish; } done_testing; Test2-Suite-0.000129/t/acceptance/spec.t0000644000175000017500000000053513615053353017434 0ustar exodistexodistuse Test2::V0 -target => 'Test2::Tools::Spec'; use Test2::Tools::Spec; tests foo => sub { ok(1, "pass"); }; describe nested => sub { my $x = 0; before_all set_x => sub { $x = 100 }; tests a => sub { is($x, 100, "x was set (A)"); }; tests b => sub { is($x, 100, "x was set (B)"); }; }; done_testing; Test2-Suite-0.000129/t/acceptance/skip.t0000644000175000017500000001005513615053353017446 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::AsyncSubtest; use Test2::Tools::AsyncSubtest; use Test2::Tools::Compare qw{ array event call T }; use Test2::IPC; use Test2::Util qw/CAN_REALLY_FORK/; use Test2::API qw/context context_do intercept/; sub DO_THREADS { return 0 unless $ENV{AUTHOR_TESTING} || $ENV{T2_DO_THREAD_TESTS}; return Test2::AsyncSubtest->CAN_REALLY_THREAD; } skip_all 'These tests require forking or threading' unless CAN_REALLY_FORK || DO_THREADS(); subtest( 'fork tests', sub { run_tests('fork'); stress_tests('fork'); } ) if CAN_REALLY_FORK; subtest( 'thread tests', sub { run_tests('thread'); stress_tests('thread'); } ) if DO_THREADS(); done_testing; sub run_tests { my $type = shift; my $st_sub = $type eq 'fork' ? \&fork_subtest : \&thread_subtest; is( intercept { $st_sub->( '$ctx->plan(0, SKIP)', sub { skip_all 'because'; ok(0, "Should not see"); } )->finish; }, array { event Subtest => sub { call name => '$ctx->plan(0, SKIP)'; call pass => T(); call subevents => array { event '+Test2::AsyncSubtest::Event::Attach'; event Plan => sub { call directive => 'SKIP'; call reason => 'because'; }; event '+Test2::AsyncSubtest::Event::Detach'; end(); }; }; end(); }, qq[${type}_subtest with skip_all] ); is( intercept { $st_sub->( 'skip_all', { manual_skip_all => 1 }, sub { skip_all 'because'; note "Post skip"; return; } )->finish; }, array { event Subtest => sub { call name => 'skip_all'; call pass => T(); call subevents => array { event '+Test2::AsyncSubtest::Event::Attach'; event Plan => sub { call directive => 'SKIP'; call reason => 'because'; }; event Note => { message => 'Post skip' }; event '+Test2::AsyncSubtest::Event::Detach'; end(); }; }; end(); }, qq[${type}_subtest with skip_all and manual skip return}] ); my $method = 'run_' . $type; is( intercept { my $at = Test2::AsyncSubtest->new(name => '$ctx->plan(0, SKIP)'); $at->$method( sub { skip_all 'because'; ok(0, "should not see"); } ); $at->finish; }, array { event Subtest => sub { call name => '$ctx->plan(0, SKIP)'; call pass => T(); call subevents => array { event '+Test2::AsyncSubtest::Event::Attach'; event Plan => sub { call directive => 'SKIP'; call reason => 'because'; }; event '+Test2::AsyncSubtest::Event::Detach'; end(); }; }; end(); }, qq[\$subtest->$method with skip_all] ); } sub stress_tests { my $type = shift; my $st_sub = $type eq 'fork' ? \&fork_subtest : \&thread_subtest; for my $i (2 .. 5) { my @st; for my $j (1 .. $i) { push @st, $st_sub->( "skip all $i - $j", sub { skip_all 'because'; ok(0, "should not see"); } ); } $_->finish for @st; } } Test2-Suite-0.000129/t/acceptance/OO.t0000644000175000017500000000517613615053353017025 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::AsyncSubtest; use Test2::Tools::Compare qw{ array event field }; use Test2::IPC; use Test2::Util qw/CAN_REALLY_FORK CAN_THREAD get_tid/; sub DO_THREADS { return 0 unless $ENV{AUTHOR_TESTING} || $ENV{T2_DO_THREAD_TESTS}; return Test2::AsyncSubtest->CAN_REALLY_THREAD; } my $wrap = Test2::AsyncSubtest->new(name => 'wrap'); $wrap->start; my $t1 = Test2::AsyncSubtest->new(name => 't1'); my $t2 = Test2::AsyncSubtest->new(name => 't2'); $wrap->stop; $_->run(sub { ok(1, "not concurrent A"); }) for $t1, $t2; ok(1, "Something else"); if (CAN_REALLY_FORK) { my @pids; $_->run(sub { my $id = $_->cleave; my $pid = fork; die "Failed to fork!" unless defined $pid; if ($pid) { push @pids => $pid; return; } my $ok = eval { $_->attach($id); ok(1, "from proc $$"); $_->detach(); 1 }; exit 0 if $ok; warn $@; exit 255; }) for $t1, $t2; waitpid($_, 0) for @pids; } ok(1, "Something else"); if (DO_THREADS()) { require threads; my @threads; $_->run(sub { my $id = $_->cleave; push @threads => threads->create(sub { $_->attach($id); ok(1, "from thread " . get_tid); $_->detach(); }); }) for $t1, $t2; $_->join for @threads; } $_->run(sub { ok(1, "not concurrent B"); }) for $t1, $t2; ok(1, "Something else"); ok($wrap->pending, "Pending stuff"); $_->finish for $t1, $t2; ok(!$wrap->pending, "Ready now"); $wrap->finish; is( intercept { my $t = Test2::AsyncSubtest->new(name => 'will die'); $t->run(sub { die "kaboom!\n" }); $t->finish; }, array { event Subtest => sub { field name => 'will die'; field subevents => array { event Exception => sub { field error => "kaboom!\n"; }; event Plan => sub { field max => 0; }; }; }; event Diag => sub { field message => match qr/\QFailed test 'will die'/; }; end(); }, 'Subtest that dies not add a diagnostic about a bad plan' ); my $sta = Test2::AsyncSubtest->new(name => 'collapse: empty'); my $stb = Test2::AsyncSubtest->new(name => 'collapse: note only'); my $stc = Test2::AsyncSubtest->new(name => 'collapse: full'); $stb->run(sub { note "inside" }); $stc->run(sub { ok(1, "test") }); $sta->finish(collapse => 1); $stb->finish(collapse => 1); $stc->finish(collapse => 1); done_testing; Test2-Suite-0.000129/t/load_manual.t0000644000175000017500000000007413615053353016666 0ustar exodistexodistuse Test2::Tools::Tiny; use ok Test2::Manual; done_testing; Test2-Suite-0.000129/t/modules/0000755000175000017500000000000013615053353015674 5ustar exodistexodistTest2-Suite-0.000129/t/modules/AsyncSubtest/0000755000175000017500000000000013615053353020323 5ustar exodistexodistTest2-Suite-0.000129/t/modules/AsyncSubtest/Event/0000755000175000017500000000000013615053353021404 5ustar exodistexodistTest2-Suite-0.000129/t/modules/AsyncSubtest/Event/Attach.t0000644000175000017500000000164613615053353023004 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::AsyncSubtest::Event::Attach'; use Test2::AsyncSubtest::Event::Attach; isa_ok($CLASS, 'Test2::Event'); can_ok($CLASS, 'id'); require Test2::AsyncSubtest::Hub; my $hub = Test2::AsyncSubtest::Hub->new(); my $events = []; $hub->listen(sub { my ($h, $e) = @_; push @$events => $e; }); my $one = $CLASS->new(id => 123, trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__])); $one->callback($hub); like( pop(@$events), event(Exception => sub { error => qr/Invalid AsyncSubtest attach ID: 123/ }), "Got exception for attached id" ); $hub->{ast_ids}->{123} = 0; $one->callback($hub); is($hub->ast_ids->{123}, 1, "Filled slot"); ok(!@$events, "no events added"); $one->callback($hub); like( pop(@$events), event(Exception => sub { error => qr/AsyncSubtest ID 123 already attached/ }), "Got exception for invalid id" ); done_testing; Test2-Suite-0.000129/t/modules/AsyncSubtest/Event/Detach.t0000644000175000017500000000171113615053353022761 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::AsyncSubtest::Event::Detach'; use Test2::AsyncSubtest::Event::Detach; isa_ok($CLASS, 'Test2::Event'); can_ok($CLASS, 'id'); require Test2::AsyncSubtest::Hub; my $hub = Test2::AsyncSubtest::Hub->new(); my $events = []; $hub->listen(sub { my ($h, $e) = @_; push @$events => $e; }); my $one = $CLASS->new(id => 123, trace => Test2::Util::Trace->new(frame => [__PACKAGE__, __FILE__, __LINE__])); $one->callback($hub); like( pop(@$events), event(Exception => sub { error => qr/Invalid AsyncSubtest attach ID: 123/ }), "Got exception for invalid id" ); $hub->{ast_ids}->{123} = 0; $one->callback($hub); like( pop(@$events), event(Exception => sub { error => qr/AsyncSubtest ID 123 is not attached/ }), "Got exception for unattached id" ); $hub->{ast_ids}->{123} = 1; $one->callback($hub); ok(!exists($hub->ast_ids->{123}), "deleted slot"); ok(!@$events, "no events added"); done_testing; Test2-Suite-0.000129/t/modules/AsyncSubtest/Hub.t0000644000175000017500000000032213615053353021223 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::AsyncSubtest::Hub'; use Test2::AsyncSubtest::Hub; isa_ok($CLASS, 'Test2::Hub::Subtest'); ok(!$CLASS->can('inherit')->(), "inherit does nothing"); done_testing; Test2-Suite-0.000129/t/modules/Workflow/0000755000175000017500000000000013615053353017506 5ustar exodistexodistTest2-Suite-0.000129/t/modules/Workflow/Task/0000755000175000017500000000000013615053353020410 5ustar exodistexodistTest2-Suite-0.000129/t/modules/Workflow/Task/Action.t0000644000175000017500000000016213615053353022011 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Workflow::Task::Action'; can_ok($CLASS, 'around'); done_testing; Test2-Suite-0.000129/t/modules/Workflow/Task/Group.t0000644000175000017500000000026113615053353021670 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Workflow::Task::Group'; skip_all "Tests not yet written"; can_ok($CLASS, qw/before after primary rand variant/); done_testing; Test2-Suite-0.000129/t/modules/Workflow/BlockBase.t0000644000175000017500000000015013615053353021514 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Workflow::BlockBase'; skip_all "Tests not yet written"; Test2-Suite-0.000129/t/modules/Workflow/Runner.t0000644000175000017500000000014513615053353021144 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Workflow::Runner'; skip_all "Tests not yet written"; Test2-Suite-0.000129/t/modules/Workflow/Build.t0000644000175000017500000000014413615053353020731 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Workflow::Build'; skip_all "Tests not yet written"; Test2-Suite-0.000129/t/modules/Workflow/Task.t0000644000175000017500000000014413615053353020574 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Workflow::Task'; skip_all "Tests not yet written"; Test2-Suite-0.000129/t/modules/Require/0000755000175000017500000000000013615053353017310 5ustar exodistexodistTest2-Suite-0.000129/t/modules/Require/AuthorTesting.t0000644000175000017500000000051413615053353022275 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Require::AuthorTesting'; { local %ENV = %ENV; $ENV{AUTHOR_TESTING} = 0; is($CLASS->skip(), 'Author test, set the $AUTHOR_TESTING environment variable to run it', "will skip"); $ENV{AUTHOR_TESTING} = 1; is($CLASS->skip(), undef, "will not skip"); } done_testing; Test2-Suite-0.000129/t/modules/Require/RealFork.t0000644000175000017500000000102513615053353021200 0ustar exodistexodistuse strict; use warnings; # Prevent Test2::Util from making 'CAN_REALLY_FORK' a constant my $forks; BEGIN { require Test2::Util; local $SIG{__WARN__} = sub { 1 }; # no warnings is not sufficient on older perls *Test2::Util::CAN_REALLY_FORK = sub { $forks }; } use Test2::Bundle::Extended -target => 'Test2::Require::RealFork'; { $forks = 0; is($CLASS->skip(), 'This test requires a perl capable of true forking.', "will skip"); $forks = 1; is($CLASS->skip(), undef, "will not skip"); } done_testing; Test2-Suite-0.000129/t/modules/Require/Threads.t0000644000175000017500000000101713615053353021066 0ustar exodistexodistuse strict; use warnings; # Prevent Test2::Util from making 'CAN_THREAD' a constant my $threads; BEGIN { require Test2::Util; local $SIG{__WARN__} = sub { 1 }; # no warnings is not sufficient on older perls *Test2::Util::CAN_THREAD = sub { $threads }; } use Test2::Bundle::Extended -target => 'Test2::Require::Threads'; { $threads = 0; is($CLASS->skip(), 'This test requires a perl capable of threading.', "will skip"); $threads = 1; is($CLASS->skip(), undef, "will not skip"); } done_testing; Test2-Suite-0.000129/t/modules/Require/EnvVar.t0000644000175000017500000000065613615053353020705 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Require::EnvVar'; { local %ENV = %ENV; $ENV{FOO} = 0; is($CLASS->skip('FOO'), 'This test only runs if the $FOO environment variable is set', "will skip"); $ENV{FOO} = 1; is($CLASS->skip('FOO'), undef, "will not skip"); like( dies { $CLASS->skip }, qr/no environment variable specified/, "must specify a var" ); } done_testing; Test2-Suite-0.000129/t/modules/Require/Module.t0000644000175000017500000000077313615053353020731 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Require::Module'; is($CLASS->skip('Scalar::Util'), undef, "will not skip, module installed"); is($CLASS->skip('Scalar::Util', 0.5), undef, "will not skip, module at sufficient version"); like( $CLASS->skip('Test2', '99999'), qr/Need 'Test2' version 99999, have \d+.\d+\./, "Skip, insufficient version" ); is( $CLASS->skip('Some::Fake::Module'), "Module 'Some::Fake::Module' is not installed", "Skip, not installed" ); done_testing; Test2-Suite-0.000129/t/modules/Require/Fork.t0000644000175000017500000000077613615053353020410 0ustar exodistexodistuse strict; use warnings; # Prevent Test2::Util from making 'CAN_FORK' a constant my $forks; BEGIN { require Test2::Util; local $SIG{__WARN__} = sub { 1 }; # no warnings is not sufficient on older perls *Test2::Util::CAN_FORK = sub { $forks }; } use Test2::Bundle::Extended -target => 'Test2::Require::Fork'; { $forks = 0; is($CLASS->skip(), 'This test requires a perl capable of forking.', "will skip"); $forks = 1; is($CLASS->skip(), undef, "will not skip"); } done_testing; Test2-Suite-0.000129/t/modules/Require/Perl.t0000644000175000017500000000030413615053353020374 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Require::Perl'; is($CLASS->skip('v5.6'), undef, "will not skip"); is($CLASS->skip('v10.10'), 'Perl v10.10.0 required', "will skip"); done_testing; Test2-Suite-0.000129/t/modules/AsyncSubtest.t0000644000175000017500000001356713615053353020524 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::AsyncSubtest'; use Test2::AsyncSubtest; use Test2::Util qw/get_tid CAN_THREAD CAN_REALLY_FORK/; use Test2::API qw/intercept/; ok($INC{'Test2/IPC.pm'}, "Loaded Test2::IPC"); # Preserve the API can_ok $CLASS => qw{ name hub trace send_to events finished active stack id children pid tid context cleave attach detach ready pending run start stop finish wait fork run_fork run_thread }; my $file = __FILE__; my $line; like( dies { $line = __LINE__; $CLASS->new }, qr/'name' is a required attribute at \Q$file\E line $line/, "Must provide name" ); my ($one, $two, $three, $hub); my %lines; intercept { $lines{one} = __LINE__ + 1; $one = $CLASS->new(name => 'one'); $hub = Test2::API::test2_stack()->top; $one->run(sub { $lines{two} = __LINE__ + 1; $two = $CLASS->new(name => 'two'); $two->run(sub { $lines{three} = __LINE__ + 1; $three = $CLASS->new(name => 'three'); }); }); }; isa_ok($one, $CLASS); is($one->hub->ast, exact_ref($one), "Can retrieve AST fromthe hub"); like( $one, { name => 'one', send_to => exact_ref($hub), trace => {frame => [__PACKAGE__, __FILE__, $lines{one}]}, stack => [], _in_use => 2, tid => get_tid, pid => $$, finished => 0, id => 1, active => 0, children => [], hub => meta { prop blessed => 'Test2::AsyncSubtest::Hub' }, events => array {}, }, "Got expected properties from construction part 1" ); like( $two, { name => 'two', send_to => exact_ref($one->hub), trace => {frame => [__PACKAGE__, __FILE__, $lines{two}]}, stack => [exact_ref($one)], _in_use => 1, tid => get_tid, pid => $$, finished => 0, id => 1, active => 0, children => [], hub => meta { prop blessed => 'Test2::AsyncSubtest::Hub' }, events => array {}, }, "Got expected properties from construction part 2" ); like( $three, { name => 'three', send_to => exact_ref($two->hub), trace => {frame => [__PACKAGE__, __FILE__, $lines{three}]}, stack => [exact_ref($one), exact_ref($two)], _in_use => 0, tid => get_tid, pid => $$, finished => 0, id => 1, active => 0, children => [], hub => meta { prop blessed => 'Test2::AsyncSubtest::Hub' }, events => array {}, }, "Got expected properties from construction part 3" ); $_->finish for $three, $two, $one; is( intercept { my $st = Test2::AsyncSubtest->new(name => 'collapse: empty'); $st->finish(collapse => 1); }, array { event Ok => { pass => 1, name => 'collapse: empty', }; end; }, "Got 1 ok event for collapsed/empty subtest" ); is( intercept { my $st = Test2::AsyncSubtest->new(name => 'collapse: note only'); $st->run(sub { note "inside" }); $st->finish(collapse => 1); }, array { event Subtest => sub { call pass => 1; call name => 'collapse: note only'; call subevents => array { event Note => { message => "inside" }; event Plan => { max => 0, directive => 'SKIP' }; end; }; }; end; }, "Got subtest event containing only the note and a 0 plan" ); is( intercept { my $st = Test2::AsyncSubtest->new(name => 'collapse: full'); $st->run(sub { ok(1, "test") }); $st->finish(collapse => 1); }, array { event Subtest => sub { call pass => 1; call name => 'collapse: full'; call subevents => array { event Ok => { pass => 1 }; event Plan => { max => 1 }; end; }; }; end; }, "Got full subtest" ); is( intercept { my $st = Test2::AsyncSubtest->new(name => 'collapse: no assert, but fail'); $st->hub->set_failed(1); $st->finish(collapse => 1); }, array { fail_events Ok => sub { call pass => 0; call name => 'collapse: no assert, but fail'; }; end; }, "Failure with no assertion (no test count)" ); is( intercept { my $st = Test2::AsyncSubtest->new(name => 'skip test'); $st->finish(skip => "foo bar"); }, array { event Skip => { name => 'skip test', reason => 'foo bar' }; end; }, "Can skip" ); my $events = intercept { my $control = mock 'Test2::Hub' => ( override => [ is_local => sub { 0 } ], ); my $st = Test2::AsyncSubtest->new(name => 'early'); $st->run(sub { diag("We want to see this message or people die!") }); $control = undef; $st->finish(); }; is( $events->[0]->{subevents}->[0]->{message}, "We want to see this message or people die!", "Can send non-local non-attached events" ); # TODO Make this into an actual test, we want it to cause an explosion, but # intercept is not string enough to contain that explosion... #$events = intercept { # my $control = mock 'Test2::Hub' => ( # override => [ is_local => sub { 0 } ], # ); # # my $st = Test2::AsyncSubtest->new(name => 'early'); # # local $SIG{PIPE} = 'IGNORE'; # pipe(my $rh, my $wh) or die "Could not pipe"; # my $pid = fork(); # if ($pid) { # $st->run(sub{ ok(1) }); # $control = undef; # $st->finish(); # print $wh "ready\n"; # $wh->flush; # close($wh); # waitpid($pid, 0); # } # else { # my $ready = <$rh>; # $st->run(sub{ diag "Too Late" }); # exit 0; # } #}; done_testing; Test2-Suite-0.000129/t/modules/Compare/0000755000175000017500000000000013615053353017262 5ustar exodistexodistTest2-Suite-0.000129/t/modules/Compare/OrderedSubset.t0000644000175000017500000000526713615053353022233 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::OrderedSubset'; use lib 't/lib'; isa_ok($CLASS, 'Test2::Compare::Base'); is($CLASS->name, '', "got name"); subtest construction => sub { my $one = $CLASS->new(); isa_ok($one, $CLASS); is($one->items, [], "created items as an array"); $one = $CLASS->new(items => [qw/a b/]); is($one->items, [qw/a b/], "used items as specified"); $one = $CLASS->new(inref => ['a', 'b']); is($one->items, [qw/a b/], "Generated items"); like( dies { $CLASS->new(inref => { 1 => 'a' }) }, qr/'inref' must be an array reference, got 'HASH\(.+\)'/, "inref must be an array" ); }; subtest verify => sub { my $one = $CLASS->new; is($one->verify(exists => 0), 0, "did not get anything"); is($one->verify(exists => 1, got => undef), 0, "undef is not an array"); is($one->verify(exists => 1, got => 0), 0, "0 is not an array"); is($one->verify(exists => 1, got => 1), 0, "1 is not an array"); is($one->verify(exists => 1, got => 'string'), 0, "'string' is not an array"); is($one->verify(exists => 1, got => {}), 0, "a hash is not an array"); is($one->verify(exists => 1, got => []), 1, "an array is an array"); }; subtest add_item => sub { my $one = $CLASS->new(); $one->add_item('a'); $one->add_item(1 => 'b'); $one->add_item(3 => 'd'); $one->add_item(8 => 'x'); $one->add_item('y'); is( $one->items, [ 'a', 'b', 'd', 'x', 'y' ], "Expected items" ); }; subtest deltas => sub { my $conv = Test2::Compare->can('strict_convert'); my %params = (exists => 1, convert => $conv, seen => {}); my $inref = ['a', 'b']; my $one = $CLASS->new(inref => $inref); like( [$one->deltas(%params, got => ['a', 'b'])], [], "No delta, no diff" ); like( [$one->deltas(%params, got => ['a'])], [ { dne => 'got', id => [ARRAY => '?'], } ], "Got the delta for the missing value" ); like( [$one->deltas(%params, got => ['a', 'a'])], [ { dne => 'got', id => [ARRAY => '?'], } ], "Got the delta for the incorrect value" ); like( [$one->deltas(%params, got => ['a', 'b', 'a', 'a'])], [], "No delta, not checking ending" ); }; { package Foo::OO; use base 'MyTest::Target'; sub new { my $class = shift; bless [ @_ ] , $class; } } subtest object_as_arrays => sub { my $o1 = Foo::OO->new( 'b') ; is ( $o1 , subset{ item 'b' }, "same" ); }; done_testing; Test2-Suite-0.000129/t/modules/Compare/EventMeta.t0000644000175000017500000000130413615053353021335 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::EventMeta'; use Test2::Util qw/get_tid/; my $one = $CLASS->new(); my $trace = Test2::Util::Trace->new(frame => ['Foo', 'foo.t', 42, 'foo']); my $Ok = Test2::Event::Ok->new(trace => $trace, pass => 1); is($one->get_prop_file($Ok), 'foo.t', "file"); is($one->get_prop_line($Ok), 42, "line"); is($one->get_prop_package($Ok), 'Foo', "package"); is($one->get_prop_subname($Ok), 'foo', "subname"); is($one->get_prop_debug($Ok), 'at foo.t line 42', "trace"); is($one->get_prop_pid($Ok), $$, "pid"); is($one->get_prop_tid($Ok), get_tid, "tid"); done_testing; Test2-Suite-0.000129/t/modules/Compare/Wildcard.t0000644000175000017500000000075313615053353021205 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Wildcard'; my $one = $CLASS->new(expect => 'foo'); isa_ok($one, $CLASS, 'Test2::Compare::Base'); ok(defined $CLASS->new(expect => 0), "0 is a valid expect value"); ok(defined $CLASS->new(expect => undef), "undef is a valid expect value"); ok(defined $CLASS->new(expect => ''), "'' is a valid expect value"); like( dies { $CLASS->new() }, qr/'expect' is a require attribute/, "Need to specify 'expect'" ); done_testing; Test2-Suite-0.000129/t/modules/Compare/Pattern.t0000644000175000017500000000243113615053353021064 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Pattern'; my $one = $CLASS->new(pattern => qr/HASH/); isa_ok($one, $CLASS, 'Test2::Compare::Base'); is($one->name, "" . qr/HASH/, "got name"); is($one->operator, '=~', "got operator"); ok(!$one->verify(got => {}, exists => 1), "A hashref does not validate against the pattern 'HASH'"); ok(!$one->verify(exists => 0), "DNE does not validate"); ok(!$one->verify(exists => 1, got => undef), "undef does not validate"); ok(!$one->verify(exists => 1, got => 'foo'), "Not a match"); ok($one->verify(exists => 1, got => 'A HASH B'), "Matches"); $one = $CLASS->new(pattern => qr/HASH/, negate => 1); isa_ok($one, $CLASS, 'Test2::Compare::Base'); is($one->name, "" . qr/HASH/, "got name"); is($one->operator, '!~', "got operator"); ok(!$one->verify(exists => 1, got => {}), "A hashref does not validate against the pattern 'HASH' even when negated"); ok(!$one->verify(exists => 0), "DNE does not validate"); ok(!$one->verify(exists => 1, got => undef), "undef does not validate"); ok($one->verify(exists => 1, got => 'foo'), "Not a match, but negated"); ok(!$one->verify(exists => 1, got => 'A HASH B'), "Matches, but negated"); like( dies { $CLASS->new }, qr/'pattern' is a required attribute/, "Need to specify a pattern" ); done_testing; Test2-Suite-0.000129/t/modules/Compare/String.t0000644000175000017500000000771613615053353020730 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::String'; my $number = $CLASS->new(input => '22.0'); my $string = $CLASS->new(input => 'hello'); my $untru1 = $CLASS->new(input => ''); my $untru2 = $CLASS->new(input => 0); isa_ok($_, $CLASS, 'Test2::Compare::Base') for $number, $string, $untru1, $untru2; subtest name => sub { is($number->name, '22.0', "got expected name"); is($string->name, 'hello', "got expected name"); is($untru1->name, '', "got expected name"); is($untru2->name, '0', "got expected name"); }; subtest operator => sub { is($number->operator(), '', "no operator for number + nothing"); is($number->operator(undef), '', "no operator for number + undef"); is($number->operator('x'), 'eq', "eq operator for number + string"); is($number->operator(1), 'eq', "eq operator for number + number"); is($string->operator(), '', "no operator for string + nothing"); is($string->operator(undef), '', "no operator for string + undef"); is($string->operator('x'), 'eq', "eq operator for string + string"); is($string->operator(1), 'eq', "eq operator for string + number"); is($untru1->operator(), '', "no operator for empty string + nothing"); is($untru1->operator(undef), '', "no operator for empty string + undef"); is($untru1->operator('x'), 'eq', "eq operator for empty string + string"); is($untru1->operator(1), 'eq', "eq operator for empty string + number"); is($untru2->operator(), '', "no operator for 0 + nothing"); is($untru2->operator(undef), '', "no operator for 0 + undef"); is($untru2->operator('x'), 'eq', "eq operator for 0 + string"); is($untru2->operator(1), 'eq', "eq operator for 0 + number"); }; subtest verify => sub { ok(!$number->verify(exists => 0, got => undef), 'does not verify against DNE'); ok(!$number->verify(exists => 1, got => {}), 'ref will not verify'); ok(!$number->verify(exists => 1, got => undef), 'looking for a number, not undef'); ok(!$number->verify(exists => 1, got => 'x'), 'not looking for a string'); ok(!$number->verify(exists => 1, got => 1), 'wrong number'); ok(!$number->verify(exists => 1, got => 22), '22.0 ne 22'); ok($number->verify(exists => 1, got => '22.0'), 'exact match with decimal'); ok(!$string->verify(exists => 0, got => undef), 'does not verify against DNE'); ok(!$string->verify(exists => 1, got => {}), 'ref will not verify'); ok(!$string->verify(exists => 1, got => undef), 'looking for a string, not undef'); ok(!$string->verify(exists => 1, got => 'x'), 'looking for a different string'); ok(!$string->verify(exists => 1, got => 1), 'looking for a string, not a number'); ok($string->verify(exists => 1, got => 'hello'), 'exact match'); ok(!$untru1->verify(exists => 0, got => undef), 'does not verify against DNE'); ok(!$untru1->verify(exists => 1, got => {}), 'ref will not verify'); ok(!$untru1->verify(exists => 1, got => undef), 'looking for a string, not undef'); ok(!$untru1->verify(exists => 1, got => 'x'), 'wrong string'); ok(!$untru1->verify(exists => 1, got => 1), 'not a number'); ok($untru1->verify(exists => 1, got => ''), 'exact match, empty string'); ok(!$untru2->verify(exists => 0, got => undef), 'does not verify against DNE'); ok(!$untru2->verify(exists => 1, got => {}), 'ref will not verify'); ok(!$untru2->verify(exists => 1, got => undef), 'undef is not 0 for this test'); ok(!$untru2->verify(exists => 1, got => 'x'), 'x is not 0'); ok(!$untru2->verify(exists => 1, got => 1), '1 is not 0'); ok(!$untru2->verify(exists => 1, got => '0.0'), '0.0 ne 0'); ok(!$untru2->verify(exists => 1, got => '-0.0'), '-0.0 ne 0'); ok($untru2->verify(exists => 1, got => 0), 'got 0'); }; like( dies { $CLASS->new() }, qr/input must be defined for 'String' check/, "Cannot use undef as a string" ); done_testing; Test2-Suite-0.000129/t/modules/Compare/Scalar.t0000644000175000017500000000177013615053353020661 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Scalar'; my $one = $CLASS->new(item => 'foo'); is($one->name, '', "got name"); is($one->operator, '${...}', "Got operator"); ok(!$one->verify(exists => 0), "nothing to verify"); ok(!$one->verify(exists => 1, got => undef), "undef"); ok(!$one->verify(exists => 1, got => 'a'), "not a ref"); ok(!$one->verify(exists => 1, got => {}), "not a scalar ref"); ok($one->verify(exists => 1, got => \'anything'), "Scalar ref"); my $convert = Test2::Compare->can('strict_convert'); is( [$one->deltas(got => \'foo', convert => $convert, seen => {})], [], "Exact match, no delta" ); like( [$one->deltas(got => \'bar', convert => $convert, seen => {})], [ { got => 'bar', id => [SCALAR => '$*'], chk => {'input' => 'foo'}, } ], "Value pointed to is different" ); like( dies { $CLASS->new() }, qr/'item' is a required attribute/, "item is required" ); done_testing; Test2-Suite-0.000129/t/modules/Compare/Object.t0000644000175000017500000001653513615053353020667 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Object'; subtest simple => sub { my $one = $CLASS->new; isa_ok($one, $CLASS, 'Test2::Compare::Base'); is($one->calls, [], "got calls arrayref for free"); is($one->name, '', "Got name"); is($one->meta_class, 'Test2::Compare::Meta', "Correct metaclass"); is($one->object_base, 'UNIVERSAL', "Correct object base"); ok(defined $CLASS->new(calls => []), "Can specify a calls array") }; subtest verify => sub { my $one = $CLASS->new; ok(!$one->verify(exists => 0), "nothing to verify"); ok(!$one->verify(exists => 1, got => 1), "not a ref"); ok(!$one->verify(exists => 1, got => {}), "not blessed"); ok($one->verify(exists => 1, got => bless({}, 'Foo')), "Blessed"); no warnings 'once'; local *Foo::isa = sub { 0 }; ok(!$one->verify(exists => 1, got => bless({}, 'Foo')), "not a 'UNIVERSAL' (pretend)"); }; subtest add_prop => sub { my $one = $CLASS->new(); ok(!$one->meta, "no meta yet"); $one->add_prop('blessed' => 'Foo'); isa_ok($one->meta, 'Test2::Compare::Meta'); is(@{$one->meta->items}, 1, "1 item"); $one->add_prop('reftype' => 'HASH'); is(@{$one->meta->items}, 2, "2 items"); }; subtest add_field => sub { my $one = $CLASS->new(); ok(!$one->refcheck, "no refcheck yet"); $one->add_field(foo => 1); isa_ok($one->refcheck, 'Test2::Compare::Hash'); is(@{$one->refcheck->order}, 1, "1 item"); $one->add_field(bar => 1); is(@{$one->refcheck->order}, 2, "2 items"); $one = $CLASS->new(); $one->add_item(0 => 'foo'); like( dies { $one->add_field(foo => 1) }, qr/Underlying reference does not have fields/, "Cannot add fields to a non-hash refcheck" ); }; subtest add_item => sub { my $one = $CLASS->new(); ok(!$one->refcheck, "no refcheck yet"); $one->add_item(0 => 'foo'); isa_ok($one->refcheck, 'Test2::Compare::Array'); is(@{$one->refcheck->order}, 1, "1 item"); $one->add_item(1 => 'bar'); is(@{$one->refcheck->order}, 2, "2 items"); $one = $CLASS->new(); $one->add_field('foo' => 1); like( dies { $one->add_item(0 => 'foo') }, qr/Underlying reference does not have items/, "Cannot add items to a non-array refcheck" ); }; subtest add_call => sub { my $one = $CLASS->new; my $code = sub { 1 }; $one->add_call(foo => 'FOO'); $one->add_call($code, 1); $one->add_call($code, 1, 'custom'); $one->add_call($code, 1, 'custom', 'list'); is( $one->calls, [ ['foo', 'FOO', 'foo', 'scalar'], [$code, 1, '\&CODE', 'scalar'], [$code, 1, 'custom', 'scalar'], [$code, 1, 'custom', 'list'], ], "Added all 4 calls" ); }; { package Foo::Bar; sub foo { 'foo' } sub baz { 'baz' } sub one { 1 } sub many { return (1,2,3,4) } sub args { shift; +{@_} } package Fake::Fake; sub foo { 'xxx' } sub one { 2 } sub args { shift; +[@_] } } subtest deltas => sub { my $convert = Test2::Compare->can('strict_convert'); my $good = bless { a => 1 }, 'Foo::Bar'; my $bad = bless [ 'a', 1 ], 'Fake::Fake'; my $one = $CLASS->new; $one->add_field(a => 1); $one->add_prop(blessed => 'Foo::Bar'); $one->add_call(sub { my $self = shift; die "XXX" unless $self->isa('Foo::Bar'); 'live'; }, 'live', 'maybe_throw'); $one->add_call('foo' => 'foo'); $one->add_call('baz' => 'baz'); $one->add_call('one' => 1); $one->add_call('many' => [1,2,3,4],undef,'list'); $one->add_call('many' => {1=>2,3=>4},undef,'hash'); $one->add_call([args => 1,2] => {1=>2}); is( [$one->deltas(exists => 1, got => $good, convert => $convert, seen => {})], [], "Nothing failed" ); like( [$one->deltas(got => $bad, convert => $convert, seen => {})], [ { chk => T(), got => 'Fake::Fake', id => ['META' => 'blessed'], }, { chk => T(), got => undef, id => [METHOD => 'maybe_throw'], exception => qr/XXX/, }, { chk => T(), got => 'xxx', id => [METHOD => 'foo'], }, { chk => T(), dne => 'got', got => undef, id => [METHOD => 'baz'], }, { chk => T(), got => 2, id => [METHOD => 'one'], }, { chk => T(), dne => 'got', got => undef, id => [METHOD => 'many'], }, { chk => T(), dne => 'got', got => undef, id => [METHOD => 'many'], }, { chk => T(), got => [1,2], id => [METHOD => 'args'], }, { chk => T(), got => [], id => [META => 'Object Ref'], }, ], "Everything failed" ); # This is critical, there were a couple bugs only seen when wrapped in # 'run' instead of directly calling 'deltas' like( [$one->run(id => undef, got => $bad, convert => $convert, seen => {})], [ { verified => 1, children => [ { chk => T(), got => 'Fake::Fake', id => ['META' => 'blessed'], }, { chk => T(), got => undef, id => [METHOD => 'maybe_throw'], exception => qr/XXX/, }, { chk => T(), got => 'xxx', id => [METHOD => 'foo'], }, { chk => T(), dne => 'got', got => undef, id => [METHOD => 'baz'], }, { chk => T(), got => 2, id => [METHOD => 'one'], }, { chk => T(), dne => 'got', got => undef, id => [METHOD => 'many'], }, { chk => T(), dne => 'got', got => undef, id => [METHOD => 'many'], }, { chk => T(), got => [1,2], id => [METHOD => 'args'], }, { chk => T(), got => [], id => [META => 'Object Ref'], }, ], }, ], "Everything failed, check when wrapped" ); }; done_testing; Test2-Suite-0.000129/t/modules/Compare/Custom.t0000644000175000017500000000164113615053353020723 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Custom'; my $pass = $CLASS->new(code => sub { 1 }); my $fail = $CLASS->new(code => sub { 0 }); isa_ok($pass, $CLASS, 'Test2::Compare::Base'); isa_ok($fail, $CLASS, 'Test2::Compare::Base'); ok($pass->verify(got => "anything"), "always passes"); ok(!$fail->verify(got => "anything"), "always fails"); is($pass->operator, 'CODE(...)', "default operator"); is($pass->name, '', "default name"); my $args; my $under; my $one = $CLASS->new(code => sub { $args = {@_}; $under = $_ }, name => 'the name', operator => 'the op'); $_ = undef; $one->verify(got => 'foo', exists => 'x'); is($_, undef, '$_ restored'); is($args, {got => 'foo', exists => 'x', operator => 'the op', name => 'the name'}, "Got the expected args"); is($under, 'foo', '$_ was set'); like( dies { $CLASS->new() }, qr/'code' is required/, "Need to provide code" ); done_testing; Test2-Suite-0.000129/t/modules/Compare/Number.t0000644000175000017500000000546413615053353020710 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Number'; my $num = $CLASS->new(input => '22.0'); my $untrue = $CLASS->new(input => 0); isa_ok($num, $CLASS, 'Test2::Compare::Base'); isa_ok($untrue, $CLASS, 'Test2::Compare::Base'); subtest name => sub { is($num->name, '22.0', "got expected name for number"); is($untrue->name, '0', "got expected name for 0"); }; subtest operator => sub { is($num->operator(), '', "no operator for number + nothing"); is($num->operator(undef), '', "no operator for number + undef"); is($num->operator(1), '==', "== operator for number + number"); is($untrue->operator(), '', "no operator for 0 + nothing"); is($untrue->operator(undef), '', "no operator for 0 + undef"); is($untrue->operator(1), '==', "== operator for 0 + number"); }; subtest verify => sub { ok(!$num->verify(exists => 0, got => undef), 'does not verify against DNE'); ok(!$num->verify(exists => 1, got => {}), 'ref will not verify'); ok(!$num->verify(exists => 1, got => undef), 'looking for a number, not undef'); ok(!$num->verify(exists => 1, got => 'x'), 'not looking for a string'); ok(!$num->verify(exists => 1, got => 1), 'wrong number'); ok($num->verify(exists => 1, got => 22), '22.0 == 22'); ok($num->verify(exists => 1, got => '22.0'), 'exact match with decimal'); ok(!$untrue->verify(exists => 0, got => undef), 'does not verify against DNE'); ok(!$untrue->verify(exists => 1, got => {}), 'ref will not verify'); ok(!$untrue->verify(exists => 1, got => undef), 'undef is not 0 for this test'); ok(!$untrue->verify(exists => 1, got => 'x'), 'x is not 0'); ok(!$untrue->verify(exists => 1, got => 1), '1 is not 0'); ok(!$untrue->verify(exists => 1, got => ''), '"" is not 0'); ok(!$untrue->verify(exists => 1, got => ' '), '" " is not 0'); ok($untrue->verify(exists => 1, got => 0), 'got 0'); ok($untrue->verify(exists => 1, got => '0.0'), '0.0 == 0'); ok($untrue->verify(exists => 1, got => '-0.0'), '-0.0 == 0'); }; subtest rounding => sub { my $round = $CLASS->new(input => '60.48'); ok($round->verify(exists => 1, got => 60.48), '60.48 == 60.48'); { my $todo = todo "floating point comparison representation error"; ok($round->verify(exists => 1, got => 125 - 64.52), '60.48 == 125 - 64.52'); } }; like( dies { $CLASS->new() }, qr/input must be defined for 'Number' check/, "Cannot use undef as a number" ); like( dies { $CLASS->new(input => '') }, qr/input must be a number for 'Number' check/, "Cannot use empty string as a number" ); like( dies { $CLASS->new(input => ' ') }, qr/input must be a number for 'Number' check/, "Cannot use whitespace string as a number" ); done_testing; Test2-Suite-0.000129/t/modules/Compare/Float.t0000644000175000017500000002236413615053353020523 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Float'; my $num = $CLASS->new(input => '22.0', tolerance => .001); my $neg_num = $CLASS->new(input => -22, tolerance => .001); my $untrue = $CLASS->new(input => 0); my $pre_num = $CLASS->new(input => '22.0', precision => 3); isa_ok($num, $CLASS, 'Test2::Compare::Base'); isa_ok($untrue, $CLASS, 'Test2::Compare::Base'); subtest tolerance => sub { is($num->tolerance, 0.001, "got expected tolerance for number"); is($untrue->tolerance, 1e-08, "got default tolerance for 0"); }; subtest name => sub { is($num->name, '22.0 +/- ' . $num->tolerance, "got expected name for number"); is($untrue->name, '0 +/- ' . $untrue->tolerance, "got expected name for 0"); # Note: string length of mantissa varies by perl install, e.g. 1e-08 vs 1e-008 is($pre_num->name, '22.000', "got expected 3 digits of precision in name for 22.0, precision=5"); is($CLASS->new(input => '100.123456789012345', precision => 10)->name, '100.1234567890', 'got expected precision in name at precision=10'); is($CLASS->new(input => '100.123456789012345', precision => 15)->name, sprintf('%.*f', 15, '100.123456789012345'), 'got expected precision in name at precision=15'); # likely not 100.123456789012345! is($CLASS->new(input => '100.123456789012345', precision => 20)->name, sprintf('%.*f', 20, '100.123456789012345'), 'got expected precision in name at precision=20'); }; subtest operator => sub { is($num->operator(), '', "no operator for number + nothing"); is($num->operator(undef), '', "no operator for number + undef"); is($num->operator(1), '==', "== operator for number + number"); is($untrue->operator(), '', "no operator for 0 + nothing"); is($untrue->operator(undef), '', "no operator for 0 + undef"); is($untrue->operator(1), '==', "== operator for 0 + number"); is($pre_num->operator(), '', "no operator for precision number + nothing"); is($pre_num->operator(undef), '', "no operator for precision number + undef"); is($pre_num->operator(1), 'eq', "eq operator for precision number + number"); }; subtest verify => sub { ok(!$num->verify(exists => 0, got => undef), 'does not verify against DNE'); ok(!$num->verify(exists => 1, got => {}), 'ref will not verify'); ok(!$num->verify(exists => 1, got => undef), 'looking for a number, not undef'); ok(!$num->verify(exists => 1, got => 'x'), 'not looking for a string'); ok(!$num->verify(exists => 1, got => 1), 'wrong number'); ok($num->verify(exists => 1, got => 22), '22.0 == 22'); ok($num->verify(exists => 1, got => '22.0'), 'exact match with decimal'); ok(!$untrue->verify(exists => 0, got => undef), 'does not verify against DNE'); ok(!$untrue->verify(exists => 1, got => {}), 'ref will not verify'); ok(!$untrue->verify(exists => 1, got => undef), 'undef is not 0 for this test'); ok(!$untrue->verify(exists => 1, got => 'x'), 'x is not 0'); ok(!$untrue->verify(exists => 1, got => 1), '1 is not 0'); ok(!$untrue->verify(exists => 1, got => ''), '"" is not 0'); ok(!$untrue->verify(exists => 1, got => ' '), '" " is not 0'); ok($untrue->verify(exists => 1, got => 0), 'got 0'); ok($untrue->verify(exists => 1, got => '0.0'), '0.0 == 0'); ok($untrue->verify(exists => 1, got => '-0.0'), '-0.0 == 0'); }; subtest verify_float_tolerance => sub { ok($num->verify(exists => 1, got => "22.0"), '22.0 == 22 +/- .001'); ok($num->verify(exists => 1, got => "22.0009"), '22.0009 == 22 +/- .001'); ok($num->verify(exists => 1, got => "21.9991"), '21.9991 == 22 +/- .001'); ok(!$num->verify(exists => 1, got => "22.0011"), '22.0009 != 22 +/- .001'); ok(!$num->verify(exists => 1, got => "21.9989"), '21.9989 != 22 +/- .001'); ok(!$num->verify(exists => 1, got => "23"), '23 != 22 +/- .001'); ok($num->verify(exists => 1, got => 22.0), '22.0 == 22 +/- .001'); ok($num->verify(exists => 1, got => 22.0009), '22.0009 == 22 +/- .001'); ok($num->verify(exists => 1, got => 21.9991), '21.9991 == 22 +/- .001'); ok(!$num->verify(exists => 1, got => 22.0011), '22.0009 != 22 +/- .001'); ok(!$num->verify(exists => 1, got => 21.9989), '21.9989 != 22 +/- .001'); ok(!$num->verify(exists => 1, got => 23), '23 != 22 +/- .001'); ok($neg_num->verify(exists => 1, got => -22.0), '-22.0 == -22 +/- .001'); ok($neg_num->verify(exists => 1, got => -22.0009), '-22.0009 == -22 +/- .001'); ok($neg_num->verify(exists => 1, got => -21.9991), '-21.9991 == -22 +/- .001'); ok(!$neg_num->verify(exists => 1, got => -22.0011), '-22.0009 != -22 +/- .001'); ok(!$neg_num->verify(exists => 1, got => -21.9989), '-21.9989 != -22 +/- .001'); ok(!$neg_num->verify(exists => 1, got => -23), '-23 != -22 +/- .001'); }; subtest verify_float_precision => sub { ok($pre_num->verify(exists => 1, got => "22.0"), '22.0 == 22.000'); ok($pre_num->verify(exists => 1, got => "22.0001"), '22.0001 == 22.000'); ok($pre_num->verify(exists => 1, got => "21.9999"), '21.9999 == 22.000'); ok(!$pre_num->verify(exists => 1, got => "22.0011"), '22.0011 != 22.000'); ok(!$pre_num->verify(exists => 1, got => "21.9989"), '21.9989 != 22.000'); ok(!$pre_num->verify(exists => 1, got => "23"), '23 != 22.000'); ok($pre_num->verify(exists => 1, got => 22.0), '22.0 == 22.000'); ok($pre_num->verify(exists => 1, got => 22.00049), '22.00049 == 22.000'); ok(!$pre_num->verify(exists => 1, got => 22.00051), '22.00051 != 22.000'); ok($pre_num->verify(exists => 1, got => 21.99951), '21.99951 == 22.000'); ok(!$pre_num->verify(exists => 1, got => 22.0009), '22.0009 != 22.000'); ok(!$pre_num->verify(exists => 1, got => 21.9989), '21.9989 != 22.000'); ok(!$pre_num->verify(exists => 1, got => 23), '23 != 22.000'); ok($neg_num->verify(exists => 1, got => -22.0), '-22.0 == -22.000'); ok($neg_num->verify(exists => 1, got => -22.0009), '-22.0009 == -22.000'); ok($neg_num->verify(exists => 1, got => -21.9991), '-21.9991 == -22.000'); ok(!$neg_num->verify(exists => 1, got => -22.0011), '-22.0009 != -22.000'); ok(!$neg_num->verify(exists => 1, got => -21.9989), '-21.9989 != -22.000'); ok(!$neg_num->verify(exists => 1, got => -23), '-23 != -22.000'); }; subtest rounding_tolerance => sub { my $round_08 = $CLASS->new(input => '60.48'); my $round_13 = $CLASS->new(input => '60.48', tolerance => 1e-13); my $round_14 = $CLASS->new(input => '60.48', tolerance => 1e-14); ok($round_08->verify(exists => 1, got => 60.48), ' 60.48 == ' . $round_08->name . " - inside tolerance"); ok($round_13->verify(exists => 1, got => 60.48), ' 60.48 == ' . $round_13->name . " - inside tolerance"); ok($round_14->verify(exists => 1, got => 60.48), ' 60.48 == ' . $round_14->name . " - inside tolerance"); ok($round_08->verify(exists => 1, got => 125 - 64.52), '125 - 64.52 == ' . $round_08->name . " - inside tolerance"); ok($round_13->verify(exists => 1, got => 125 - 64.52), '125 - 64.52 == ' . $round_13->name . " - inside tolerance"); todo 'broken on some platforms' => sub { ok(!$round_14->verify(exists => 1, got => 125 - 64.52), '125 - 64.52 != ' . $round_14->name . " - outside tolerance"); }; }; subtest rounding_precision => sub { my $round_08 = $CLASS->new(input => '60.48', precision => 8 ); my $round_13 = $CLASS->new(input => '60.48', precision => 13); my $round_14 = $CLASS->new(input => '60.48', precision => 14); ok($round_08->verify(exists => 1, got => 60.48), ' 60.48 == ' . $round_08->name . " - inside precision"); ok($round_13->verify(exists => 1, got => 60.48), ' 60.48 == ' . $round_13->name . " - inside precision"); ok($round_14->verify(exists => 1, got => 60.48), ' 60.48 == ' . $round_14->name . " - inside precision"); ok($round_08->verify(exists => 1, got => 125 - 64.52), '125 - 64.52 == ' . $round_08->name . " - inside precision"); ok($round_13->verify(exists => 1, got => 125 - 64.52), '125 - 64.52 == ' . $round_13->name . " - inside precision"); # unlike TOLERANCE, this should work on 32 and 64 bit platforms. ok($round_14->verify(exists => 1, got => 125 - 64.52), '125 - 64.52 != ' . $round_14->name . " - outside precision"); }; like( dies { $CLASS->new() }, qr/input must be defined for 'Float' check/, "Cannot use undef as a number" ); like( dies { $CLASS->new(input => '') }, qr/input must be a number for 'Float' check/, "Cannot use empty string as a number" ); like( dies { $CLASS->new(input => ' ') }, qr/input must be a number for 'Float' check/, "Cannot use whitespace string as a number" ); like( dies { $CLASS->new(input => 1.234, precision => 5, tolerance => .001) }, qr/can't set both tolerance and precision/, "Cannot use both precision and tolerance" ); like( dies { $CLASS->new(input => 1.234, precision => .05) }, qr/precision must be an integer/, "precision can't be fractional" ); like( dies { $CLASS->new(input => 1.234, precision => -2) }, qr/precision must be an integer/, "precision can't be negative" ); done_testing; Test2-Suite-0.000129/t/modules/Compare/Regex.t0000644000175000017500000000162713615053353020527 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Regex'; my $one = $CLASS->new(input => qr/abc/i); is(qr/abc/i, $one, "same regex"); ok(!$one->verify(got => qr/xyz/i, exists => 1), "Different regex"); ok(!$one->verify(got => qr/abc/, exists => 1), "Different flags"); ok(!$one->verify(exists => 0), "Must exist"); ok(!$one->verify(exists => 1, got => {}), "Must be regex"); ok(!$one->verify(exists => 1, got => undef), "Must be defined"); ok(!$one->verify(exists => 1, got => 'aaa'), "String is not valid"); is($one->name, "" . qr/abc/i, "name is regex pattern"); is($one->operator, 'eq', "got operator"); ok($one->verify(got => qr/abc/i, exists => 1), "Same regex"); like( dies { $CLASS->new() }, qr/'input' is a required attribute/, "require a pattern" ); like( dies { $CLASS->new(input => 'foo') }, qr/'input' must be a regex , got 'foo'/, "must be a regex" ); done_testing; Test2-Suite-0.000129/t/modules/Compare/Undef.t0000644000175000017500000000307213615053353020512 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Undef'; my $undef = $CLASS->new(); my $isdef = $CLASS->new(negate => 1); isa_ok($undef, $CLASS, 'Test2::Compare::Base'); isa_ok($isdef, $CLASS, 'Test2::Compare::Base'); subtest name => sub { is($undef->name, '', "got expected name for undef"); is($isdef->name, '', "got expected name for negated undef"); }; subtest operator => sub { is($undef->operator(), 'IS', "Operator is 'IS'"); is($undef->operator('a'), 'IS', "Operator is 'IS'"); is($isdef->operator(), 'IS NOT', "Operator is 'IS NOT'"); is($isdef->operator('a'), 'IS NOT', "Operator is 'IS NOT'"); }; subtest verify => sub { ok(!$undef->verify(exists => 0, got => undef), 'does not verify against DNE'); ok(!$undef->verify(exists => 1, got => {}), 'ref will not verify'); ok(!$undef->verify(exists => 1, got => 'x'), 'not looking for a string'); ok(!$undef->verify(exists => 1, got => 1), 'not looking for a number'); ok(!$undef->verify(exists => 1, got => 0), 'not looking for a 0'); ok($undef->verify(exists => 1, got => undef), 'got undef'); ok(!$isdef->verify(exists => 0, got => undef), 'does not verify against DNE'); ok(!$isdef->verify(exists => 1, got => undef), 'got undef'); ok($isdef->verify(exists => 1, got => {}), 'ref is defined'); ok($isdef->verify(exists => 1, got => 'x'), 'string is defined'); ok($isdef->verify(exists => 1, got => 1), 'number is defined'); ok($isdef->verify(exists => 1, got => 0), '0 is defined'); }; done_testing; Test2-Suite-0.000129/t/modules/Compare/Delta.t0000644000175000017500000004642613615053353020514 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Delta'; BEGIN { $ENV{TABLE_TERM_SIZE} = 80 } can_ok($CLASS, qw/check/); is( $CLASS->can('chk'), $CLASS->can('check'), "chk is aliased to check" ); my $one = $CLASS->new(); isa_ok($one, $CLASS); my $check1 = Test2::Compare::String->new(input => 'x'); my $check2 = Test2::Compare::String->new(input => 'y'); $one = $CLASS->new(check => $check1); ref_is($one->chk, $check1, "Got our check"); ref_is($one->check, $check1, "Got our check aliased"); $one = $CLASS->new(chk => $check2); ref_is($one->chk, $check2, "Got our check"); ref_is($one->check, $check2, "Got our check aliased"); like( dies { $CLASS->new(check => $check1, chk => $check2) }, qr/Cannot specify both 'check' and 'chk' as arguments/, "Cannot specify both chk and check" ); subtest render_got => sub { my $one = $CLASS->new; is($one->render_got, '', "'got' is undef"); $one->set_exception('foo'); is($one->render_got, '', "Exception always wins"); $one->set_exception(undef); $one->set_dne('got'); is($one->render_got, '', "'got' does not exist"); $one->set_dne('check'); is($one->render_got, '', "'got' does not exist"); $one->set_dne(undef); $one->set_got('a'); is($one->render_got, 'a', "'got' value"); $one->set_got({}); like($one->render_got, qr/HASH\(.*\)/, "'got' ref value"); }; subtest render_check => sub { my $one = $CLASS->new; my $check = Test2::Compare::String->new(input => 'xyz'); is($one->render_check, '', "check is undef"); $one->set_dne('got'); is($one->render_check, '', "check is undef and dne is 'got'"); $one->set_dne('check'); is($one->render_check, '', "check does not exit"); $one->set_dne(undef); $one->set_check($check); is($one->render_check, $check->render, "valid check is rendered"); }; subtest _full_id => sub { my $fid = $CLASS->can('_full_id'); is($fid->(undef, 'xxx'), '', "no type means "); is($fid->('META', 'xxx'), '', "META type means "); is($fid->('SCALAR', '$*'), '$*', "SCALAR type means ID is unchanged"); is($fid->('HASH', 'xxx'), '{xxx}', "HASH type means ID is wrapped in {}"); is($fid->('ARRAY', '12'), '[12]', "ARRAY type means ID is wrapped in []"); is($fid->('METHOD', 'foo'), 'foo()', "METHOD type gets () postfix"); }; subtest _arrow_id => sub { my $aid = $CLASS->can('_arrow_id'); is($aid->('xxx', undef), ' ', "undef gets a space, not an arrow"); is($aid->('xxx', 'META'), ' ', "Meta gets a space, not an arrow"); is($aid->('xxx', 'METHOD'), '->', "Method always needs an arrow"); is($aid->('xxx', 'SCALAR'), '->', "Scalar always needs an arrow"); is($aid->('xxx', 'HASH'), '->', "Hash usually needs an arrow"); is($aid->('xxx', 'ARRAY'), '->', "Array usually needs an arrow"); is($aid->('{xxx}', 'HASH'), '', "Hash needs no arrow after hash"); is($aid->('{xxx}', 'ARRAY'), '', "Array needs no arrow after hash"); is($aid->('[xxx]', 'HASH'), '', "Hash needs no arrow after array"); is($aid->('[xxx]', 'ARRAY'), '', "Array needs no arrow after array"); is($aid->('', 'xxx'), '->', "Need an arrow after meta, or after a method"); is($aid->('xxx()', 'xxx'), '->', "Need an arrow after meta, or after a method"); is($aid->('$VAR', 'xxx'), '->', "Need an arrow after the initial ref"); is($aid->('xxx', ''), ' ', "space"); is($aid->('', ''), '', "No arrow needed"); }; subtest _join_id => sub { my $jid = $CLASS->can('_join_id'); is($jid->('{path}', [undef, 'id']), "{path} ", "Hash + undef"); is($jid->('[path]', [undef, 'id']), "[path] ", "Array + undef"); is($jid->('path', [undef, 'id']), "path ", "path + undef"); is($jid->('', [undef, 'id']), " ", "meta + undef"); is($jid->('path()', [undef, 'id']), "path() ", "meth + undef"); is($jid->('$VAR', [undef, 'id']), '$VAR ', '$VAR + undef'); is($jid->('', [undef, 'id']), "", "empty + undef"); is($jid->('{path}', ['META', 'id']), "{path} ", "hash + meta"); is($jid->('[path]', ['META', 'id']), "[path] ", "array + meta"); is($jid->('path', ['META', 'id']), "path ", "path + meta"); is($jid->('', ['META', 'id']), " ", "meta + meta"); is($jid->('path()', ['META', 'id']), "path() ", "meth + meta"); is($jid->('$VAR', ['META', 'id']), '$VAR ', '$VAR + meta'); is($jid->('', ['META', 'id']), "", "empty + meta"); is($jid->('{path}', ['SCALAR', '$*']), '{path}->$*', "Hash + scalar"); is($jid->('[path]', ['SCALAR', '$*']), '[path]->$*', "Array + scalar"); is($jid->('path', ['SCALAR', '$*']), 'path->$*', "Path + scalar"); is($jid->('', ['SCALAR', '$*']), '->$*', "Meta + scalar"); is($jid->('path()', ['SCALAR', '$*']), 'path()->$*', "Meth + scalar"); is($jid->('$VAR', ['SCALAR', '$*']), '$VAR->$*', '$VAR + scalar'); is($jid->('', ['SCALAR', '$*']), '$*', "Empty + scalar"); is($jid->('{path}', ['HASH', 'id']), "{path}{id}", "Hash + hash"); is($jid->('[path]', ['HASH', 'id']), "[path]{id}", "Array + hash"); is($jid->('path', ['HASH', 'id']), "path->{id}", "Path + hash"); is($jid->('', ['HASH', 'id']), "->{id}", "Meta + hash"); is($jid->('path()', ['HASH', 'id']), "path()->{id}", "Meth + hash"); is($jid->('$VAR', ['HASH', 'id']), '$VAR->{id}', '$VAR + hash'); is($jid->('', ['HASH', 'id']), "{id}", "Empty + hash"); is($jid->('{path}', ['ARRAY', '12']), "{path}[12]", "Hash + array"); is($jid->('[path]', ['ARRAY', '12']), "[path][12]", "Array + array"); is($jid->('path', ['ARRAY', '12']), "path->[12]", "Path + array"); is($jid->('', ['ARRAY', '12']), "->[12]", "Meta + array"); is($jid->('path()', ['ARRAY', '12']), "path()->[12]", "Meth + array"); is($jid->('$VAR', ['ARRAY', '12']), '$VAR->[12]', '$VAR + array'); is($jid->('', ['ARRAY', '12']), "[12]", "Empty + array"); is($jid->('{path}', ['METHOD', 'id']), "{path}->id()", "Hash + method"); is($jid->('[path]', ['METHOD', 'id']), "[path]->id()", "Array + method"); is($jid->('path', ['METHOD', 'id']), "path->id()", "Path + method"); is($jid->('', ['METHOD', 'id']), "->id()", "Meta + method"); is($jid->('path()', ['METHOD', 'id']), "path()->id()", "Meth + method"); is($jid->('$VAR', ['METHOD', 'id']), '$VAR->id()', '$VAR + method'); is($jid->('', ['METHOD', 'id']), "id()", "Empty + method"); }; subtest should_show => sub { my $one = $CLASS->new(verified => 0); ok($one->should_show, "not verified, always show"); $one->set_verified(1); ok(!$one->should_show, "verified, do not show"); my $check = Test2::Compare::String->new(input => 'xyz'); $one->set_chk($check); ok(!$one->should_show, "verified, check is uninteresting"); $check->set_lines([1,2]); ok(!$one->should_show, "verified, check has lines but no file"); $check->set_file('foo'); ok(!$one->should_show, "verified, check has lines different file"); $check->set_file(__FILE__); ok($one->should_show, "Have lines and same file, should show for debug purposes"); }; subtest filter_visible => sub { my $root = $CLASS->new(verified => 1); my $child1 = $CLASS->new(verified => 0, id => [HASH => 'a']); my $child2 = $CLASS->new(verified => 1, id => [HASH => 'b']); my $grand1 = $CLASS->new(verified => 0, id => [ARRAY => 0], children => []); my $grand2 = $CLASS->new(verified => 0, id => [ARRAY => 1], children => []); $root->set_children([$child1, $child2]); $child2->set_children([$grand1, $grand2]); is( $root->filter_visible, [ ['{a}', $child1], ['{b}[0]', $grand1], ['{b}[1]', $grand2], ], "Got visible ones" ); }; subtest table_header => sub { is($CLASS->table_header, [qw/PATH LNs GOT OP CHECK LNs/], "got header"); }; subtest table_op => sub { my $one = $CLASS->new(verified => 0); is($one->table_op, '!exists', "no op if there is no check"); my $check = Test2::Compare::String->new(input => 'xyz'); $one->set_chk($check); $one->set_got('foo'); is($one->table_op, 'eq', "got op"); $one->set_dne('anything'); is($one->table_op, 'eq', "got op when dne is set to something other than 'got'"); $one->set_dne('got'); is($one->table_op, '', "Called check->operator without args since dne is 'got'"); }; subtest table_check_lines => sub { my $one = $CLASS->new(verified => 0); is($one->table_check_lines, '', 'no lines without a check'); my $check = Test2::Compare::String->new(input => 'xyz'); $one->set_chk($check); is($one->table_check_lines, '', 'check has no lines'); $check->set_lines([]); is($one->table_check_lines, '', 'check has lines, but it is empty'); $check->set_lines([2, 4, 6]); is($one->table_check_lines, '2, 4, 6', 'got lines'); }; subtest table_got_lines => sub { my $one = $CLASS->new(verified => 0); is($one->table_got_lines, '', "no lines without a check"); my $check = Test2::Compare::String->new(input => 'xyz'); $one->set_chk($check); $one->set_dne('got'); is($one->table_got_lines, '', "no lines when 'got' is dne"); $one->set_dne('anything'); is($one->table_got_lines, '', "no lines found with other dne"); $one->set_dne(''); is($one->table_got_lines, '', "no lines found by check"); my $c = mock 'Test2::Compare::Base' => ( override => [ got_lines => sub {(2, 4, 6)}, ], ); is($one->table_got_lines, '2, 4, 6', "got lines"); }; subtest table_rows => sub { my $one = $CLASS->new(verified => 0); # These are tested above, mocking here for simplicity my $mock = mock $CLASS => ( override => [ filter_visible => sub { [['{foo}', $one], ['{bar}', $one]] }, render_check => sub { 'CHECK!' }, render_got => sub { 'GOT!' }, table_op => sub { 'OP!' }, table_check_lines => sub { 'CHECK LINES!' }, table_got_lines => sub { 'GOT LINES!' }, ], ); my $rows = $one->table_rows; $mock = undef; is( $rows, [ ['{foo}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], ['{bar}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], ], "got rows" ); }; subtest table => sub { local $ENV{TS_MAX_DELTA} = 10; my $rows; my $mock = mock $CLASS => (override => [table_rows => sub { return $rows }]); my $one = $CLASS->new(); $rows = [ ['{foo}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], ['{bar}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], ['{baz}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], ['{bat}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], ]; def is => ( [split /\n/, $one->table->as_string], [ '+-------+------------+------+-----+--------+--------------+', '| PATH | LNs | GOT | OP | CHECK | LNs |', '+-------+------------+------+-----+--------+--------------+', '| {foo} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |', '| {bar} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |', '| {baz} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |', '| {bat} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |', '+-------+------------+------+-----+--------+--------------+', ], "Got expected table" ); $rows = [ ['{foo}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], ['{bar}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], ['{baz}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], ['{bat}', 'GOT LINES!', 'GOT!', 'OP!', 'CHECK!', 'CHECK LINES!'], ]; $ENV{TS_MAX_DELTA} = 2; def is => ( [split /\n/, $one->table->as_string], [ '+-------+------------+------+-----+--------+--------------+', '| PATH | LNs | GOT | OP | CHECK | LNs |', '+-------+------------+------+-----+--------+--------------+', '| {foo} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |', '| {bar} | GOT LINES! | GOT! | OP! | CHECK! | CHECK LINES! |', '+-------+------------+------+-----+--------+--------------+', '************************************************************', '* Stopped after 2 differences. *', '* Set the TS_MAX_DELTA environment var to raise the limit. *', '* Set it to 0 for no limit. *', '************************************************************', ], "Got expected table and warning" ); $ENV{TS_MAX_DELTA} = 25; $rows = [ ['{foo}', '', '', '', '', ''], ['{bar}', '', '', '', '', ''], ['{baz}', '', '', '', '', ''], ['{bat}', '', '', '', '', ''], ]; def is => ( [split /\n/, $one->table->as_string], [ '+-------+-----+-------+', '| PATH | GOT | CHECK |', '+-------+-----+-------+', '| {foo} | | |', '| {bar} | | |', '| {baz} | | |', '| {bat} | | |', '+-------+-----+-------+', ], "'GOT' and 'CHECK' never collapse" ); $mock = undef; delete $ENV{TS_MAX_DELTA}; do_def(); }; subtest custom_columns => sub { my $conv = Test2::Compare->can('strict_convert'); my $comp = Test2::Compare->can('compare'); my $cmp = sub { my $ctx = context(); my $delta = $comp->(@_, $conv); my $table = $delta->table; $ctx->release; return [split /\n/, $table->as_string]; }; $CLASS->add_column('V' => sub { my ($d) = @_; return $d->verified ? '*' : ''; }); my $table = $cmp->( { foo => ['x', 'y'] }, hash { field foo => array { item 'a'; item 'b'; }; }, ); like( $table, [ qr/\Q+---+\E$/, qr/\Q| V |\E$/, qr/\Q+---+\E$/, qr/\Q| * |\E$/, qr/\Q| * |\E$/, qr/\Q| |\E$/, qr/\Q| |\E$/, qr/\Q+---+\E$/, DNE() ], "Got new column, it is last" ); $table = $cmp->( ['x', 'y'], ['a', 'b'], ); is($table->[1], mismatch qr/\Q| V |\E/, "Column not shown, it is empty"); is($CLASS->remove_column('V'), 1, "Removed the column"); is($CLASS->remove_column('V'), 0, "No column to remove"); $CLASS->add_column( 'V', value => sub { my ($d) = @_; return $d->verified ? '*' : ''; }, alias => '?', no_collapse => 1, prefix => 1, ); $table = $cmp->( { foo => ['x', 'y'] }, hash { field foo => array { item 'a'; item 'b'; }; }, ); like( $table, [ qr/^\Q+---+\E/, qr/^\Q| ? |\E/, qr/^\Q+---+\E/, qr/^\Q| * |\E/, qr/^\Q| * |\E/, qr/^\Q| |\E/, qr/^\Q| |\E/, qr/^\Q+---+\E/, DNE() ], "Got new column, it is first" ); $table = $cmp->( ['x', 'y'], ['a', 'b'], ); like( $table, [ qr/^\Q+---+\E/, qr/^\Q| ? |\E/, qr/^\Q+---+\E/, qr/^\Q| |\E/, qr/^\Q| |\E/, qr/^\Q+---+\E/, DNE() ], "Did not collapse" ); is($CLASS->remove_column('V'), 1, "Removed the column"); is($CLASS->remove_column('V'), 0, "No column to remove"); like( dies { $CLASS->add_column }, qr/Column name is required/, "Column name is required" ); like( dies { $CLASS->add_column('FOO') }, qr/You must specify a 'value' callback/, "Need value callback" ); like( dies { $CLASS->add_column('FOO', 'foo') }, qr/'value' callback must be a CODE reference/, "Need value callback" ); $CLASS->add_column('FOO' => sub { '' }); like( dies { $CLASS->add_column('FOO' => sub { '' }) }, qr/Column 'FOO' is already defined/, "No duplicates" ); is($CLASS->remove_column('FOO'), 1, "Removed the column"); }; subtest set_column_alias => sub { $CLASS->set_column_alias(PATH => ' '); is( $CLASS->table_header, [' ', qw/LNs GOT OP CHECK LNs/], "hide column name" ); $CLASS->set_column_alias(GLNs => 'Now This'); is( $CLASS->table_header, [' ', 'Now This', qw/GOT OP CHECK LNs/], "column name with spaces" ); $CLASS->add_column('NEW' => sub { '' }); $CLASS->set_column_alias(NEW => 'OLD'); is( $CLASS->table_header, [' ', 'Now This', qw/GOT OP CHECK LNs OLD/], "change added column name" ); like( dies { $CLASS->set_column_alias('OP') }, qr/Missing alias/, 'Missing alias' ); like( dies { $CLASS->set_column_alias(DNE => 'NOPE') }, qr/Tried to alias a non-existent column/, 'Needs existing column name' ); }; subtest overload => sub { no warnings 'once'; { package Overload::Foo; use overload '""' => sub { 'FOO' }, '0+' => sub { 42 }; package Overload::Bar; use overload '""' => sub { 'BAR' }, '0+' => sub { 99 }; } my $foo = bless \*FOO, 'Overload::Foo'; my $bar = bless \*BAR, 'Overload::Bar'; is("$foo", "FOO", "overloaded string form FOO"); is("$bar", "BAR", "overloaded string form BAR"); is(int($foo), 42, "overloaded number form FOO"); is(int($bar), 99, "overloaded number form BAR"); my $conv = Test2::Compare->can('strict_convert'); my $comp = Test2::Compare->can('compare'); my $cmp = sub { my $ctx = context(); my $delta = $comp->(@_, $conv); my $table = $delta->table; $ctx->release; return [split /\n/, $table->as_string]; }; my $table = $cmp->($foo, $bar); # On some systems the memory address is long enough to cause this to wrap. my @checks; if (@$table == 5) { @checks = ( qr/^\| Overload::Foo=GLOB\(.+\)\s+\| ==\s+\| Overload::Bar=GLOB\(.+\)\s+\|$/, ); } else { @checks = ( qr/^\| Overload::Foo=GLOB\(.+\s+\| ==\s+\| Overload::Bar=GLOB\(.+\s+\|$/, qr/^\| .*\)\s+\| \s+\| .*\)\s+\|$/, ); } like( $table, [ T(), # Border T(), # Header T(), # Border @checks, T(), # Border DNE(), # END ], "Showed type+mem address, despire overloading" ); }; done_testing; Test2-Suite-0.000129/t/modules/Compare/Array.t0000644000175000017500000001526013615053353020531 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Array'; use lib 't/lib'; isa_ok($CLASS, 'Test2::Compare::Base'); is($CLASS->name, '', "got name"); subtest construction => sub { my $one = $CLASS->new(); isa_ok($one, $CLASS); is($one->items, {}, "created items as a hash"); is($one->order, [], "created order as an array"); $one = $CLASS->new(items => { 1 => 'a', 2 => 'b' }); is($one->items, { 1 => 'a', 2 => 'b' }, "used items as specified"); is($one->order, [ 1, 2 ], "generated order"); like( dies { $CLASS->new(items => { a => 1, b => 2 }) }, qr/All indexes listed in the 'items' hashref must be numeric/, "Indexes must be numeric" ); like( dies { $CLASS->new(items => {}, order => [ 'a' ]) }, qr/All indexes listed in the 'order' arrayref must be numeric/, "Indexes must be numeric" ); $one = $CLASS->new(inref => ['a', 'b']); is($one->items, { 0 => 'a', 1 => 'b' }, "Generated items"); is($one->order, [ 0, 1 ], "generated order"); like( dies { $CLASS->new(inref => [ 'a' ], items => { 0 => 'a' }) }, qr/Cannot specify both 'inref' and 'items'/, "Cannot specify inref and items" ); like( dies { $CLASS->new(inref => [ 'a' ], order => [ 0 ]) }, qr/Cannot specify both 'inref' and 'order'/, "Cannot specify inref and order" ); like( dies { $CLASS->new(inref => { 1 => 'a' }) }, qr/'inref' must be an array reference, got 'HASH\(.+\)'/, "inref must be an array" ); }; subtest verify => sub { my $one = $CLASS->new; is($one->verify(exists => 0), 0, "did not get anything"); is($one->verify(exists => 1, got => undef), 0, "undef is not an array"); is($one->verify(exists => 1, got => 0), 0, "0 is not an array"); is($one->verify(exists => 1, got => 1), 0, "1 is not an array"); is($one->verify(exists => 1, got => 'string'), 0, "'string' is not an array"); is($one->verify(exists => 1, got => {}), 0, "a hash is not an array"); is($one->verify(exists => 1, got => []), 1, "an array is an array"); }; subtest top_index => sub { my $one = $CLASS->new; is($one->top_index, undef, "no indexes"); $one = $CLASS->new(inref => [ 'a', 'b', 'c' ]); is($one->top_index, 2, "got top index"); $one = $CLASS->new(inref => [ 'a' ]); is($one->top_index, 0, "got top index"); $one = $CLASS->new(inref => [ ]); is($one->top_index, undef, "no indexes"); $one = $CLASS->new(order => [ 0, 1, 2, sub { 1 }], items => { 0 => 'a', 1 => 'b', 2 => 'c' }); is($one->top_index, 2, "got top index, despite ref"); }; subtest add_item => sub { my $one = $CLASS->new(); $one->add_item('a'); $one->add_item(1 => 'b'); $one->add_item(3 => 'd'); like( dies { $one->add_item(2 => 'c') }, qr/elements must be added in order!/, "Items must be added in order" ); $one->add_item(8 => 'x'); $one->add_item('y'); is( $one->items, { 0 => 'a', 1 => 'b', 3 => 'd', 8 => 'x', 9 => 'y' }, "Expected items" ); is($one->order, [0, 1, 3, 8, 9], "got order"); }; subtest add_filter => sub { my $one = $CLASS->new; $one->add_item('a'); my $f = sub { grep { m/[a-z]/ } @_ }; $one->add_filter($f); $one->add_item('b'); like( dies { $one->add_filter }, qr/A single coderef is required/, "No filter specified" ); like( dies { $one->add_filter(1) }, qr/A single coderef is required/, "Not a valid filter" ); like( dies { $one->add_filter(undef) }, qr/A single coderef is required/, "Filter must be defined" ); like( dies { $one->add_filter(sub { 1 }, sub { 2 }) }, qr/A single coderef is required/, "Too many filters" ); like( dies { $one->add_filter({}) }, qr/A single coderef is required/, "Not a coderef" ); is( $one->order, [0, $f, 1], "added filter to order array"); }; subtest deltas => sub { my $conv = Test2::Compare->can('strict_convert'); my %params = (exists => 1, convert => $conv, seen => {}); my $inref = ['a', 'b']; my $one = $CLASS->new(inref => $inref); like( [$one->deltas(%params, got => ['a', 'b'])], [], "No delta, no diff" ); like( [$one->deltas(%params, got => ['a'])], [ { dne => 'got', id => [ARRAY => 1], got => undef, } ], "Got the delta for the missing value" ); like( [$one->deltas(%params, got => ['a', 'a'])], [ { dne => DNE, id => [ARRAY => 1], got => 'a', chk => {input => 'b'}, } ], "Got the delta for the incorrect value" ); like( [$one->deltas(%params, got => ['a', 'b', 'a', 'a'])], [], "No delta, not checking ending" ); $one->set_ending(1); like( [$one->deltas(%params, got => ['a', 'b', 'a', 'x'])], array { item 0 => { dne => 'check', id => [ARRAY => 2], got => 'a', check => DNE, }; item 1 => { dne => 'check', id => [ARRAY => 3], got => 'x', check => DNE, }; end(), }, "Got 2 deltas for extra items" ); $one = $CLASS->new(); $one->add_item('a'); $one->add_filter( sub { grep { m/[a-z]/ } @_; } ); $one->add_item('b'); is( [$one->deltas(%params, got => ['a', 1, 2, 'b'])], [], "Filter worked" ); like( [$one->deltas(%params, got => ['a', 1, 2, 'a'])], [ { dne => DNE, id => [ARRAY => 1], got => 'a', chk => {input => 'b'}, } ], "Filter worked, but input is still wrong" ); }; { package Foo::Array; use base 'MyTest::Target'; sub new { my $class = shift; bless [ @_ ] , $class; } } subtest objects_as_arrays => sub { my $o1 = Foo::Array->new( 'b' ) ; my $o2 = Foo::Array->new( 'b' ) ; is ( $o1, $o2, "same" ); }; subtest add_prop => sub { my $one = $CLASS->new(); ok(!$one->meta, "no meta yet"); $one->add_prop('size' => 1); isa_ok($one->meta, 'Test2::Compare::Meta'); is(@{$one->meta->items}, 1, "1 item"); $one->add_prop('reftype' => 'ARRAY'); is(@{$one->meta->items}, 2, "2 items"); }; done_testing; Test2-Suite-0.000129/t/modules/Compare/Event.t0000644000175000017500000000117513615053353020534 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Event'; my $one = $CLASS->new(etype => 'Ok'); is($one->name, '', "got name"); is($one->meta_class, 'Test2::Compare::EventMeta', "correct meta class"); is($one->object_base, 'Test2::Event', "Event is the base class"); my $trace = Test2::Util::Trace->new(frame => ['Foo', 'foo.t', 42, 'foo']); my $Ok = Test2::Event::Ok->new(trace => $trace, pass => 1); is($one->got_lines(), undef, "no lines"); is($one->got_lines('xxx'), undef, "no lines"); is($one->got_lines(bless {}, 'XXX'), undef, "no lines"); is($one->got_lines($Ok), 42, "got the correct line"); done_testing; Test2-Suite-0.000129/t/modules/Compare/Bool.t0000644000175000017500000000051713615053353020345 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Bool'; my $one = $CLASS->new(input => 'foo'); is($one->name, '', "Got name"); is($one->operator, '==', "Got operator"); $one = $CLASS->new(input => 0, negate => 1); is($one->name, '', "Got name"); is($one->operator, '!=', "Got operator"); done_testing; Test2-Suite-0.000129/t/modules/Compare/Hash.t0000644000175000017500000001304613615053353020336 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Hash'; use lib 't/lib'; subtest simple => sub { my $one = $CLASS->new(); isa_ok($one, $CLASS, 'Test2::Compare::Base'); is($one->name, '', "name is "); }; subtest verify => sub { my $one = $CLASS->new(); ok(!$one->verify(exists => 0), "nothing to verify"); ok(!$one->verify(exists => 1, got => undef), "undef is not a hashref"); ok(!$one->verify(exists => 1, got => 1), "1 is not a hashref"); ok(!$one->verify(exists => 1, got => []), "An arrayref is not a hashref"); ok($one->verify(exists => 1, got => {}), "got a hashref"); }; subtest init => sub { my $one = $CLASS->new(); ok( defined $one, "args are not required"); is($one->items, {}, "got the items hash"); is($one->order, [], "got order array"); $one = $CLASS->new(inref => { a => 1, b => 2 }); is($one->items, {a => 1, b => 2}, "got the items hash"); is($one->order, ['a', 'b'], "generated order (ascii sort)"); $one = $CLASS->new(items => { a => 1, b => 2 }, order => [ 'b', 'a' ]); is($one->items, {a => 1, b => 2}, "got the items hash"); is($one->order, ['b', 'a'], "got specified order"); $one = $CLASS->new(items => { a => 1, b => 2 }); is($one->items, {a => 1, b => 2}, "got the items hash"); is($one->order, ['a', 'b'], "generated order (ascii sort)"); like( dies { $CLASS->new(inref => {a => 1}, items => {a => 1}) }, qr/Cannot specify both 'inref' and 'items'/, "inref and items are exclusive" ); like( dies { $CLASS->new(inref => {a => 1}, order => ['a']) }, qr/Cannot specify both 'inref' and 'order'/, "inref and order are exclusive" ); like( dies { $CLASS->new(items => { a => 1, b => 2, c => 3 }, order => ['a']) }, qr/Keys are missing from the 'order' array: b, c/, "Missing fields in order" ); }; subtest add_field => sub { my $one = $CLASS->new(); $one->add_field(a => 1); $one->add_field(c => 3); $one->add_field(b => 2); like( dies { $one->add_field(undef, 'x') }, qr/field name is required/, "Must specify a field name" ); like( dies { $one->add_field(a => 1) }, qr/field 'a' has already been specified/, "Cannot add field twice" ); is($one->items, { a => 1, b => 2, c => 3 }, "added items"); is($one->order, [ 'a', 'c', 'b' ], "order preserved"); }; subtest deltas => sub { my $convert = Test2::Compare->can('strict_convert'); my %params = (exists => 1, convert => $convert, seen => {}); my $one = $CLASS->new(inref => {a => 1, b => 2, c => 3, x => DNE()}); is( [$one->deltas(got => {a => 1, b => 2, c => 3}, %params)], [], "No deltas, perfect match" ); is( [$one->deltas(got => {a => 1, b => 2, c => 3, e => 4, f => 5}, %params)], [], "No deltas, extra items are ok" ); $one->set_ending(1); is( [$one->deltas(got => {a => 1, b => 2, c => 3, e => 4, f => 5}, %params)], [ { dne => 'check', verified => F(), id => [HASH => 'e'], got => 4, chk => F(), }, { dne => 'check', verified => F(), id => [HASH => 'f'], got => 5, chk => F(), }, ], "Extra items are no longer ok, problem" ); is( [$one->deltas(got => {a => 1}, %params)], [ { children => [], dne => 'got', verified => F(), id => [HASH => 'b'], got => F(), chk => T(), }, { children => [], dne => 'got', verified => F(), id => [HASH => 'c'], got => F(), chk => T(), }, ], "Missing items" ); is( [$one->deltas(got => {a => 1, b => 1, c => 1}, %params)], [ { children => [], verified => F(), id => [HASH => 'b'], got => 1, chk => T(), }, { children => [], verified => F(), id => [HASH => 'c'], got => 1, chk => T(), }, ], "Items are wrong" ); like( [$one->deltas(got => {a => 1, b => 2, c => 3, x => 'oops'}, %params)], [ { verified => F(), id => [HASH => 'x'], got => 'oops', check => DNE(), }, ], "Items are wrong" ); }; subtest add_prop => sub { my $one = $CLASS->new(); ok(!$one->meta, "no meta yet"); $one->add_prop('size' => 1); isa_ok($one->meta, 'Test2::Compare::Meta'); is(@{$one->meta->items}, 1, "1 item"); $one->add_prop('reftype' => 'HASH'); is(@{$one->meta->items}, 2, "2 items"); }; { package Foo::Hash; use base 'MyTest::Target'; sub new { my $class = shift; bless { @_ } , $class; } } subtest objects_with_hashes => sub { my $o1 = Foo::Hash->new( b => { foo => 2 } ) ; my $o2 = Foo::Hash->new( b => { foo => 2 } ) ; is ( $o1, $o2, "same" ); }; done_testing; Test2-Suite-0.000129/t/modules/Compare/Meta.t0000644000175000017500000000425013615053353020336 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Meta'; local *convert = Test2::Compare->can('strict_convert'); subtest simple => sub { my $one = $CLASS->new(); isa_ok($one, $CLASS, 'Test2::Compare::Base'); is($one->items, [], "generated an empty items array"); is($one->name, '', "sane name"); is($one->verify(exists => 0), 0, "Does not verify for non-existant values"); is($one->verify(exists => 1), 1, "always verifies for existing values"); ok(defined $CLASS->new(items => []), "Can provide items"); }; subtest add_prop => sub { my $one = $CLASS->new(); like( dies { $one->add_prop(undef, convert(1)) }, qr/prop name is required/, "property name is required" ); like( dies { $one->add_prop('fake' => convert(1)) }, qr/'fake' is not a known property/, "Must use valid property" ); like( dies { $one->add_prop('blessed') }, qr/check is required/, "Must use valid property" ); ok($one->add_prop('blessed' => convert('xxx')), "normal"); }; subtest deltas => sub { my $one = $CLASS->new(); my $it = bless {a => 1, b => 2, c => 3}, 'Foo'; $one->add_prop('blessed' => 'Foo'); $one->add_prop('reftype' => 'HASH'); $one->add_prop('this' => exact_ref($it)); $one->add_prop('size' => 3); is( [$one->deltas(got => $it, convert => \&convert, seen => {})], [], "Everything matches" ); my $not_it = bless ['a'], 'Bar'; like( [$one->deltas(got => $not_it, convert => \&convert, seen => {})], [ { verified => F(), got => 'Bar' }, { verified => F(), got => 'ARRAY' }, { verified => F(), got => $not_it }, { verified => F(), got => 1 }, ], "Nothing matches" ); like( [$one->deltas(got => 'a', convert => \&convert, seen => {})], [ { verified => F(), got => undef }, { verified => F(), got => undef }, { verified => F(), got => 'a' }, { verified => F(), got => undef }, ], "Nothing matches, wrong everything" ); }; done_testing; Test2-Suite-0.000129/t/modules/Compare/Base.t0000644000175000017500000000261513615053353020325 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Base'; my $one = $CLASS->new(); isa_ok($one, $CLASS); is($one->delta_class, 'Test2::Compare::Delta', "Got expected delta class"); is([$one->deltas], [], "no deltas"); is([$one->got_lines], [], "no lines"); is($one->operator, '', "no default operator"); like(dies { $one->verify }, qr/unimplemented/, "unimplemented"); like(dies { $one->name }, qr/unimplemented/, "unimplemented"); { no warnings 'redefine'; *Test2::Compare::Base::name = sub { 'bob' }; *Test2::Compare::Base::verify = sub { shift; my %p = @_; $p{got} eq 'xxx' }; } is($one->render, 'bob', "got name"); is( [$one->run(id => 'xxx', got => 'xxx', convert => sub { $_[-1] }, seen => {})], [], "Valid" ); is( [$one->run(id => [META => 'xxx'], got => 'xxy', convert => sub { $_[-1] }, seen => {})], [ { verified => '', id => [META => 'xxx'], got => 'xxy', chk => {%$one}, children => [], } ], "invalid" ); $one = $CLASS->new; is($one->lines, [], "no lines"); my $line1 = __LINE__ + 1; $one = $CLASS->new(builder => sub { print "A"; print "B"; }); my $line2 = __LINE__ - 1; is($one->lines, [$line1, $line2], "got lines from builder."); $one = $CLASS->new(called => ['foo', 'bar', 42]); is($one->lines, [42], "got line from caller"); done_testing; Test2-Suite-0.000129/t/modules/Compare/Ref.t0000644000175000017500000000160013615053353020160 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Ref'; my $ref = sub { 1 }; my $one = $CLASS->new(input => $ref); isa_ok($one, $CLASS, 'Test2::Compare::Base'); like($one->name, qr/CODE\(.*\)/, "Got Name"); is($one->operator, '==', "got operator"); ok($one->verify(exists => 1, got => $ref), "verified ref"); ok(!$one->verify(exists => 1, got => sub { 1 }), "different ref"); ok(!$one->verify(exists => 0, got => $ref), "value must exist"); is( [ 'a', $ref ], [ 'a', $one ], "Did a ref check" ); ok(!$one->verify(exists => 1, got => 'a'), "not a ref"); $one->set_input('a'); ok(!$one->verify(exists => 1, got => $ref), "input not a ref"); like( dies { $CLASS->new() }, qr/'input' is a required attribute/, "Need input" ); like( dies { $CLASS->new(input => 'a') }, qr/'input' must be a reference, got 'a'/, "Input must be a ref" ); done_testing; Test2-Suite-0.000129/t/modules/Compare/Bag.t0000644000175000017500000001001713615053353020137 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Bag'; isa_ok($CLASS, 'Test2::Compare::Base'); is($CLASS->name, '', "got name"); subtest construction => sub { my $one = $CLASS->new(); isa_ok($one, $CLASS); is($one->items, [], "created items as an array"); }; subtest verify => sub { my $one = $CLASS->new; is($one->verify(exists => 0), 0, "did not get anything"); is($one->verify(exists => 1, got => undef), 0, "undef is not an array"); is($one->verify(exists => 1, got => 0), 0, "0 is not an array"); is($one->verify(exists => 1, got => 1), 0, "1 is not an array"); is($one->verify(exists => 1, got => 'string'), 0, "'string' is not an array"); is($one->verify(exists => 1, got => {}), 0, "a hash is not an array"); is($one->verify(exists => 1, got => []), 1, "an array is an array"); }; subtest add_item => sub { my $one = $CLASS->new(); $one->add_item('a'); $one->add_item(1 => 'b'); $one->add_item(3 => 'd'); ok( lives { $one->add_item(2 => 'c') }, "Indexes are ignored", ); $one->add_item(8 => 'x'); $one->add_item('y'); is( $one->items, [ 'a', 'b', 'd', 'c', 'x', 'y' ], "Expected items", ); }; subtest deltas => sub { my $conv = Test2::Compare->can('strict_convert'); my %params = (exists => 1, convert => $conv, seen => {}); my $items = ['a', 'b']; my $one = $CLASS->new(items => $items); like( [$one->deltas(%params, got => ['a', 'b'])], [], "No delta, no diff" ); like( [$one->deltas(%params, got => ['b', 'a'])], [], "No delta, no diff, order is ignored" ); like( [$one->deltas(%params, got => ['a'])], [ { dne => 'got', id => [ARRAY => '*'], got => undef,, chk => {input => 'b'}, } ], "Got the delta for the missing value" ); like( [$one->deltas(%params, got => ['a', 'a'])], [ { dne => 'got', id => [ARRAY => '*'], got => undef, chk => {input => 'b'}, } ], "Got the delta for the incorrect value" ); like( [$one->deltas(%params, got => ['a', 'b', 'a', 'a'])], [], "No delta, not checking ending" ); $one->set_ending(1); like( [$one->deltas(%params, got => ['a', 'b', 'a', 'x'])], array { item 0 => { dne => 'check', id => [ARRAY => 2], got => 'a', check => DNE, }; item 1 => { dne => 'check', id => [ARRAY => 3], got => 'x', check => DNE, }; end(), }, "Got 2 deltas for extra items" ); subtest 'duplicate items' => sub { my $items = ['a', 'a']; my $one = $CLASS->new(items => $items); like( [$one->deltas(%params, got => ['a', 'a'])], [], "No delta, no diff" ); like( [$one->deltas(%params, got => ['a', 'a', 'a'])], [], "No delta, not checking ending" ); $one->set_ending(1); like( [$one->deltas(%params, got => ['a', 'a', 'a'])], array { item 0 => { dne => 'check', id => [ARRAY => 2], got => 'a', check => DNE, }; end(), }, "Got the delta for extra item" ); }; }; subtest add_prop => sub { my $one = $CLASS->new(); ok(!$one->meta, "no meta yet"); $one->add_prop('size' => 1); isa_ok($one->meta, 'Test2::Compare::Meta'); is(@{$one->meta->items}, 1, "1 item"); $one->add_prop('reftype' => 'ARRAY'); is(@{$one->meta->items}, 2, "2 items"); }; done_testing; Test2-Suite-0.000129/t/modules/Compare/Set.t0000644000175000017500000001056613615053353020212 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Set'; subtest construction => sub { my $one = $CLASS->new(); isa_ok($one, 'Test2::Compare::Base', $CLASS); is($one->reduction, 'any', "default to 'any'"); is($one->checks, [], "default to empty list of checks"); is($one->name, '', "got name"); is($one->operator, 'any', "got op"); $one = $CLASS->new(checks => [ 'a', 'b' ], reduction => 'all'); isa_ok($one, 'Test2::Compare::Base', $CLASS); is($one->reduction, 'all', "specified reduction"); is($one->checks, ['a', 'b'], "specified checks"); is($one->name, '', "got name"); is($one->operator, 'all', "got op"); like( dies { $CLASS->new(reduction => 'fake') }, qr/'fake' is not a valid set reduction/, "Need a valid reduction", ); }; subtest set_reduction => sub { my $one = $CLASS->new(); is($one->reduction, 'any', "default"); $one->set_reduction('all'); is($one->reduction, 'all', "changed"); like( dies { $one->set_reduction('fake') }, qr/'fake' is not a valid set reduction/, "Need a valid reduction", ); }; subtest verify => sub { my $one = $CLASS->new(); is($one->verify(exists => 1), 1, "valid"); # in_set(DNE) is a valid construct, so we cannot reject non-existing values. is($one->verify(exists => 0), 1, "valid"); }; subtest add_check => sub { my $one = $CLASS->new(checks => ['a']); $one->add_check('b'); $one->add_check(match qr/xxx/); is( $one->checks, [ 'a', 'b', meta { prop blessed => 'Test2::Compare::Pattern' } ], "Added the checks" ); }; subtest deltas => sub { my $one; my $after_each = sub { $one->set_checks(undef); is( dies { $one->deltas() }, "No checks defined for set\n", "Need checks list" ); $one->set_checks([]); $one->set_file(__FILE__); my $file = __FILE__; is( dies { $one->deltas() }, "No checks defined for set\n", "Need checks in list" ); $one->set_checks(undef); $one->set_lines([__LINE__]); my $line1 = __LINE__; is( dies { $one->deltas() }, "No checks defined for set (Set defined in $file line $line1)\n", "Need checks list, have file+line" ); $one->set_checks([]); push @{$one->lines} => __LINE__; my $line2 = __LINE__; is( dies { $one->deltas() }, "No checks defined for set (Set defined in $file lines $line1, $line2)\n", "Need checks in list, have file + 2 lines" ); }; subtest any => sub { $one = $CLASS->new(reduction => 'any'); $one->add_check(match qr/a/); $one->add_check(match qr/b/); $one->add_check(match qr/c/); is('xax', $one, "matches 'a'"); is('xbx', $one, "matches 'b'"); is('xcx', $one, "matches 'c'"); is([$one->deltas(got => 'a', exists => 1, seen => {}, convert => sub { $_[0] })], [], "no deltas with 'a'"); is([$one->deltas(got => 'b', exists => 1, seen => {}, convert => sub { $_[0] })], [], "no deltas with 'b'"); is([$one->deltas(got => 'c', exists => 1, seen => {}, convert => sub { $_[0] })], [], "no deltas with 'c'"); like( [$one->deltas(got => 'x', exists => 1, seen => {}, convert => sub { $_[0] })], [{ got => 'x' }, { got => 'x' }, { got => 'x' }, DNE], "no matches, 3 deltas, one per check" ); $after_each->(); }; subtest all => sub { $one = $CLASS->new(reduction => 'all'); $one->add_check(mismatch qr/x/); $one->add_check(match qr/fo/); $one->add_check(match qr/oo/); is('foo', $one, "matches all 3"); is([$one->deltas(got => 'foo', exists => 1, seen => {}, convert => sub { $_[0] })], [], "no deltas with 'foo'"); like( [$one->deltas(got => 'oo', exists => 1, seen => {}, convert => sub { $_[0] })], [{ got => 'oo' }, DNE], "1 delta, one failed check" ); like( [$one->deltas(got => 'fox', exists => 1, seen => {}, convert => sub { $_[0] })], [{ got => 'fox' }, { got => 'fox' }, DNE], "2 deltas, one per failed check" ); $after_each->(); }; }; done_testing; Test2-Suite-0.000129/t/modules/Bundle/0000755000175000017500000000000013615053353017105 5ustar exodistexodistTest2-Suite-0.000129/t/modules/Bundle/Extended.t0000644000175000017500000000512013615053353021030 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::API qw/test2_stack/; use PerlIO; # HARNESS-NO-FORMATTER imported_ok qw{ ok pass fail diag note todo skip plan skip_all done_testing bail_out gen_event intercept context cmp_ok subtest can_ok isa_ok DOES_ok set_encoding imported_ok not_imported_ok ref_ok ref_is ref_is_not mock mocked dies lives try_ok is like isnt unlike match mismatch validator hash array object meta number string bool in_set not_in_set check_set item field call call_list call_hash prop check all_items all_keys all_vals all_values etc end filter_items T F D DF E DNE FDNE U event fail_events exact_ref }; ok(Test2::Plugin::ExitSummary->active, "Exit Summary is loaded"); ok(defined(Test2::Plugin::SRand->seed), "SRand is loaded"); subtest strictures => sub { local $^H; my $hbefore = $^H; Test2::Bundle::Extended->import; my $hafter = $^H; my $strict = do { local $^H; strict->import(); $^H }; ok($strict, 'sanity, got $^H value for strict'); ok(!($hbefore & $strict), "strict is not on before loading Test2::Bundle::Extended"); ok(($hafter & $strict), "strict is on after loading Test2::Bundle::Extended"); }; subtest warnings => sub { local ${^WARNING_BITS}; my $wbefore = ${^WARNING_BITS} || ''; Test2::Bundle::Extended->import; my $wafter = ${^WARNING_BITS} || ''; my $warnings = do { local ${^WARNING_BITS}; 'warnings'->import(); ${^WARNING_BITS} || '' }; ok($warnings, 'sanity, got ${^WARNING_BITS} value for warnings'); ok($wbefore ne $warnings, "warnings are not on before loading Test2::Bundle::Extended") || diag($wbefore, "\n", $warnings); ok(($wafter & $warnings), "warnings are on after loading Test2::Bundle::Extended"); }; subtest utf8 => sub { ok(utf8::is_utf8("癸"), "utf8 pragma is on"); # -2 cause the subtest adds to the stack my $format = test2_stack()->[-2]->format; my $handles = $format->handles or return; for my $hn (0 .. @$handles) { my $h = $handles->[$hn] || next; my $layers = { map {$_ => 1} PerlIO::get_layers($h) }; ok($layers->{utf8}, "utf8 is on for formatter handle $hn"); } }; subtest "rename imports" => sub { package A::Consumer; use Test2::Bundle::Extended ':v1', '!subtest', subtest => {-as => 'a_subtest'}; imported_ok('a_subtest'); not_imported_ok('subtest'); }; subtest "no meta" => sub { package B::Consumer; use Test2::Bundle::Extended '!meta'; imported_ok('meta_check'); not_imported_ok('meta'); }; done_testing; 1; Test2-Suite-0.000129/t/modules/Bundle/Simple.t0000644000175000017500000000034013615053353020520 0ustar exodistexodistuse strict; use warnings; use Test2::Bundle::Simple; use Test2::Tools::Exports; imported_ok qw/ok plan done_testing skip_all/; ok(Test2::Plugin::ExitSummary->active, "Exit Summary is loaded"); done_testing; 1; __END__ Test2-Suite-0.000129/t/modules/Bundle/More.t0000644000175000017500000000053013615053353020172 0ustar exodistexodistuse strict; use warnings; use Test2::Bundle::More; use Test2::Tools::Exports; imported_ok 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 }; ok(Test2::Plugin::ExitSummary->active, "Exit Summary is loaded"); done_testing; 1; __END__ Test2-Suite-0.000129/t/modules/Plugin/0000755000175000017500000000000013615053353017132 5ustar exodistexodistTest2-Suite-0.000129/t/modules/Plugin/ExitSummary.t0000644000175000017500000000367613615053353021622 0ustar exodistexodistuse strict; use warnings; # HARNESS-NO-PRELOAD use Test2::API; my $initial_count; BEGIN { $initial_count = Test2::API::test2_list_exit_callbacks() } use Test2::Tools::Basic; use Test2::API qw/intercept context/; use Test2::Tools::Compare qw/array event end is like/; use Test2::Plugin::ExitSummary; use Test2::Plugin::ExitSummary; use Test2::Plugin::ExitSummary; my $post_count = Test2::API::test2_list_exit_callbacks(); is($initial_count, 0, "no hooks initially"); is($post_count, 1, "Added the hook, but only once"); my $summary = Test2::Plugin::ExitSummary->can('summary'); my $exit = 0; my $new = 0; like( intercept { my $ctx = context(level => -1); $summary->($ctx, $exit, \$new); $ctx->release; }, array { event Diag => {message => 'No tests run!'}; end }, "No tests run" ); like( intercept { plan 1; my $ctx = context(level => -1); $summary->($ctx, $exit, \$new); $ctx->release; }, array { event Plan => { max => 1 }; event Diag => {message => 'No tests run!'}; event Diag => {message => 'Did not follow plan: expected 1, ran 0.'}; end }, "No tests run, bad plan" ); like( intercept { ok(1); my $ctx = context(level => -1); $summary->($ctx, $exit, \$new); $ctx->release; }, array { event Ok => { pass => 1 }; event Diag => {message => 'Tests were run but no plan was declared and done_testing() was not seen.'}; end }, "Tests, but no plan" ); $exit = 123; $new = 123; like( intercept { plan 1; ok(1); my $ctx = context(level => -1); $summary->($ctx, $exit, \$new); $ctx->release; }, array { event Plan => { max => 1 }; event Ok => { pass => 1 }; event Diag => {message => 'Looks like your test exited with 123 after test #1.'}; end }, "Bad exit code" ); done_testing(); Test2-Suite-0.000129/t/modules/Plugin/BailOnFail.t0000644000175000017500000000211013615053353021251 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Plugin::BailOnFail; like( intercept { ok(1, "pass"); ok(0, "fail"); ok(1, "Should not see"); }, array { filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; event Ok => { name => "pass", pass => 1 }; event Ok => { name => "fail", pass => 0 }; event Bail => { reason => "(Bail On Fail)" }; end; }, "Bailed after the failure" ); sub mok { my ($ok, $name) = @_; my $ctx = context(); ok($ok, $name); diag "Should see this after failure"; $ctx->release; return $ok; } like( intercept { ok(1, "pass"); mok(0, "fail"); ok(1, "Should not see"); }, array { event Ok => { name => "pass", pass => 1 }; event Ok => { name => "fail", pass => 0 }; event Diag => {}; # Typical failure diag event Diag => { message => "Should see this after failure" }; event Bail => { reason => "(Bail On Fail)" }; end; }, "Tool had time to output the diag" ); done_testing; Test2-Suite-0.000129/t/modules/Plugin/DieOnFail.t0000644000175000017500000000232013615053353021106 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Plugin::DieOnFail; my $error; like( intercept { ok(1, "pass"); $error = dies { ok(0, "fail"); ok(1, "Should not see"); }; }, array { filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; event Ok => { name => "pass", pass => 1 }; event Ok => { name => "fail", pass => 0 }; end; }, "Died after the failure" ); like( $error, qr/\(Die On Fail\)/, "Got the error" ); sub mok { my ($ok, $name) = @_; my $ctx = context(); ok($ok, $name); diag "Should see this after failure"; $ctx->release; return $ok; } $error = undef; like( intercept { ok(1, "pass"); $error = dies { mok(0, "fail"); ok(1, "Should not see"); }; }, array { event Ok => { name => "pass", pass => 1 }; event Ok => { name => "fail", pass => 0 }; event Diag => {}; # Typical failure diag event Diag => { message => "Should see this after failure" }; end; }, "Tool had time to output the diag" ); like( $error, qr/\(Die On Fail\)/, "Got the error" ); done_testing; Test2-Suite-0.000129/t/modules/Plugin/SRand.t0000644000175000017500000000500713615053353020330 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Basic; use Test2::API qw/intercept test2_stack context/; use Test2::Tools::Compare qw/array event end is like/; use Test2::Tools::Target 'Test2::Plugin::SRand'; use Test2::Tools::Warnings qw/warning/; test2_stack->top; my ($root) = test2_stack->all; sub intercept_2(&) { my $code = shift; # This is to force loading to happen my $ctx = context(); my @events; my $l = $root->listen(sub { my ($h, $e) = @_; push @events => $e; }); $code->(); $root->unlisten($l); $ctx->release; return \@events; } { local %ENV = %ENV; $ENV{HARNESS_IS_VERBOSE} = 1; $ENV{T2_RAND_SEED} = 1234; my $caller = [__PACKAGE__, __FILE__, __LINE__, 'xxx']; like( intercept_2 { $CLASS->import('5555') }, array { event Note => { message => "Seeded srand with seed '5555' from import arg." }; }, "got the event" ); is($CLASS->seed, 5555, "set seed"); is($CLASS->from, 'import arg', "set from"); my ($events, $warning); $warning = warning { $events = intercept_2 { $CLASS->import() } }; like( $events, array { event Note => { message => "Seeded srand with seed '1234' from environment variable." }; }, "got the event" ); is($CLASS->seed, 1234, "set seed"); is($CLASS->from, 'environment variable', "set from"); like( $warning, qr/SRand loaded multiple times, re-seeding rand/, "Warned about resetting srand" ); delete $ENV{T2_RAND_SEED}; $warning = warning { $events = intercept_2 { $CLASS->import() } }; like( $events, array { event Note => { message => qr/Seeded srand with seed '\d{8}' from local date\./ }; }, "got the event" ); ok($CLASS->seed && $CLASS->seed != 1234, "set seed"); is($CLASS->from, 'local date', "set from"); like( $warning, qr/SRand loaded multiple times, re-seeding rand/, "Warned about resetting srand" ); my $hooks = Test2::API::test2_list_exit_callbacks(); delete $ENV{HARNESS_IS_VERBOSE}; $ENV{HARNESS_ACTIVE} = 1; warning { $events = intercept { $CLASS->import() } }; warning { $events = intercept { $CLASS->import() } }; is(Test2::API::test2_list_exit_callbacks, $hooks + 1, "added hook, but only once"); warning { $CLASS->import(undef) }; is($CLASS->seed, 0 , "set seed"); is($CLASS->from, 'import arg', "set from"); } done_testing(); Test2-Suite-0.000129/t/modules/Plugin/Times.t0000644000175000017500000000172013615053353020400 0ustar exodistexodistuse strict; use warnings; use Test2::API qw/intercept context/; use Test2::Tools::Defer qw/def do_def/; use vars qw/@CALLBACKS/; BEGIN { no warnings 'redefine'; local *Test2::API::test2_add_callback_exit = sub { push @CALLBACKS => @_ }; require Test2::Plugin::Times; def ok => (!scalar(@CALLBACKS), "requiring the module does not add a callback"); Test2::Plugin::Times->import(); def ok => (scalar(@CALLBACKS), "importing the module does add a callback"); } use Test2::Tools::Basic; use Test2::Tools::Compare qw/like/; do_def; my $events = intercept { sub { my $ctx = context(); $CALLBACKS[0]->($ctx); $ctx->release; }->(); }; like( $events->[0]->summary, qr/^\S+ on wallclock \([\d\.]+ usr [\d\.]+ sys \+ [\d\.]+ cusr [\d\.]+ csys = [\d\.]+ CPU\)$/, "Got the time info" ); ok($events->[0]->{times}, "Got times"); ok($events->[0]->{harness_job_fields}, "Got harness job fields"); done_testing(); Test2-Suite-0.000129/t/modules/Plugin/UTF8.t0000644000175000017500000000204413615053353020045 0ustar exodistexodistuse strict; use warnings; # HARNESS-NO-FORMATTER # Store the default STDOUT and STDERR IO layers for later testing. # This must happen before we load anything else. use PerlIO (); my %Layers; sub get_layers { my $fh = shift; return { map {$_ => 1} PerlIO::get_layers($fh) }; } BEGIN { $Layers{STDERR} = get_layers(*STDERR); $Layers{STDOUT} = get_layers(*STDOUT); } use Test2::Plugin::UTF8; use Test2::Tools::Basic; use Test2::Tools::Compare; use Test2::API qw(test2_stack); note "pragma"; { ok(utf8::is_utf8("癸"), "utf8 pragma is on"); } note "io_layers"; { is get_layers(*STDOUT), $Layers{STDOUT}, "STDOUT encoding is untouched"; is get_layers(*STDERR), $Layers{STDERR}, "STDERR encoding is untouched"; } note "format_handles"; { my $format = test2_stack()->top->format; my $handles = $format->handles or last; for my $hn (0 .. @$handles) { my $h = $handles->[$hn] || next; my $layers = get_layers($h); ok($layers->{utf8}, "utf8 is on for formatter handle $hn"); } } done_testing; Test2-Suite-0.000129/t/modules/Tools/0000755000175000017500000000000013615053353016774 5ustar exodistexodistTest2-Suite-0.000129/t/modules/Tools/ClassicCompare2.t0000644000175000017500000000016213615053353022132 0ustar exodistexodistuse Test2::Tools::ClassicCompare; use Test2::Tools::Basic; is_deeply({},{}, "deep checking works"); done_testing; Test2-Suite-0.000129/t/modules/Tools/ClassicCompare.t0000644000175000017500000002067313615053353022061 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Tools::ClassicCompare'; BEGIN { $ENV{TABLE_TERM_SIZE} = 80 } use Test2::Util::Stash qw/purge_symbol/; BEGIN { purge_symbol('&is'); purge_symbol('&like'); purge_symbol('&unlike'); purge_symbol('&isnt'); purge_symbol('&cmp_ok'); not_imported_ok(qw/is is_deeply like unlike isnt cmp_ok/); } use Test2::Tools::ClassicCompare; imported_ok(qw/is is_deeply like cmp_ok unlike isnt/); my $ref = {}; is(undef, undef, "undef is undef"); is("foo", "foo", 'foo check'); is($ref, "$ref", "flat check, ref as string right"); is("$ref", $ref, "flat check, ref as string left"); isnt("bar", "foo", 'not foo check'); isnt({}, "$ref", "negated flat check, ref as string right"); isnt("$ref", {}, "negated flat check, ref as string left"); like('aaa', qr/a/, "have an a"); like('aaa', 'a', "have an a, not really a regex"); unlike('bbb', qr/a/, "do not have an a"); unlike('bbb', 'a', "do not have an a, not really a regex"); # Failures my $events = intercept { def ok => (!is('foo', undef, "undef check"), "undef check"); def ok => (!is(undef, 'foo', "undef check"), "undef check"); def ok => (!is('foo', 'bar', "string mismatch"), "string mismatch"); def ok => (!isnt('foo', 'foo', "undesired match"), "undesired match"); def ok => (!like('foo', qr/a/, "no match"), "no match"); def ok => (!unlike('foo', qr/o/, "unexpected match"), "unexpected match"); }; do_def; is_deeply( $events, array { filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; event Fail => { }; event Fail => { }; event Fail => { }; event Fail => { }; event Fail => { }; event Fail => { }; end; }, "got failure events" ); # is_deeply uses the same algorithm as the 'Compare' plugin, so it is already # tested over there. is_deeply( {foo => 1, bar => 'baz'}, {foo => 1, bar => 'baz'}, "Deep compare" ); { package Foo; use overload '""' => sub { 'xxx' }; } my $foo = bless({}, 'Foo'); like($foo, qr/xxx/, "overload"); my $thing = bless {}, 'Foo::Bar'; # Test cmp_ok in a seperate package so we have access to the better tools. package main2; use Test2::Bundle::Extended; BEGIN { main::purge_symbol('&cmp_ok') } use Test2::Tools::ClassicCompare qw/cmp_ok/; use Test2::Util::Table(); sub table { join "\n" => Test2::Util::Table::table(@_) } use Test2::Util::Ref qw/render_ref/; cmp_ok('x', 'eq', 'x', 'string pass'); cmp_ok(5, '==', 5, 'number pass'); cmp_ok(5, '==', 5.0, 'float pass'); my $file = __FILE__; my $line = __LINE__ + 2; like( warnings { cmp_ok(undef, '==', undef, 'undef pass') }, [ qr/uninitialized value.*at \(eval in cmp_ok\) \Q$file\E line $line/, ], "got expected warnings (number)" ); $line = __LINE__ + 2; like( warnings { cmp_ok(undef, 'eq', undef, 'undef pass') }, [ qr/uninitialized value.*at \(eval in cmp_ok\) \Q$file\E line $line/, ], "got expected warnings (string)" ); like( intercept { cmp_ok('x', 'ne', 'x', 'string fail', 'extra diag') }, array { fail_events Ok => sub { call pass => 0; call name => 'string fail'; }; event Diag => sub { call message => table( header => [qw/GOT OP CHECK/], rows => [ [qw/x ne x/], ], ); }; event Diag => { message => 'extra diag' }; end; }, "Got 1 string fail event" ); like( intercept { cmp_ok(5, '==', 42, 'number fail', 'extra diag') }, array { fail_events Ok => sub { call pass => 0; call name => 'number fail'; }; event Diag => sub { call message => table( header => [qw/GOT OP CHECK/], rows => [ [qw/5 == 42/], ], ); }; event Diag => { message => 'extra diag' }; end; }, "Got 1 number fail event" ); my $warning; $line = __LINE__ + 2; like( intercept { $warning = main::warning { cmp_ok(5, '&& die', 42, 'number fail', 'extra diag') } }, array { event Exception => { error => qr/42 at \(eval in cmp_ok\) \Q$file\E line $line/ }; fail_events Ok => sub { call pass => 0; call name => 'number fail'; }; event Diag => sub { call message => table( header => [qw/GOT OP CHECK/], rows => [ ['5', '&& die', ''], ], ); }; event Diag => { message => 'extra diag' }; end; }, "Got exception in test" ); like( $warning, qr/operator '&& die' is not supported \(you can add it to %Test2::Tools::ClassicCompare::OPS\)/, "Got warning about unsupported operator" ); { package Overloaded::Foo42; use overload 'fallback' => 1, '0+' => sub { 42 }, '""' => sub { 'foo' }; } $foo = bless {}, 'Overloaded::Foo42'; cmp_ok($foo, '==', 42, "numeric compare with overloading"); cmp_ok($foo, 'eq', 'foo', "string compare with overloading"); like( intercept { local $ENV{TS_TERM_SIZE} = 10000; cmp_ok($foo, 'ne', $foo, 'string fail', 'extra diag') }, array { fail_events Ok => sub { call pass => 0; call name => 'string fail'; }; event Diag => sub { call message => table( header => [qw/TYPE GOT OP CHECK/], rows => [ ['str', 'foo', 'ne', 'foo'], ['orig', render_ref($foo), '', render_ref($foo)], ], ); }; event Diag => { message => 'extra diag' }; end; }, "Failed string compare, overload" ); like( intercept { local $ENV{TS_TERM_SIZE} = 10000; cmp_ok($foo, '!=', $foo, 'number fail', 'extra diag') }, array { fail_events Ok => sub { call pass => 0; call name => 'number fail'; }; event Diag => sub { call message => table( header => [qw/TYPE GOT OP CHECK/], rows => [ ['num', '42', '!=', '42'], ['orig', render_ref($foo), '', render_ref($foo)], ], ); }; event Diag => { message => 'extra diag' }; end; }, "Failed number compare, overload" ); $line = __LINE__ + 2; like( intercept { local $ENV{TS_TERM_SIZE} = 10000; main::warning { cmp_ok($foo, '&& die', $foo, 'overload exception', 'extra diag') } }, array { event Exception => { error => T() }; fail_events Ok => sub { call pass => 0; call name => 'overload exception'; }; event Diag => sub { call message => table( header => [qw/TYPE GOT OP CHECK/], rows => [ ['unsupported', 'foo', '&& die', ''], ['orig', render_ref($foo), '', render_ref($foo)], ], ); }; event Diag => { message => 'extra diag' }; end; }, "Got exception in test" ); note "cmp_ok() displaying good numbers"; { my $have = 1.23456; my $want = 4.5678; like( intercept { cmp_ok($have, '>', $want); }, array { fail_events Ok => sub { call pass => 0; }; event Diag => sub { call message => table( header => [qw/GOT OP CHECK/], rows => [ [$have, '>', $want], ], ); }; end; }, ); } note "cmp_ok() displaying bad numbers"; { my $have = "zero"; my $want = "3point5"; like( intercept { warnings { cmp_ok($have, '>', $want) }; }, array { fail_events Ok => sub { call pass => 0; }; event Diag => sub { call message => table( header => [qw/TYPE GOT OP CHECK/], rows => [ ['num', 0, '>', '3'], ['orig', $have, '', $want], ], ); }; end; }, ); } done_testing; Test2-Suite-0.000129/t/modules/Tools/AsyncSubtest.t0000644000175000017500000000365113615053353021615 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Tools::AsyncSubtest'; use Test2::Tools::AsyncSubtest; use Test2::Util qw/get_tid CAN_REALLY_FORK/; use Test2::API qw/intercept/; sub DO_THREADS { return 0 unless $ENV{AUTHOR_TESTING} || $ENV{T2_DO_THREAD_TESTS}; return Test2::AsyncSubtest->CAN_REALLY_THREAD; } ok($INC{'Test2/IPC.pm'}, "Loaded Test2::IPC"); imported_ok(qw/async_subtest fork_subtest thread_subtest/); sub run { my $ast = async_subtest('foo'); $ast->run(sub { ok(1, "inside subtest") }); $ast->finish; $ast = async_subtest foo => sub { ok(1, "inside subtest") }; $ast->finish; if (CAN_REALLY_FORK) { $ast = fork_subtest foo => sub { ok(1, "forked subtest: $$") }; $ast->finish; } if (DO_THREADS()) { $ast = thread_subtest foo => sub { ok(1, "threaded subtest: " . get_tid) }; $ast->finish; } } run(); is( &intercept(\&run), array { event Subtest => sub { call pass => T; call name => 'foo'; call subevents => array { event Ok => { pass => 1 }; event Plan => { max => 1 }; }; } for 1 .. 2; event Subtest => sub { call pass => T; call name => 'foo'; call subevents => array { event '+Test2::AsyncSubtest::Event::Attach' => {}; event Ok => { pass => 1 }; event '+Test2::AsyncSubtest::Event::Detach' => {}; event Plan => { max => 1 }; }; } for grep { $_ } CAN_REALLY_FORK, DO_THREADS(); }, "Got expected events" ); like( dies { fork_subtest('foo') }, qr/fork_subtest requires a CODE reference as the second argument/, "fork_subtest needs code" ); like( dies { thread_subtest('foo') }, qr/thread_subtest requires a CODE reference as the second argument/, "thread_subtest needs code" ); done_testing; Test2-Suite-0.000129/t/modules/Tools/Exception.t0000644000175000017500000000160213615053353021116 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Tools::Exception'; { package Foo; use Test2::Tools::Exception qw/dies lives try_ok/; ::imported_ok(qw/dies lives try_ok/); } use Test2::API qw/intercept/; like( dies { die 'xyz' }, qr/xyz/, "Got exception" ); is(dies { 0 }, undef, "no exception"); { local $@ = 'foo'; ok(lives { 0 }, "it lives!"); is($@, "foo", "did not change \$@"); } ok(!lives { die 'xxx' }, "it died"); like($@, qr/xxx/, "Exception is available"); try_ok { 0 } "No Exception from try_ok"; my $err; is( intercept { try_ok { die 'abc' } "foo"; $err = $@; }, array { fail_events Ok => sub { call name => "foo"; call pass => 0; }; event Diag => sub { msg => match qr/abc/; }; }, "Got failure + diag from try_ok" ); like($err, qr/abc/, '$@ has the exception'); done_testing; Test2-Suite-0.000129/t/modules/Tools/Warnings.t0000644000175000017500000000214313615053353020751 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Tools::Warnings'; { package Foo; use Test2::Tools::Warnings qw/warns warning warnings no_warnings/; ::imported_ok(qw/warns warning warnings no_warnings/); } is(warns { 0 }, 0, "no warnings"); is(warns { warn 'a' }, 1, "1 warning"); is(warns { warn 'a' for 1 .. 4 }, 4, "4 warnings"); ok(no_warnings { 0 }, "no warnings"); ok(!no_warnings { warn 'a' }, "warnings"); is( warnings { 0 }, [], "Empty arrayref" ); is( warnings { warn "a\n" for 1 .. 4 }, [ map "a\n", 1 .. 4 ], "4 warnings in arrayref" ); is( warning { warn "xyz\n" }, "xyz\n", "Got expected warning" ); is( warning { 0 }, undef, "No warning" ); my ($events, $warn); $events = intercept { $warn = warning { warning { warn "a\n"; warn "b\n" }; }; }; like( $warn, qr/Extra warnings in warning \{ \.\.\. \}/, "Got warning about extra warnings" ); like( $events, array { event Note => { message => "a\n" }; event Note => { message => "b\n" }; }, "Got warnings as notes." ); done_testing; Test2-Suite-0.000129/t/modules/Tools/Encoding.t0000644000175000017500000000205013615053353020704 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Tools::Encoding'; require Test2::Formatter::TAP; use File::Temp qw/tempfile/; { package Temp; use Test2::Tools::Encoding; main::imported_ok(qw/set_encoding/); } my $warnings; intercept { $warnings = warns { use utf8; my ($fh, $name); my $ct = 100; until ($fh) { --$ct or die "Failed to get temp file after 100 tries"; ($fh, $name) = eval { tempfile() }; } Test2::API::test2_stack->top->format( Test2::Formatter::TAP->new( handles => [$fh, $fh, $fh], ), ); set_encoding('utf8'); ok(1, '†'); unlink($name) or print STDERR "Could not remove temp file $name: $!\n"; }; }; ok(!$warnings, "set_encoding worked"); my $exception; intercept { $exception = dies { set_encoding('utf8'); }; }; like( $exception, qr/Unable to set encoding on formatter ''/, "Cannot set encoding without a formatter" ); done_testing; Test2-Suite-0.000129/t/modules/Tools/Exports.t0000644000175000017500000000120113615053353020617 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Tools::Exports'; { package Temp; use Test2::Tools::Exports; imported_ok(qw/imported_ok not_imported_ok/); not_imported_ok(qw/xyz/); } like( intercept { imported_ok('x') }, array { fail_events Ok => { pass => 0 }; event Diag => { message => "'x' was not imported." }; end; }, "Failed, x is not imported" ); like( intercept { not_imported_ok('ok') }, array { fail_events Ok => { pass => 0 }; event Diag => { message => "'ok' was imported." }; end; }, "Failed, 'ok' is imported" ); done_testing; Test2-Suite-0.000129/t/modules/Tools/GenTemp.t0000644000175000017500000000172713615053353020527 0ustar exodistexodistuse Test2::V0 -target => 'Test2::Tools::GenTemp'; use ok $CLASS => 'gen_temp'; use File::Spec; use IO::Handle; imported_ok qw/gen_temp/; my $tmp = gen_temp( -tempdir => [CLEANUP => 1, TMPDIR => 1], foo => "foo\n", bar => "bar\n", subdir => { baz => "baz\n", nested => { bat => "bat", }, }, ); ok($tmp, "Got a temp dir ($tmp)"); ok(-d File::Spec->canonpath($_), "Created dir $_") for ( $tmp, "$tmp/subdir", "$tmp/subdir/nested", ); for my $file (qw{foo bar subdir/baz subdir/nested/bat}) { my $cp = File::Spec->canonpath("$tmp/$file"); ok(-f $cp, "Created file $file"); open(my $fh, '<', $cp) or die "Could not open file '$cp': $!"; my $content = $file; $content =~ s{^.*/}{}g; $content .= "\n" unless $content eq 'bat'; my $printable = $content; $printable =~ s/\n/\\n/; is(<$fh>, $content, "Got content ($printable)"); ok($fh->eof, "$file At EOF"); } done_testing; Test2-Suite-0.000129/t/modules/Tools/Subtest.t0000644000175000017500000002533513615053353020622 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Tools::Subtest'; use Test2::Tools::Subtest qw/subtest_streamed subtest_buffered/; use File::Temp qw/tempfile/; # A bug in older perls causes a strange error AFTER the program appears to be # done if this test is run. # "Size magic not implemented." if ($] > 5.020000 && $ENV{AUTHOR_TESTING}) { like( intercept { subtest_streamed 'foo' => sub { my ($fh, $name) = tempfile; print $fh <<" EOT"; use Test2::Bundle::Extended; BEGIN { skip_all 'because' } 1; EOT close($fh); do $name; unlink($name) or warn "Could not remove temp file $name: $!"; die $@ if $@; die "Ooops"; }; }, subset { event Note => { message => 'Subtest: foo' }; event Subtest => sub { field pass => 1; field name => 'Subtest: foo'; field subevents => subset { event Plan => { directive => 'SKIP', reason => 'because' }; }; } }, "skip_all in BEGIN inside a subtest works" ); } subtest_streamed 'hub tests' => sub { my $hub = Test2::API::test2_stack->top; isa_ok($hub, 'Test2::Hub', 'Test2::Hub::Subtest'); my $todo = todo "testing parent_todo"; subtest_streamed 'inner hub tests' => sub { my $ihub = Test2::API::test2_stack->top; isa_ok($ihub, 'Test2::Hub', 'Test2::Hub::Subtest'); }; }; like( intercept { subtest_streamed 'foo' => sub { subtest_buffered 'bar' => sub { ok(1, "pass"); }; }; }, subset { event Note => { message => 'Subtest: foo' }; event Subtest => sub { field pass => 1; field name => 'Subtest: foo'; field subevents => subset { event Subtest => sub { field pass => 1; field name => 'bar'; field subevents => subset { event Ok => sub { field name => 'pass'; field pass => 1; }; }; }; }; }; }, "Can nest subtests" ); my @lines = (); like( intercept { push @lines => __LINE__ + 4; subtest_streamed 'foo' => sub { push @lines => __LINE__ + 1; ok(1, "pass"); }; }, subset { event Note => { message => 'Subtest: foo' }; event Subtest => sub { prop file => __FILE__; prop line => $lines[0]; field pass => 1; field name => 'Subtest: foo'; field subevents => subset { event Ok => sub { prop file => __FILE__; prop line => $lines[1]; field name => 'pass'; field pass => 1; }; }; }; }, "Got events for passing subtest" ); @lines = (); like( intercept { push @lines => __LINE__ + 4; subtest_streamed 'foo' => sub { push @lines => __LINE__ + 1; ok(0, "fail"); }; }, subset { event Note => { message => 'Subtest: foo' }; event Subtest => sub { prop file => __FILE__; prop line => $lines[0]; field pass => 0; field name => 'Subtest: foo'; field subevents => subset { event Ok => sub { prop file => __FILE__; prop line => $lines[1]; field name => 'fail'; field pass => 0; }; }; }; }, "Got events for failing subtest" ); @lines = (); like( intercept { push @lines => __LINE__ + 5; subtest_streamed 'foo' => sub { push @lines => __LINE__ + 1; ok(1, "pass"); done_testing; }; }, subset { event Note => { message => 'Subtest: foo' }; event Subtest => sub { prop file => __FILE__; prop line => $lines[0]; field pass => 1; field name => 'Subtest: foo'; field subevents => subset { event Ok => sub { prop file => __FILE__; prop line => $lines[1]; field name => 'pass'; field pass => 1; }; event Plan => { max => 1 }; }; }; }, "Can use done_testing" ); @lines = (); like( intercept { push @lines => __LINE__ + 5; subtest_streamed 'foo' => sub { plan 1; push @lines => __LINE__ + 1; ok(1, "pass"); }; }, subset { event Note => { message => 'Subtest: foo' }; event Subtest => sub { prop file => __FILE__; prop line => $lines[0]; field pass => 1; field name => 'Subtest: foo'; field subevents => subset { event Plan => { max => 1 }; event Ok => sub { prop file => __FILE__; prop line => $lines[1]; field name => 'pass'; field pass => 1; }; }; }; }, "Can plan" ); @lines = (); like( intercept { push @lines => __LINE__ + 5; subtest_streamed 'foo' => sub { skip_all 'bleh'; push @lines => __LINE__ + 1; ok(1, "pass"); }; }, subset { event Note => { message => 'Subtest: foo' }; event Subtest => sub { prop file => __FILE__; prop line => $lines[0]; field pass => 1; field name => 'Subtest: foo'; field subevents => subset { event Plan => { directive => 'SKIP', reason => 'bleh' }; }; }; }, "Can skip_all" ); @lines = (); like( intercept { subtest_streamed 'foo' => sub { bail_out 'cause'; ok(1, "should not see this"); }; }, subset { event Note => { message => 'Subtest: foo' }; event Bail => { reason => 'cause' }; }, "Can bail out" ); @lines = (); like( intercept { push @lines => __LINE__ + 4; subtest_buffered 'foo' => sub { push @lines => __LINE__ + 1; ok(1, "pass"); }; }, subset { event Subtest => sub { prop file => __FILE__; prop line => $lines[0]; field pass => 1; field name => 'foo'; field subevents => subset { event Ok => sub { prop file => __FILE__; prop line => $lines[1]; field name => 'pass'; field pass => 1; }; }; }; }, "Got events for passing subtest" ); @lines = (); like( intercept { push @lines => __LINE__ + 4; subtest_buffered 'foo' => sub { push @lines => __LINE__ + 1; ok(0, "fail"); }; }, subset { event Subtest => sub { prop file => __FILE__; prop line => $lines[0]; field pass => 0; field name => 'foo'; field subevents => subset { event Ok => sub { prop file => __FILE__; prop line => $lines[1]; field name => 'fail'; field pass => 0; }; }; }; }, "Got events for failing subtest" ); @lines = (); like( intercept { push @lines => __LINE__ + 5; subtest_buffered 'foo' => sub { push @lines => __LINE__ + 1; ok(1, "pass"); done_testing; }; }, subset { event Subtest => sub { prop file => __FILE__; prop line => $lines[0]; field pass => 1; field name => 'foo'; field subevents => subset { event Ok => sub { prop file => __FILE__; prop line => $lines[1]; field name => 'pass'; field pass => 1; }; event Plan => { max => 1 }; }; }; }, "Can use done_testing" ); @lines = (); like( intercept { push @lines => __LINE__ + 5; subtest_buffered 'foo' => sub { plan 1; push @lines => __LINE__ + 1; ok(1, "pass"); }; }, subset { event Subtest => sub { prop file => __FILE__; prop line => $lines[0]; field pass => 1; field name => 'foo'; field subevents => subset { event Plan => { max => 1 }; event Ok => sub { prop file => __FILE__; prop line => $lines[1]; field name => 'pass'; field pass => 1; }; }; }; }, "Can plan" ); @lines = (); like( intercept { push @lines => __LINE__ + 5; subtest_buffered 'foo' => sub { skip_all 'bleh'; push @lines => __LINE__ + 1; ok(1, "pass"); }; }, subset { event Subtest => sub { prop file => __FILE__; prop line => $lines[0]; field pass => 1; field name => 'foo'; field subevents => subset { event Plan => { directive => 'SKIP', reason => 'bleh' }; }; }; }, "Can skip_all" ); @lines = (); like( intercept { subtest_buffered 'foo' => sub { bail_out 'cause'; ok(1, "should not see this"); }; }, subset { event Bail => { reason => 'cause' }; }, "Can bail out" ); @lines = (); my $xyz = 0; like( intercept { push @lines => __LINE__ + 5; subtest_buffered 'foo' => {manual_skip_all => 1}, sub { skip_all 'bleh'; $xyz = 1; return; }; }, subset { event Subtest => sub { prop file => __FILE__; prop line => $lines[0]; field pass => 1; field name => 'foo'; field subevents => subset { event Plan => { directive => 'SKIP', reason => 'bleh' }; }; }; }, "Can skip_all" ); ok($xyz, "skip_all did not auto-abort"); done_testing; Test2-Suite-0.000129/t/modules/Tools/Compare.t0000644000175000017500000013206713615053353020560 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Tools::Compare'; use Test2::Util::Table(); BEGIN { $ENV{TABLE_TERM_SIZE} = 80 } { package My::Boolean; use overload bool => sub { ${$_[0]} }; } { package My::String; use overload '""' => sub { "xxx" }; } sub fail_table { my %args = @_; my $string = join "\n" => Test2::Util::Table::table(%args, sanitize => 1, mark_tail => 1); event Fail => sub { call facet_data => hash { field assert => hash { field pass => 0; etc }; field info => array { item hash { field details => $string; field table => hash { field header => bag { item $_ for @{$args{header}}; etc }; field rows => bag { item bag { item $_ for @{$_}; etc } for @{$args{rows}}; etc; }; etc; }; etc; }; etc; }; etc; }; }; } subtest simple => sub { imported_ok qw{ match mismatch validator hash array bag object meta number float rounded within string bool in_set not_in_set check_set item field call call_list call_hash prop check all_items all_keys all_vals all_values etc end filter_items T F D DF E DNE FDNE U event exact_ref }; }; subtest is => sub { my $events = intercept { def ok => (is(1, 1), '2 arg pass'); def ok => (is('a', 'a', "simple pass", 'diag'), 'simple pass'); def ok => (!is('a', 'b', "simple fail", 'diag'), 'simple fail'); def ok => (is([{'a' => 1}], [{'a' => 1}], "complex pass", 'diag'), 'complex pass'); def ok => (!is([{'a' => 2, 'b' => 3}], [{'a' => 1}], "complex fail", 'diag'), 'complex fail'); def ok => (is(undef, undef), 'undef pass'); def ok => (!is(0, undef), 'undef fail'); my $true = do { bless \(my $dummy = 1), "My::Boolean" }; my $false = do { bless \(my $dummy = 0), "My::Boolean" }; def ok => (is($true, $true, "true scalar ref is itself"), "true scalar ref is itself"); def ok => (is($false, $false, "false scalar ref is itself"), "false scalar ref is itself"); def ok => (is(v1.2.3, v1.2.3, 'vstring pass'), 'vstring pass'); def ok => (is(\v1.2.3, \v1.2.3, 'vstring refs pass'), 'vstring refs pass'); def ok => (!is(v1.2.3, v1.2.4, 'vstring fail'), 'vstring fail'); def ok => (!is(\v1.2.3, \v1.2.4, 'vstring refs fail'), 'vstring refs fail'); my $x = \\"123"; def ok => (is($x, \\"123", "Ref-Ref check 1"), "Ref-Ref check 1"); $x = \[123]; def ok => (is($x, \["123"], "Ref-Ref check 2"), "Ref-Ref check 2"); def ok => (!is(\$x, \\["124"], "Ref-Ref check 3"), "Ref-Ref check 3"); }; do_def; like( $events, array { event Ok => sub { call pass => T(); call name => undef; }; event Ok => sub { call pass => T(); call name => 'simple pass'; }; fail_table( header => [qw/GOT OP CHECK/], rows => [[qw/a eq b/]], ); event Ok => sub { call pass => T(); call name => 'complex pass'; }; fail_table( header => [qw/PATH GOT OP CHECK/], rows => [ [qw/[0]{a} 2 eq 1/], [qw/[0]{b} 3 !exists/, ''], ], ); event Ok => sub { call pass => T(); }; fail_table( header => [qw/GOT OP CHECK/], rows => [[qw/0 IS /]], ); event Ok => sub { call pass => T(); call name => "true scalar ref is itself"; }; event Ok => sub { call pass => T(); call name => "false scalar ref is itself"; }; event Ok => sub { call pass => T(); call name => 'vstring pass'; }; event Ok => sub { call pass => T(); call name => 'vstring refs pass'; }; fail_table( header => [qw/GOT OP CHECK/], rows => [["\N{U+1}\N{U+2}\N{U+3}", 'eq', "\N{U+1}\N{U+2}\N{U+4}"]], ); fail_table( header => [qw/PATH GOT OP CHECK/], rows => [['$*', "\N{U+1}\N{U+2}\N{U+3}", 'eq', "\N{U+1}\N{U+2}\N{U+4}"]], ); event Ok => sub { call pass => T(); call name => "Ref-Ref check 1"; }; event Ok => sub { call pass => T(); call name => "Ref-Ref check 2"; }; event Fail => sub { call name => 'Ref-Ref check 3'; }; end; }, "Got expected events" ); }; subtest like => sub { my $events = intercept { def ok => (like(1, 1), '2 arg pass'); def ok => (like('a', qr/a/, "simple pass", 'diag'), 'simple pass'); def ok => (!like('b', qr/a/, "simple fail", 'diag'), 'simple fail'); def ok => (like([{'a' => 1, 'b' => 2}, 'a'], [{'a' => 1}], "complex pass", 'diag'), 'complex pass'); def ok => (!like([{'a' => 2, 'b' => 2}, 'a'], [{'a' => 1}], "complex fail", 'diag'), 'complex fail'); my $str = bless {}, 'My::String'; def ok => (like($str, qr/xxx/, 'overload pass'), "overload pass"); def ok => (!like($str, qr/yyy/, 'overload fail'), "overload fail"); }; do_def; my $rx = "" . qr/a/; like( $events, array { event Ok => sub { call pass => T(); call name => undef; }; event Ok => sub { call pass => T(); call name => 'simple pass'; }; fail_table( header => [qw/GOT OP CHECK/], rows => [[qw/b =~/, "$rx"]], ); event Ok => sub { call pass => T(); call name => 'complex pass'; }; fail_table( header => [qw/PATH GOT OP CHECK/], rows => [[qw/[0]{a} 2 eq 1/]], ); event Ok => sub { call pass => T(); call name => 'overload pass'; }; $rx = qr/yyy/; fail_table( header => [qw/GOT OP CHECK/], rows => [[qw/xxx =~/, "$rx"]], ); end; }, "Got expected events" ); }; subtest shortcuts => sub { is(1, T(), "true"); is('a', T(), "true"); is(' ', T(), "true"); is('0 but true', T(), "true"); my @lines; my $events = intercept { is(0, T(), "not true"); push @lines => __LINE__; is('', T(), "not true"); push @lines => __LINE__; is(undef, T(), "not true"); push @lines => __LINE__; }; like( $events, array { filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; event Fail => sub { prop line => $lines[0]; prop file => __FILE__; }; event Fail => sub { prop line => $lines[1]; prop file => __FILE__; }; event Fail => sub { prop line => $lines[2]; prop file => __FILE__; }; end() }, "T() fails for untrue", ); is(0, F(), "false"); is('', F(), "false"); is(undef, F(), "false"); $events = intercept { is(1, F(), "not false"); is('a', F(), "not false"); is(' ', F(), "not false"); }; like( $events, array { filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; event Fail => {}; event Fail => {}; event Fail => {}; end() }, "F() fails for true", ); is(undef, U(), "not defined"); like( intercept { is(0, U(), "not defined") }, array { event Fail => {} }, "0 is defined" ); is(0, D(), "defined"); is(1, D(), "defined"); is('', D(), "defined"); is(' ', D(), "defined"); is('0 but true', D(), "defined"); like( intercept { is(undef, D(), "not defined") }, array { event Fail => { } }, "undef is not defined" ); is(0, DF(), "defined but false"); is('', DF(), "defined but false"); like( intercept { is(undef, DF()); is(1, DF()); is(' ', DF()); is('0 but true', DF()); }, array { filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; event Fail => {}; event Fail => {}; event Fail => {}; event Fail => {}; }, "got fail for DF" ); is([undef], [E()], "does exist"); is([], [DNE()], "does not exist"); is({}, {a => DNE()}, "does not exist"); $events = intercept { is([], [E()]); is([undef], [DNE()]); is({a => undef}, {a => DNE()}); }; like( $events, array { filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; event Fail => {}; event Fail => {}; event Fail => {}; }, "got failed event" ); is([], [FDNE()], "does not exist"); is({}, {a => FDNE()}, "does not exist"); is([undef], [FDNE()], "false"); is({a => undef}, {a => FDNE()}, "false"); $events = intercept { is([1], [FDNE()]); is({a => 1}, {a => FDNE()}); }; like( $events, array { filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; event Fail => {}; event Fail => {}; }, "got failed event" ); }; subtest exact_ref => sub { my $ref = {}; my $check = exact_ref($ref); my $line = __LINE__; is($check->lines, [$line], "correct line"); my $hash = {}; my $events = intercept { is($ref, $check, "pass"); is($hash, $check, "fail"); }; like( $events, array { event Ok => {pass => 1}; fail_table( header => [qw/GOT OP CHECK LNs/], rows => [["$hash", '==', "$ref", $line]], ); end; }, "Got events" ); }; subtest string => sub { my $check = string "foo"; my $line = __LINE__; is($check->lines, [$line], "Got line number"); my $events = intercept { is('foo', $check, "pass"); is('bar', $check, "fail"); }; like( $events, array { event Ok => {pass => 1}; fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[qw/bar eq foo/, $line]], ); end; }, "Got events" ); my ($check1, $check2) = (string("foo", negate => 1), !string("foo")); $line = __LINE__ - 1; for $check ($check1, $check2) { is($check->lines, [$line], "Got line number"); $events = intercept { is('bar', $check1, "pass"); is('foo', $check1, "fail"); }; like( $events, array { event Ok => {pass => 1}; fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[qw/foo ne foo/, $line]], ); end; }, "Got events" ); } }; subtest number => sub { my $check = number "22.0"; my $line = __LINE__; is($check->lines, [$line], "Got line number"); my $events = intercept { is(22, $check, "pass"); is("22.0", $check, "pass"); is(12, $check, "fail"); is('xxx', $check, "fail"); }; like( $events, array { event Ok => {pass => 1}; event Ok => {pass => 1}; fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[qw/12 == 22.0/, $line]], ); fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[qw/xxx == 22.0/, $line]], ); end; }, "Got events" ); my ($check1, $check2) = (number("22.0", negate => 1), !number("22.0")); $line = __LINE__ - 1; for $check ($check1, $check2) { is($check->lines, [$line], "Got line number"); $events = intercept { is(12, $check, "pass"); is(22, $check, "fail"); is("22.0", $check, "fail"); is('xxx', $check, "fail"); }; like( $events, array { event Ok => {pass => 1}; fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[qw/22 != 22.0/, $line]], ); fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[qw/22.0 != 22.0/, $line]], ); fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[qw/xxx != 22.0/, $line]], ); end; }, "Got events" ); } }; subtest float => sub { subtest float_number => sub { # float should pass all of the number subtests my $check = float("22.0"); my $line = __LINE__; is($check->lines, [$line], "Got line number"); my $events = intercept { is(22, $check, "pass"); is("22.0", $check, "pass"); is(12, $check, "fail"); is('xxx', $check, "fail"); }; like( $events, array { event Ok => {pass => 1}; event Ok => {pass => 1}; fail_table( header => [qw/GOT OP CHECK LNs/], rows => [['12', '==', $check->name, $line]], ); fail_table( header => [qw/GOT OP CHECK LNs/], rows => [['xxx', '==', $check->name, $line]], ); end; }, "Got events" ); my ($check1, $check2) = (float("22.0", negate => 1), !float("22.0")); $line = __LINE__ - 1; for $check ($check1, $check2) { is($check->lines, [$line], "Got line number"); $events = intercept { is(12, $check, "pass"); is(22, $check, "fail"); is("22.0", $check, "fail"); is('xxx', $check, "fail"); }; like( $events, array { event Ok => {pass => 1}; fail_table( header => [qw/GOT OP CHECK LNs/], rows => [['22', '!=', $check->name, $line]], ); fail_table( header => [qw/GOT OP CHECK LNs/], rows => [['22.0', '!=', $check->name, $line]], ); fail_table( header => [qw/GOT OP CHECK LNs/], rows => [['xxx', '!=', $check->name, $line]], ); end; }, "Got float events" ); } }; subtest float_rounding => sub { my $check = float("22.0"); my $check_3 = float("22.0", tolerance => .001); is($check->tolerance, 1e-08, "default tolerance"); is($check_3->tolerance, 0.001, "custom tolerance"); my $check_p3 = float("22.0", precision => 3); is($check_p3->precision, 3, "custom precision"); is($check_p3->name, "22.000", "custom precision name"); }; subtest rounded_and_within => sub { my $check = within("22.0"); my $check_3 = within("22.0", .001); is($check->tolerance, 1e-08, "default tolerance"); is($check_3->tolerance, 0.001, "custom tolerance"); my $check_p3 = rounded("22.0", 3); is($check_p3->precision, 3, "custom precision"); is($check_p3->name, "22.000", "custom precision name"); }; }; subtest bool => sub { my @true = (1, 'yup', '0 but true', ' ', {}); my @false = (0, '0', '', undef); for my $true (@true) { for my $true2 (@true) { is($true2, bool($true), "Both true"); my $line = __LINE__ + 2; is( intercept { is($true2, !bool($true)) }, array { fail_table( header => [qw/GOT OP CHECK LNs/], rows => [["", '!=', "", $line]], ); end; }, "true($true2) + true($true) + negate" ); } for my $false (@false) { is($false, !bool($true), "true + false + !"); is($false, bool($true, negate => 1), "true + false + negate"); my $render = ''; my $line = __LINE__ + 2; is( intercept { is($false, bool($true)) }, array { fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[$render, '==', "", $line]], ); end; }, "$render + TRUE ($true) + negate" ); } } for my $false (@false) { my $render1 = ''; for my $false2 (@false) { is($false2, bool($false), "false + false"); my $render2 = ''; my $line = __LINE__ + 2; is( intercept { is($false2, !bool($false)) }, array { fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[$render2, '!=', $render1, $line]], ); end; }, "$render2 + $render1 + negate" ); } for my $true (@true) { is($true, !bool($false), "true + false + !"); is($true, bool($false, negate => 1), "true + false + negate"); my $line = __LINE__ + 2; is( intercept { is($true, bool($false)) }, array { fail_table( header => [qw/GOT OP CHECK LNs/], rows => [["", '==', $render1, $line]], ); end; }, "TRUE ($true) + $render1 + negate" ); } } my $arr = []; my $line = __LINE__ + 2; is( intercept { is($arr, [bool(0)]) }, array { fail_table( header => [qw/PATH GOT OP CHECK LNs/], rows => [['[0]', "", '==', '', $line],], ); end; }, "Value must exist" ); }; subtest match => sub { my $check = match qr/xyz/; my $line = __LINE__; is($check->lines, [$line], "Got line number"); my $events = intercept { is('axyzb', $check, "pass"); is('abcde', $check, "fail"); }; my $rx = "" . qr/xyz/; like( $events, array { event Ok => {pass => 1}; fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[qw/abcde =~/, "$rx", $line]], ); end; }, "Got events" ); }; subtest '!match' => sub { my $check = !match qr/xyz/; my $line = __LINE__; is($check->lines, [$line], "Got line number"); my $events = intercept { is('abcde', $check, "pass"); is('axyzb', $check, "fail"); }; my $rx = "" . qr/xyz/; like( $events, array { event Ok => {pass => 1}; fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[qw/axyzb !~/, "$rx", $line]], ); end; }, "Got events" ); }; subtest '!mismatch' => sub { my $check = !mismatch qr/xyz/; my $line = __LINE__; is($check->lines, [$line], "Got line number"); my $events = intercept { is('axyzb', $check, "pass"); is('abcde', $check, "fail"); }; my $rx = "" . qr/xyz/; like( $events, array { event Ok => {pass => 1}; fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[qw/abcde =~/, "$rx", $line]], ); end; }, "Got events" ); }; subtest mismatch => sub { my $check = mismatch qr/xyz/; my $line = __LINE__; is($check->lines, [$line], "Got line number"); my $events = intercept { is('abcde', $check, "pass"); is('axyzb', $check, "fail"); }; my $rx = "" . qr/xyz/; like( $events, array { event Ok => {pass => 1}; fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[qw/axyzb !~/, "$rx", $line]], ); end; }, "Got events" ); }; subtest check => sub { my @lines; my $one = validator sub { $_ ? 1 : 0 }; push @lines => __LINE__; my $two = validator two => sub { $_ ? 1 : 0 }; push @lines => __LINE__; my $thr = validator 't', thr => sub { $_ ? 1 : 0 }; push @lines => __LINE__; is($one->lines, [$lines[0]], "line 1"); is($two->lines, [$lines[1]], "line 2"); is($thr->lines, [$lines[2]], "line 3"); my $events = intercept { is(1, $one, 'pass'); is(1, $two, 'pass'); is(1, $thr, 'pass'); is(0, $one, 'fail'); is(0, $two, 'fail'); is(0, $thr, 'fail'); }; like( $events, array { event Ok => {pass => 1}; event Ok => {pass => 1}; event Ok => {pass => 1}; fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[0, 'CODE(...)', '', $lines[0]]], ); fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[0, 'CODE(...)', 'two', $lines[1]]], ); fail_table( header => [qw/GOT OP CHECK LNs/], rows => [[0, 't', 'thr', $lines[2]]], ); end; }, "Got events" ); }; subtest prop => sub { like( dies { prop x => 1 }, qr/No current build/, "Need a build" ); like( dies { [meta { my $x = prop x => 1 }] }, qr/'prop' should only ever be called in void context/, "restricted context" ); is( [1], array { prop size => 1; etc; }, "Array builder supports 'prop'" ); is( [1], bag { prop size => 1; etc; }, "Bag builder supports 'prop'" ); is( { foo => 1, }, hash { prop size => 1; etc; }, "Hash builder supports 'prop'" ); my $events = intercept { is( [1], array { prop size => 2; etc; } ); is( [1], bag { prop size => 2; etc; } ); is( { foo => 1, }, hash { prop size => 2; etc; } ); }; is( $events, array { filter_items { grep { ref =~ /::Ok/ } @_ }; all_items object { call pass => F }; etc; } ); }; subtest end => sub { like( dies { end() }, qr/No current build/, "Need a build" ); like( dies { [meta { end() }] }, qr/'Test2::Compare::Meta.*' does not support 'ending'/, "Build does not support end" ); like( dies { [array { [end()] }] }, qr/'end' should only ever be called in void context/, "end context" ); }; subtest field => sub { like( dies { field a => 1 }, qr/No current build/, "Need a build" ); like( dies { [array { field a => 1 }] }, qr/'Test2::Compare::Array.*' does not support hash field checks/, "Build does not take fields" ); like( dies { [hash { [field a => 1] }] }, qr/'field' should only ever be called in void context/, "field context" ); }; subtest filter_items => sub { like( dies { filter_items {1} }, qr/No current build/, "Need a build" ); like( dies { [hash { filter_items {1} }] }, qr/'Test2::Compare::Hash.*' does not support filters/, "Build does not take filters" ); like( dies { [array { [filter_items {1}] }] }, qr/'filter_items' should only ever be called in void context/, "filter context" ); }; subtest item => sub { like( dies { item 0 => 'a' }, qr/No current build/, "Need a build" ); like( dies { [hash { item 0 => 'a' }] }, qr/'Test2::Compare::Hash.*' does not support array item checks/, "Build does not take items" ); like( dies { [array { [ item 0 => 'a' ] }] }, qr/'item' should only ever be called in void context/, "item context" ); }; subtest call => sub { like( dies { call foo => 1 }, qr/No current build/, "Need a build" ); like( dies { [hash { call foo => 1 }] }, qr/'Test2::Compare::Hash.*' does not support method calls/, "Build does not take methods" ); like( dies { [object { [ call foo => 1 ] }] }, qr/'call' should only ever be called in void context/, "call context" ); }; subtest check => sub { like( dies { check 'a' }, qr/No current build/, "Need a build" ); like( dies { [hash { check 'a' }] }, qr/'Test2::Compare::Hash.*' is not a check-set/, "Build must support checks" ); like( dies { [in_set(sub { [ check 'a' ] })] }, qr/'check' should only ever be called in void context/, "check context" ); }; subtest meta => sub { my $x = bless {}, 'Foo'; my $check = meta { prop blessed => 'Foo'; prop reftype => 'HASH'; prop this => $x; }; my @lines = map { __LINE__ - $_ } reverse 1 .. 5; is($x, $check, "meta pass"); my $array = []; my $events = intercept { is($array, $check, "meta fail") }; like( $events, array { fail_table( header => [qw/PATH GOT OP CHECK LNs/], rows => [ ["", "$array", '', '', "$lines[0], $lines[4]"], ['', '', '', 'Foo', $lines[1]], ['', 'ARRAY', 'eq', 'HASH', $lines[2]], ['', "$array", '', '', $lines[3]], ], ); }, "got failure" ); }; subtest hash => sub { my $empty = hash { etc }; my $full = hash { field a => 1; field b => 2; etc; }; my $closed = hash { field a => 1; field b => 2; end(); }; isa_ok($_, 'Test2::Compare::Base', 'Test2::Compare::Hash') for $empty, $full, $closed; is({}, $empty, "empty hash"); is({a => 1}, $empty, "unclosed empty matches anything"); is({a => 1, b => 2}, $full, "full exact match"); is({a => 1, b => 2, c => 3 }, $full, "full with extra"); is({a => 1, b => 2}, $closed, "closed"); my $events = intercept { is([], $empty); is(undef, $empty); is(1, $empty); is('HASH', $empty); is({}, $full); is({a => 2, b => 2}, $full); is({a => 1, b => 2, c => 3}, $closed); }; @$events = grep {$_->isa('Test2::Event::Fail')} @$events; is(@$events, 7, '7 fail events'); }; subtest array => sub { my $empty = array { etc }; my $simple = array { item 'a'; item 'b'; item 'c'; etc; }; my $filtered = array { filter_items { grep { m/a/ } @_ }; item 0 => 'a'; item 1 => 'a'; item 2 => 'a'; etc; }; my $shotgun = array { item 1 => 'b'; item 3 => 'd'; etc; }; my $closed = array { item 0 => 'a'; item 1 => 'b'; item 2 => 'c'; end; }; is([], $empty, "empty array"); is(['a'], $empty, "any array matches empty"); is([qw/a b c/], $simple, "simple exact match"); is([qw/a b c d e/], $simple, "simple with extra"); is([qw/x a b c a v a t t/], $filtered, "filtered out unwanted values"); is([qw/a b c d e/], $shotgun, "selected indexes only"); is([qw/a b c/], $closed, "closed array"); my $events = intercept { is({}, $empty); is(undef, $empty); is(1, $empty); is('ARRAY', $empty); is([qw/x y z/], $simple); is([qw/a b x/], $simple); is([qw/x b c/], $simple); is([qw/aa a a a b/], $filtered); is([qw/b c d e f/], $shotgun); is([qw/a b c d/], $closed); }; @$events = grep {$_->isa('Test2::Event::Fail')} @$events; is(@$events, 10, "10 fail events"); }; subtest bag => sub { my $empty = bag { etc }; my $simple = bag { item 'a'; item 'b'; item 'c'; etc; }; my $closed = array { item 0 => 'a'; item 1 => 'b'; item 2 => 'c'; end; }; is([], $empty, "empty array"); is(['a'], $empty, "any array matches empty"); is([qw/a b c/], $simple, "simple exact match"); is([qw/b c a/], $simple, "simple out of order"); is([qw/a b c d e/], $simple, "simple with extra"); is([qw/b a d e c/], $simple, "simple with extra, out of order"); is([qw/a b c/], $closed, "closed array"); my $events = intercept { is({}, $empty); is(undef, $empty); is(1, $empty); is('ARRAY', $empty); is([qw/x y z/], $simple); is([qw/a b x/], $simple); is([qw/x b c/], $simple); is([qw/a b c d/], $closed); }; @$events = grep {$_->isa('Test2::Event::Fail')} @$events; is(@$events, 8, "8 fail events"); }; subtest object => sub { my $empty = object { }; my $simple = object { call foo => 'foo'; call bar => 'bar'; call_list many => [1,2,3,4]; call_hash many => {1=>2,3=>4}; call [args => qw(a b)] => {a=>'b'}; }; my $array = object { call foo => 'foo'; call bar => 'bar'; call_list many => [1,2,3,4]; call_hash many => {1=>2,3=>4}; call [args => qw(a b)] => {a=>'b'}; item 0 => 'x'; item 1 => 'y'; etc; }; my $closed_array = object { call foo => 'foo'; call bar => 'bar'; call_list many => [1,2,3,4]; call_hash many => {1=>2,3=>4}; call [args => qw(a b)] => {a=>'b'}; item 0 => 'x'; item 1 => 'y'; end(); }; my $hash = object { call foo => 'foo'; call bar => 'bar'; call_list many => [1,2,3,4]; call_hash many => {1=>2,3=>4}; call [args => qw(a b)] => {a=>'b'}; field x => 1; field y => 2; etc; }; my $closed_hash = object { call foo => 'foo'; call bar => 'bar'; call_list many => [1,2,3,4]; call_hash many => {1=>2,3=>4}; call [args => qw(a b)] => {a=>'b'}; field x => 1; field y => 2; end(); }; my $meta = object { call foo => 'foo'; call bar => 'bar'; call_list many => [1,2,3,4]; call_hash many => {1=>2,3=>4}; call [args => qw(a b)] => {a=>'b'}; prop blessed => 'ObjectFoo'; prop reftype => 'HASH'; etc; }; my $mix = object { call foo => 'foo'; call bar => 'bar'; call_list many => [1,2,3,4]; call_hash many => {1=>2,3=>4}; call [args => qw(a b)] => {a=>'b'}; field x => 1; field y => 2; prop blessed => 'ObjectFoo'; prop reftype => 'HASH'; etc; }; my $obf = mock 'ObjectFoo' => (add => [ foo => sub { 'foo' }, bar => sub { 'bar' }, baz => sub {'baz'}, many => sub { (1,2,3,4) }, args => sub { shift; +{@_} }, ]); my $obb = mock 'ObjectBar' => (add => [ foo => sub { 'nop' }, baz => sub { 'baz' }, many => sub { (1,2,3,4) }, args => sub { shift; +{@_} }, ]); is(bless({}, 'ObjectFoo'), $empty, "Empty matches any object"); is(bless({}, 'ObjectBar'), $empty, "Empty matches any object"); is(bless({}, 'ObjectFoo'), $simple, "simple match hash"); is(bless([], 'ObjectFoo'), $simple, "simple match array"); is(bless([qw/x y/], 'ObjectFoo'), $array, "array match"); is(bless([qw/x y z/], 'ObjectFoo'), $array, "array match"); is(bless([qw/x y/], 'ObjectFoo'), $closed_array, "closed array"); is(bless({x => 1, y => 2}, 'ObjectFoo'), $hash, "hash match"); is(bless({x => 1, y => 2, z => 3}, 'ObjectFoo'), $hash, "hash match"); is(bless({x => 1, y => 2}, 'ObjectFoo'), $closed_hash, "closed hash"); is(bless({}, 'ObjectFoo'), $meta, "meta match"); is(bless({x => 1, y => 2, z => 3}, 'ObjectFoo'), $mix, "mix"); my $events = intercept { is({}, $empty); is(undef, $empty); is(1, $empty); is('ARRAY', $empty); is(bless({}, 'ObjectBar'), $simple, "simple match hash"); is(bless([], 'ObjectBar'), $simple, "simple match array"); is(bless([qw/a y/], 'ObjectFoo'), $array, "array match"); is(bless([qw/a y z/], 'ObjectFoo'), $array, "array match"); is(bless([qw/x y z/], 'ObjectFoo'), $closed_array, "closed array"); is(bless({x => 2, y => 2}, 'ObjectFoo'), $hash, "hash match"); is(bless({x => 2, y => 2, z => 3}, 'ObjectFoo'), $hash, "hash match"); is(bless({x => 1, y => 2, z => 3}, 'ObjectFoo'), $closed_hash, "closed hash"); is(bless({}, 'ObjectBar'), $meta, "meta match"); is(bless([], 'ObjectFoo'), $meta, "meta match"); is(bless({}, 'ObjectFoo'), $mix, "mix"); is(bless([], 'ObjectFoo'), $mix, "mix"); is(bless({x => 1, y => 2, z => 3}, 'ObjectBar'), $mix, "mix"); }; @$events = grep {$_->isa('Test2::Event::Fail')} @$events; is(@$events, 17, "17 fail events"); }; subtest event => sub { like( dies { event 0 => {} }, qr/type is required/, "Must specify event type" ); my $one = event Ok => {}; is($one->meta->items->[0]->[1], 'Test2::Event::Ok', "Event type check"); $one = event '+Foo::Event::Diag' => {}; is($one->meta->items->[0]->[1], 'Foo::Event::Diag', "Event type check with +"); my $empty = event 'Ok'; isa_ok($empty, 'Test2::Compare::Event'); like( dies { event Ok => 'xxx' }, qr/'xxx' is not a valid event specification/, "Invalid spec" ); my $from_sub = event Ok => sub { call pass => 1; field name => 'pass'; etc; }; my $from_hash = event Ok => sub { field pass => 1; field name => 'pass'; etc}; my $from_build = array { event Ok => sub { field pass => 1; field name => 'pass'; etc } }; my $pass = intercept { ok(1, 'pass') }; my $fail = intercept { ok(0, 'fail') }; my $diag = intercept { diag("hi") }; is($pass->[0], $empty, "empty matches any event of the type"); is($fail->[0], $empty, "empty on a failed event"); is($pass->[0], $from_sub, "builder worked"); is($pass->[0], $from_hash, "hash spec worked"); is($pass, $from_build, "worked in build"); my $events = intercept { is($diag->[0], $empty); is($fail->[0], $from_sub, "builder worked"); is($fail->[0], $from_hash, "hash spec worked"); is($fail, $from_build, "worked in build"); }; @$events = grep {$_->isa('Test2::Event::Fail')} @$events; is(@$events, 4, "4 fail events"); like( dies { event Ok => {}; 1 }, qr/No current build!/, "Need a build!" ); }; subtest sets => sub { subtest check_set => sub { is( 'foo', check_set(sub { check 'foo'; check match qr/fo/; check match qr/oo/ }), "matches everything in set" ); is( 'foo', check_set('foo', match qr/fo/, match qr/oo/), "matches everything in set" ); like( intercept { is('fox', check_set(sub{ check match qr/fo/; check 'foo' })); is('fox', check_set(match qr/fo/, 'foo')); }, array { filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; event Fail => {}; event Fail => {}; end; }, "Failed cause not all checks passed" ); }; subtest in_set => sub { is( 'foo', in_set(sub { check 'x'; check 'y'; check 'foo' }), "Item is in set" ); is( 'foo', in_set(qw/x y foo/), "Item is in set" ); like( intercept { is('fox', in_set(sub{ check 'x'; check 'foo' })); is('fox', in_set('x', 'foo')); }, array { filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; event Fail => {}; event Fail => {}; end; }, "Failed cause not all checks passed" ); }; subtest not_in_set => sub { is( 'foo', not_in_set(sub { check 'x'; check 'y'; check 'z' }), "Item is not in set" ); is( 'foo', not_in_set(qw/x y z/), "Item is not in set" ); like( intercept { is('fox', not_in_set(sub{ check 'x'; check 'fox' })); is('fox', not_in_set('x', 'fox')); }, array { filter_items { grep { !$_->isa('Test2::Event::Diag') } @_ }; event Fail => {}; event Fail => {}; end; }, "Failed cause not all checks passed" ); }; }; subtest regex => sub { is(qr/abc/, qr/abc/, "same regex"); my $events = intercept { is(qr/abc/i, qr/abc/, "Wrong flags"); is(qr/abc/, qr/abcd/, "wrong pattern"); is(qr/abc/, exact_ref(qr/abc/), "not an exact match"); }; @$events = grep {$_->isa('Test2::Event::Fail')} @$events; is(@$events, 3, "3 fail events"); }; subtest isnt => sub { isnt('a', 'b', "a is not b"); isnt({}, [], "has is not array"); isnt(0, 1, "0 is not 1"); my $events = intercept { isnt([], []); isnt('a', 'a'); isnt(1, 1); isnt({}, {}); }; @$events = grep {$_->isa('Test2::Event::Ok')} @$events; is(@$events, 4, "4 events"); ok(!$_->{pass}, "Event was a failure") for @$events }; subtest unlike => sub { unlike('a', 'b', "a is not b"); unlike({}, [], "has is not array"); unlike(0, 1, "0 is not 1"); unlike('aaa', qr/bbb/, "aaa does not match /bbb/"); my $events = intercept { unlike([], []); unlike('a', 'a'); unlike(1, 1); unlike({}, {}); unlike( 'foo', qr/o/ ); }; @$events = grep {$_->isa('Test2::Event::Ok')} @$events; is(@$events, 5, "5 events"); ok(!$_->{pass}, "Event was a failure") for @$events }; subtest all_items_on_array => sub { like( [qw/a aa aaa/], array { all_items match qr/^a+$/; item 'a'; item 'aa'; }, "All items match regex" ); my @lines; my $array = [qw/a aa aaa/]; my $regx = qr/^b+$/; my $events = intercept { is( $array, array { all_items match $regx; push @lines => __LINE__; item 'b'; push @lines => __LINE__; item 'aa'; push @lines => __LINE__; end; }, "items do not all match, and diag reflects all issues, and in order" ); }; like( $events, array { fail_table( header => [qw/PATH GOT OP CHECK LNs/], rows => [ ['', "$array", '', "", ($lines[0] - 1) . ", " . ($lines[-1] + 2)], ['[0]', 'a', '=~', "$regx", $lines[0]], ['[0]', 'a', 'eq', 'b', $lines[1]], ['[1]', 'aa', '=~', "$regx", $lines[0]], ['[2]', 'aaa', '=~', "$regx", $lines[0]], ['[2]', 'aaa', '!exists', '', ''], ], ); }, "items do not all match, and diag reflects all issues, and in order" ); }; subtest all_items_on_bag => sub { like( [qw/a aa aaa/], bag { all_items match qr/^a+$/; item 'a'; item 'aa'; }, "All items match regex" ); my @lines; my $array = [qw/a aa aaa/]; my $regx = qr/^b+$/; my $events = intercept { is( $array, bag { all_items match $regx; push @lines => __LINE__; item 'b'; push @lines => __LINE__; item 'aa'; push @lines => __LINE__; end; }, "items do not all match, and diag reflects all issues, and in order" ); }; like( $events, array { fail_table( header => [qw/PATH GOT OP CHECK LNs/], rows => [ ['', "$array", '', "", ($lines[0] - 1) . ", " . ($lines[-1] + 2)], ['[*]', '', '', 'b', $lines[1]], ['[0]', 'a', '=~', "$regx", $lines[0]], ['[1]', 'aa', '=~', "$regx", $lines[0]], ['[2]', 'aaa', '=~', "$regx", $lines[0]], ], ); }, "items do not all match, and diag reflects all issues, and in order" ); }; subtest all_keys_and_vals => sub { is( {a => 'a', 'aa' => 'aa', 'aaa' => 'aaa'}, hash { all_values match qr/^a+$/; all_keys match qr/^a+$/; field a => 'a'; field aa => 'aa'; field aaa => 'aaa'; }, "All items match regex" ); my @lines; my $hash = {a => 'a', 'aa' => 'aa', 'aaa' => 'aaa'}; my $regx = qr/^b+$/; my $events = intercept { is( $hash, hash { all_keys match $regx; push @lines => __LINE__; all_vals match $regx; push @lines => __LINE__; field aa => 'aa'; push @lines => __LINE__; field b => 'b'; push @lines => __LINE__; end; }, "items do not all match, and diag reflects all issues, and in order" ); }; like( $events, array { fail_table( header => [qw/PATH GOT OP CHECK LNs/], rows => [ ['', "$hash", '', '', join(', ', $lines[0] - 1, $lines[-1] + 2)], ['{aa} ', 'aa', '=~', "$regx", $lines[0]], ['{aa}', 'aa', '=~', "$regx", $lines[1]], ['{b}', '', '', 'b', $lines[3]], ['{a} ', 'a', '=~', "$regx", $lines[0]], ['{a}', 'a', '=~', "$regx", $lines[1]], ['{a}', 'a', '!exists', '', '',], ['{aaa} ', 'aaa', '=~', "$regx", $lines[0]], ['{aaa}', 'aaa', '=~', "$regx", $lines[1]], ['{aaa}', 'aaa', '!exists', '', ''], ], ); }, "items do not all match, and diag reflects all issues, and in order" ); }; done_testing; Test2-Suite-0.000129/t/modules/Tools/Tester.t0000644000175000017500000001032413615053353020427 0ustar exodistexodistuse Test2::V0; use Test2::Tools::Tester qw/event_groups filter_events facets/; use Scalar::Util qw/blessed/; my $funky = sub { my $ctx = context(); $ctx->send_event( Generic => ( facet_data => { funk1 => {details => 'funk1'}, funk2 => [{details => 'funk2'}, {details => 'more funk2'}], }, ), ); $ctx->release; }; subtest event_groups => sub { my $anon = sub { my $ctx = context(); $ctx->pass_and_release('foo'); }; my $events = intercept { plan 11; pass('pass'); ok(1, 'pass'); is(1, 1, "pass"); like(1, 1, "pass"); $anon->(); $anon->(); $funky->(); }; my $groups = event_groups($events); is( $groups, { '__NA__' => [$events->[-1]], 'Test2::Tools::Basic' => { '__ALL__' => [@{$events}[0, 1, 2]], 'plan' => [$events->[0]], 'pass' => [$events->[1]], 'ok' => [$events->[2]], }, 'Test2::Tools::Compare' => { '__ALL__' => [@{$events}[3, 4]], 'is' => [$events->[3]], 'like' => [$events->[4]], }, 'main' => { '__ALL__' => [@{$events}[5, 6]], '__ANON__' => [@{$events}[5, 6]], }, }, "Events were grouped properly" ); }; subtest filter_events => sub { my $events = intercept { ok(1, "pass"); ok(0, "fail"); is(1, 1, "pass"); is(1, 2, "fail"); }; my $basic = filter_events $events => 'Test2::Tools::Basic'; my $compare = filter_events $events => 'Test2::Tools::Compare'; is(@$basic, 3, "First 2 events (and a diag) are from vasic tools"); is(@$compare, @$events - @$basic, "Other events are from compare"); is( $basic, [@{$events}[0, 1, 2]], "Verify the correct events are in the basic group" ); my $basic2 = filter_events $events => qr/ok$/; is($basic2, $basic, "Can use a regex for a filter"); }; subtest facets => sub { my $events = intercept { ok(1, "pass"); ok(0, "fail"); diag "xxx"; note "yyy"; $funky->(); my $it = sub { my $ctx = context(); $ctx->send_event( Generic => ( facet_data => { errors => [ {fatal => 1, details => "a fatal error", tag => 'error'}, {fatal => 0, details => "just an error", tag => 'error'}, ] } ) ); $ctx->release; }; $it->(); }; my $a_facets = facets assert => $events; my $i_facets = facets info => $events; my $e1_facets = facets error => $events; my $e2_facets = facets errors => $events; my $funk1 = facets funk1 => $events; my $funk2 = facets funk2 => $events; like( $a_facets, array { item { details => 'pass', pass => 1 }; item { details => 'fail', pass => 0 }; end; }, "Got both assertions" ); isa_ok($a_facets->[0], ['Test2::EventFacet::Assert'], "Blessed the facet"); like( $i_facets, array { item {details => qr/Failed test/, tag => 'DIAG'}; item {details => 'xxx', tag => 'DIAG'}; item {details => 'yyy', tag => 'NOTE'}; end; }, "Got the info facets" ); like( $e1_facets, array { item {fatal => 1, details => "a fatal error", tag => 'error'}; item {fatal => 0, details => "just an error", tag => 'error'}; end; }, "Got error facets" ); is($e1_facets, $e2_facets, "Can get facet by either the name or the key"); is($funk1, [{details => 'funk1'}], "Can use unknown facet type"); is($funk2, [{details => 'funk2'}, {details => 'more funk2'}], "Can use unknown list facet type"); ok(!blessed($funk1->[0]), "Did not bless the unknown type"); }; done_testing; Test2-Suite-0.000129/t/modules/Tools/Target.t0000644000175000017500000000056613615053353020416 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Tools::Target 'Test2::Tools::Target'; is($CLASS, 'Test2::Tools::Target', "set default var"); is(CLASS(), 'Test2::Tools::Target', "set default const"); use Test2::Tools::Target FOO => 'Test2::Tools::Target'; is($FOO, 'Test2::Tools::Target', "set custom var"); is(FOO(), 'Test2::Tools::Target', "set custom const"); done_testing; Test2-Suite-0.000129/t/modules/Tools/Basic.t0000644000175000017500000001532413615053353020207 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Tools::Basic'; { package Temp; use Test2::Tools::Basic; main::imported_ok(qw{ ok pass fail diag note todo skip plan skip_all done_testing bail_out }); } pass('Testing Pass'); my @lines; like( intercept { pass('pass'); push @lines => __LINE__; fail('fail'); push @lines => __LINE__; fail('fail', 'added diag'); push @lines => __LINE__; }, array { event Ok => sub { call pass => 1; call name => 'pass'; prop file => __FILE__; prop package => __PACKAGE__; prop line => $lines[0]; prop subname => 'Test2::Tools::Basic::pass'; }; event Ok => sub { call pass => 0; call name => 'fail'; prop file => __FILE__; prop package => __PACKAGE__; prop line => $lines[1]; prop subname => 'Test2::Tools::Basic::fail'; }; event Diag => sub { call message => qr/Failed test 'fail'.*line $lines[1]/s; prop file => __FILE__; prop package => __PACKAGE__; prop line => $lines[1]; prop subname => 'Test2::Tools::Basic::fail'; }; event Ok => sub { call pass => 0; call name => 'fail'; prop file => __FILE__; prop package => __PACKAGE__; prop line => $lines[2]; prop subname => 'Test2::Tools::Basic::fail'; }; event Diag => sub { call message => qr/Failed test 'fail'.*line $lines[2]/s; prop file => __FILE__; prop package => __PACKAGE__; prop line => $lines[2]; prop subname => 'Test2::Tools::Basic::fail'; }; event Diag => sub { call message => 'added diag'; prop file => __FILE__; prop package => __PACKAGE__; prop line => $lines[2]; prop subname => 'Test2::Tools::Basic::fail'; }; end; }, "Got expected events for 'pass' and 'fail'" ); ok(1, 'Testing ok'); @lines = (); like( intercept { ok(1, 'pass', 'invisible diag'); push @lines => __LINE__; ok(0, 'fail'); push @lines => __LINE__; ok(0, 'fail', 'added diag'); push @lines => __LINE__; }, array { event Ok => sub { call pass => 1; call name => 'pass'; prop line => $lines[0]; }; event Ok => sub { call pass => 0; call name => 'fail'; prop debug => 'at ' . __FILE__ . " line $lines[1]"; }; event Diag => sub { call message => qr/Failed test 'fail'.*line $lines[1]/s; prop debug => 'at ' . __FILE__ . " line $lines[1]"; }; event Ok => sub { call pass => 0; call name => 'fail'; prop debug => 'at ' . __FILE__ . " line $lines[2]"; }; event Diag => sub { call message => qr/Failed test 'fail'.*line $lines[2]/s; prop debug => 'at ' . __FILE__ . " line $lines[2]"; }; event Diag => sub { call message => 'added diag'; prop debug => 'at ' . __FILE__ . " line $lines[2]"; }; end; }, "Got expected events for 'ok'" ); diag "Testing Diag (AUTHOR_TESTING ONLY)" if $ENV{AUTHOR_TESTING}; like( intercept { diag "foo"; diag "foo", ' ', "bar"; }, array { event Diag => { message => 'foo' }; event Diag => { message => 'foo bar' }; }, "Got expected events for diag" ); note "Testing Note"; like( intercept { note "foo"; note "foo", ' ', "bar"; }, array { event Note => { message => 'foo' }; event Note => { message => 'foo bar' }; }, "Got expected events for note" ); like( intercept { bail_out 'oops'; # Should not get here print STDERR "Something is wrong, did not bail out!\n"; exit 255; }, array { event Bail => { reason => 'oops' }; end; }, "Got bail event" ); like( intercept { skip_all 'oops'; # Should not get here print STDERR "Something is wrong, did not skip!\n"; exit 255; }, array { event Plan => { max => 0, directive => 'SKIP', reason => 'oops' }; end; }, "Got plan (skip_all) event" ); like( intercept { plan skip_all => 'oops'; # Should not get here print STDERR "Something is wrong, did not skip!\n"; exit 255; }, array { event Plan => { max => 0, directive => 'SKIP', reason => 'oops' }; end; }, "Got plan 'skip_all' prefix" ); like( intercept { plan(5); }, array { event Plan => { max => 5 }; end; }, "Got plan" ); like( intercept { plan(tests => 5); }, array { event Plan => { max => 5 }; end; }, "Got plan 'tests' prefix" ); like( intercept { ok(1); ok(2); done_testing; }, array { event Ok => { pass => 1 }; event Ok => { pass => 1 }; event Plan => { max => 2 }; end; }, "Done Testing works" ); like( intercept { ok(0, "not todo"); { my $todo = todo('todo 1'); ok(0, 'todo fail'); } ok(0, "not todo"); my $todo = todo('todo 2'); ok(0, 'todo fail'); $todo = undef; ok(0, "not todo"); todo 'todo 3' => sub { ok(0, 'todo fail'); }; ok(0, "not todo"); }, array { for my $id (1 .. 3) { event Ok => sub { call pass => 0; call effective_pass => 0; call todo => undef; }; event Diag => { message => qr/Failed/ }; event Ok => sub { call pass => 0; call effective_pass => 1; call todo => "todo $id"; }; event Note => { message => qr/Failed/ }; } event Ok => { pass => 0, effective_pass => 0 }; event Diag => { message => qr/Failed/ }; end; }, "Got todo events" ); like( intercept { ok(1, 'pass'); SKIP: { skip 'oops' => 5; ok(1, "Should not see this"); } }, array { event Ok => { pass => 1 }; event Skip => sub { call pass => 1; call reason => 'oops'; } for 1 .. 5; end; }, "got skip events" ); done_testing; Test2-Suite-0.000129/t/modules/Tools/Defer.t0000644000175000017500000001032713615053353020211 0ustar exodistexodistuse strict; use warnings; use Test2::Tools::Defer; # HARNESS-NO-FORK my $file = __FILE__; my $START_LINE; BEGIN { $START_LINE = __LINE__; def ok => (1, "truth"); def is => (1, 1, "1 is 1"); def is => ({}, {}, "hash is hash"); def ok => (0, 'lies'); def is => (0, 1, "1 is not 0"); def is => ({}, [], "a hash is not an array"); } use Test2::Bundle::Extended -target => 'Test2::Tools::Defer'; sub capture(&) { my $code = shift; my ($err, $out) = ("", ""); my ($ok, $e); { local *STDOUT; local *STDERR; ($ok, $e) = Test2::Util::try(sub { open(STDOUT, '>', \$out) or die "Failed to open a temporary STDOUT: $!"; open(STDERR, '>', \$err) or die "Failed to open a temporary STDERR: $!"; $code->(); }); } die $e unless $ok; return { STDOUT => $out, STDERR => $err, }; } is( intercept { do_def }, array { filter_items { grep { $_->isa('Test2::Event::Ok') || $_->isa('Test2::Event::Fail') } @_ }; event Ok => sub { call pass => 1; call name => 'truth'; prop file => "(eval in Test2::Tools::Defer) " . __FILE__; prop line => $START_LINE + 1; prop package => __PACKAGE__; }; event Ok => sub { call pass => 1; call name => '1 is 1'; prop file => "(eval in Test2::Tools::Defer) " . __FILE__; prop line => $START_LINE + 2; prop package => __PACKAGE__; }; event Ok => sub { call pass => 1; call name => 'hash is hash'; prop file => "(eval in Test2::Tools::Defer) " . __FILE__; prop line => $START_LINE + 3; prop package => __PACKAGE__; }; event Ok => sub { call pass => 0; call name => 'lies'; prop file => "(eval in Test2::Tools::Defer) " . __FILE__; prop line => $START_LINE + 5; prop package => __PACKAGE__; }; event Fail => sub { call name => '1 is not 0'; prop file => "(eval in Test2::Tools::Defer) " . __FILE__; prop line => $START_LINE + 6; prop package => __PACKAGE__; }; event Fail => sub { call name => 'a hash is not an array'; prop file => "(eval in Test2::Tools::Defer) " . __FILE__; prop line => $START_LINE + 7; prop package => __PACKAGE__; }; end; }, "got expected events" ); def ok => (1, "truth"); def is => (1, 1, "1 is 1"); def is => ({}, {}, "hash is hash"); # Actually run some that pass do_def(); like( dies { do_def() }, qr/No tests to run/, "Fails if there are no tests" ); my $line1 = __LINE__ + 1; sub oops { die 'oops' } my $line2 = __LINE__ + 1; def oops => (1); like( dies { do_def() }, < (1, "pass"); } def ok => (1, "pass"); my $new_exit = 0; my $out = capture { Test2::Tools::Defer::_verify(undef, 0, \$new_exit) }; is($new_exit, 255, "exit set to 255 due to unrun tests"); like( $out->{STDOUT}, qr/not ok - deferred tests were not run/, "Got failed STDOUT line" ); like( $out->{STDERR}, qr/# 'main' has deferred tests that were never run/, "We see that main failed" ); like( $out->{STDERR}, qr/# 'Foo' has deferred tests that were never run/, "We see that Foo failed" ); } { local $? = 101; def ok => (1, "pass"); my $out = capture { Test2::Tools::Defer::_verify() }; is($?, 101, "did not change exit code"); like( $out->{STDOUT}, qr/not ok - deferred tests were not run/, "Got failed STDOUT line" ); like( $out->{STDERR}, qr/# 'main' has deferred tests that were never run/, "We see that main failed" ); } done_testing; Test2-Suite-0.000129/t/modules/Tools/Class.t0000644000175000017500000001120213615053353020222 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Tools::Class'; { package Temp; use Test2::Tools::Class; main::imported_ok(qw/can_ok isa_ok DOES_ok/); } { package X; sub can { my $thing = pop; return 1 if $thing =~ m/x/; return 1 if $thing eq 'DOES'; } sub isa { my $thing = pop; return 1 if $thing =~ m/x/; } sub DOES { my $thing = pop; return 1 if $thing =~ m/x/; } } { package XYZ; use Carp qw/croak/; sub isa { croak 'oops' }; sub can { croak 'oops' }; sub DOES { croak 'oops' }; } { package My::String; use overload '""' => sub { "xxx\nyyy" }; sub DOES { 0 } } like( intercept { my $str = bless {}, 'My::String'; isa_ok('X', qw/axe box fox/); can_ok('X', qw/axe box fox/); DOES_ok('X', qw/axe box fox/); isa_ok($str, 'My::String'); isa_ok('X', qw/foo bar axe box/); can_ok('X', qw/foo bar axe box/); DOES_ok('X', qw/foo bar axe box/); isa_ok($str, 'X'); can_ok($str, 'X'); DOES_ok($str, 'X'); isa_ok(undef, 'X'); isa_ok('', 'X'); isa_ok({}, 'X'); isa_ok('X', [qw/axe box fox/], 'alt name'); can_ok('X', [qw/axe box fox/], 'alt name'); DOES_ok('X', [qw/axe box fox/], 'alt name'); isa_ok('X', [qw/foo bar axe box/], 'alt name'); can_ok('X', [qw/foo bar axe box/], 'alt name'); DOES_ok('X', [qw/foo bar axe box/], 'alt name'); }, array { event Ok => { pass => 1, name => 'X->isa(...)' }; event Ok => { pass => 1, name => 'X->can(...)' }; event Ok => { pass => 1, name => 'X->DOES(...)' }; event Ok => { pass => 1, name => qr/My::String=.*->isa\('My::String'\)/ }; fail_events Ok => sub { call pass => 0 }; event Diag => {message => "Failed: X->isa('foo')"}; event Diag => {message => "Failed: X->isa('bar')"}; fail_events Ok => sub { call pass => 0 }; event Diag => { message => "Failed: X->can('foo')" }; event Diag => { message => "Failed: X->can('bar')" }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => "Failed: X->DOES('foo')" }; event Diag => { message => "Failed: X->DOES('bar')" }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => qr/Failed: My::String=HASH->isa\('X'\)/ }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => qr/Failed: My::String=HASH->can\('X'\)/ }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => qr/Failed: My::String=HASH->DOES\('X'\)/ }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => qr/ is neither a blessed reference or a package name/ }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => qr/'' is neither a blessed reference or a package name/ }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => qr/HASH is neither a blessed reference or a package name/ }; event Ok => { pass => 1, name => 'alt name' }; event Ok => { pass => 1, name => 'alt name' }; event Ok => { pass => 1, name => 'alt name' }; fail_events Ok => sub { call pass => 0; call name => 'alt name' }; event Diag => {message => "Failed: X->isa('foo')"}; event Diag => {message => "Failed: X->isa('bar')"}; fail_events Ok => sub { call pass => 0; call name => 'alt name' }; event Diag => {message => "Failed: X->can('foo')"}; event Diag => {message => "Failed: X->can('bar')"}; fail_events Ok => sub { call pass => 0; call name => 'alt name' }; event Diag => {message => "Failed: X->DOES('foo')"}; event Diag => {message => "Failed: X->DOES('bar')"}; end; }, "'can/isa/DOES_ok' events" ); my $override = UNIVERSAL->can('DOES') ? 1 : 0; note "Will override UNIVERSAL::can to hide 'DOES'" if $override; my $events = intercept { my $can = \&UNIVERSAL::can; # If the platform does support 'DOES' lets pretend it doesn't. no warnings 'redefine'; local *UNIVERSAL::can = sub { my ($thing, $sub) = @_; return undef if $sub eq 'DOES'; $thing->$can($sub); } if $override; DOES_ok('A::Fake::Package', 'xxx'); }; like( $events, array { event Skip => { pass => 1, name => "A::Fake::Package->DOES('xxx')", reason => "'DOES' is not supported on this platform", }; }, "Test us skipped when platform does not support 'DOES'" ); done_testing; Test2-Suite-0.000129/t/modules/Tools/Event.t0000644000175000017500000000073613615053353020250 0ustar exodistexodistuse Test2::Bundle::Extended; imported_ok('gen_event'); my $e = gen_event Ok => (pass => 1, name => 'foo'); my $c = event Ok => {pass => 1, name => 'foo', trace => {frame => [__PACKAGE__, __FILE__, __LINE__ - 1]}}; like($e, $c, "Generated event"); $e = gen_event '+Test2::Event::Ok' => (pass => 1, name => 'foo'); $c = event Ok => {pass => 1, name => 'foo', trace => {frame => [__PACKAGE__, __FILE__, __LINE__ - 1]}}; like($e, $c, "Generated event long-form"); done_testing; Test2-Suite-0.000129/t/modules/Tools/Mock.t0000644000175000017500000001761513615053353020064 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Compare::Custom'; use Test2::Tools::Mock qw{ mock_obj mock_class mock_do mock_build mock_accessor mock_accessors mock_getter mock_getters mock_setter mock_setters mock_building }; use Scalar::Util qw/reftype blessed/; imported_ok qw{ mock_obj mock_class mock_do mock_build mock_accessor mock_accessors mock_getter mock_getters mock_setter mock_setters mock_building }; subtest generators => sub { # These are all thin wrappers around HashBase subs, we just test that we # get subs, HashBase subtest that the thing we are wrapping produce the # correct type of subs. my %accessors = mock_accessors qw/foo bar baz/; is([sort keys %accessors], [sort qw/foo bar baz/], "All 3 keys set"); is(reftype($accessors{$_}), 'CODE', "sub as value for $_") for qw/foo bar baz/; is(reftype(mock_accessor('xxx')), 'CODE', "Generated an accessor"); my %getters = mock_getters 'get_' => qw/foo bar baz/; is([sort keys %getters], [sort qw/get_foo get_bar get_baz/], "All 3 keys set"); is(reftype($getters{"get_$_"}), 'CODE', "sub as value for get_$_") for qw/foo bar baz/; is(reftype(mock_getter('xxx')), 'CODE', "Generated a getter"); my %setters = mock_setters 'set_' => qw/foo bar baz/; is([sort keys %setters], [sort qw/set_foo set_bar set_baz/], "All 3 keys set"); is(reftype($setters{"set_$_"}), 'CODE', "sub as value for set_$_") for qw/foo bar baz/; is(reftype(mock_setter('xxx')), 'CODE', "Generated a setter"); }; subtest mocks => sub { my $inst; my $control; my $class; my $object = sub { $inst = mock_obj({}, add_constructor => [new => 'hash']); ($control) = mocked($inst); $class = $control->class; }; my $package = sub { $control = mock_class('Fake::Class', add_constructor => [new => 'hash']); $class = $control->class; $inst = $class->new; }; for my $case ($object, $package) { $case->(); isa_ok($control, 'Test2::Mock'); isa_ok($inst, $class); ok($class, "got a class"); subtest mocked => sub { ok(!mocked('main'), "main class is not mocked"); is(mocked($inst), 1, "Only 1 control object for this instance"); my ($c) = mocked($inst); ref_is($c, $control, "got correct control when checking if an object was mocked"); my $control2 = mock_class($control->class); is(mocked($inst), 2, "now 2 control objects for this instance"); my ($c1, $c2) = mocked($inst); ref_is($c1, $control, "got first control"); ref_is($c2, $control2, "got second control"); }; subtest build_and_do => sub { like( dies { mock_build(undef, sub { 1 }) }, qr/mock_build requires a Test2::Mock object as its first argument/, "control is required", ); like( dies { mock_build($control, undef) }, qr/mock_build requires a coderef as its second argument/, "Must have a coderef to build" ); like( dies { mock_do add => (foo => sub { 'foo' }) }, qr/Not currently building a mock/, "mock_do outside of a build fails" ); ok(!mock_building, "no mock is building"); my $ran = 0; mock_build $control => sub { is(mock_building, $control, "Building expected control"); like( dies { mock_do 'foo' => 1 }, qr/'foo' is not a valid action for mock_do\(\)/, "invalid action" ); mock_do add => ( foo => sub { 'foo' }, ); can_ok($inst, 'foo'); is($inst->foo, 'foo', "added sub"); $ran++; }; ok(!mock_building, "no mock is building"); ok($ran, "build sub completed successfully"); }; } }; subtest mock_obj => sub { my $ref = {}; my $obj = mock_obj $ref; is($ref, $obj, "blessed \$ref"); is($ref->foo(1), 1, "is vivifying object"); my $ran = 0; $obj = mock_obj(sub { $ran++ }); is($ref->foo(1), 1, "is vivifying object"); is($ran, 1, "code ran"); $obj = mock_obj { foo => 'foo' } => ( add => [ bar => sub { 'bar' }], ); # We need to test the methods returned by ->can before we call the subs by # name. This lets us be sure that this works _before_ the AUTOLOAD # actually creates the named sub for real. my $foo = $obj->can('foo'); $obj->$foo('foo2'); is($obj->$foo, 'foo2', "->can('foo') returns a method that works as a setter"); $obj->$foo('foo'); my $bar = $obj->can('bar'); is($obj->$bar, 'bar', "->can('bar') returns a method"); ok(!$obj->can('baz'), "mock object ->can returns false for baz"); is($obj->foo, 'foo', "got value for foo"); is($obj->bar, 'bar', "got value for bar"); ok($obj->can('foo'), "mock object ->can returns true for foo"); ok($obj->can('bar'), "mock object ->can returns true for bar"); ok($obj->can('isa'), "mock object ->can returns true for isa"); $foo = $obj->can('foo'); my ($c) = mocked($obj); ok($c, "got control"); is($obj->{'~~MOCK~CONTROL~~'}, $c, "control is stashed"); my $class = $c->class; my $file = $c->file; ok($INC{$file}, "Mocked Loaded"); $obj = undef; $c = undef; ok(!$INC{$file}, "Not loaded anymore"); }; subtest mock_class_basic => sub { my $c = mock_class 'Fake'; isa_ok($c, 'Test2::Mock'); is($c->class, 'Fake', "Control for 'Fake'"); $c = undef; # Check with an instance my $i = bless {}, 'Fake'; $c = mock_class $i; isa_ok($c, 'Test2::Mock'); is($c->class, 'Fake', "Control for 'Fake'"); is([mocked($i)], [$c], "is mocked"); }; subtest post => sub { ok(!"Fake$_"->can('check'), "mock $_ did not leak") for 1 .. 5; }; ok(!"Fake$_"->can('check'), "mock $_ did not leak") for 1 .. 5; subtest just_mock => sub { like( dies { mock undef }, qr/undef is not a valid first argument to mock/, "Cannot mock undef" ); like( dies { mock 'fakemethodname' }, qr/'fakemethodname' does not look like a package name, and is not a valid control method/, "invalid mock arg" ); my $c = mock 'Fake'; isa_ok($c, 'Test2::Mock'); is($c->class, 'Fake', "mocked correct class"); mock $c => sub { mock add => (foo => sub { 'foo' }); }; can_ok('Fake', 'foo'); is(Fake->foo(), 'foo', "mocked build, mocked do"); my $o = mock; ok(blessed($o), "created object"); $c = mocked($o); ok($c, "got control"); $o = mock { foo => 'foo' }; is($o->foo, 'foo', "got the expected result"); is($o->{foo}, 'foo', "blessed the reference"); $c = mock $o; isa_ok($o, $c->class); my $code = mock accessor => 'foo'; ok(reftype($code), 'CODE', "Generated an accessor"); }; subtest handlers => sub { Test2::Tools::Mock->add_handler(__PACKAGE__, sub { is( {@_}, { class => 'Foo', caller => T(), builder => T(), args => T(), } ); 1; } ); is( dies { mock Foo => {add => ['xxx' => sub { 'xxx' }]} }, undef, "did not die" ); }; subtest set => sub { package My::Set; sub foo { 'foo' } package main; my $mock = mock 'My::Set' => ( set => [ foo => sub { 'FOO' }, bar => sub { 'BAR' }, ], ); is(My::Set->foo, 'FOO', "overrode 'foo'"); is(My::Set->bar, 'BAR', "injected 'bar'"); }; done_testing; Test2-Suite-0.000129/t/modules/Tools/Spec.t0000644000175000017500000000014013615053353020046 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Tools::Spec'; skip_all "Tests not yet written"; Test2-Suite-0.000129/t/modules/Tools/Grab.t0000644000175000017500000000110413615053353020030 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Util::Grabber'; use Test2::Tools::Grab; ok(1, "initializing"); my $grab = grab(); ok(1, "pass"); my $one = $grab->events; ok(0, "fail"); my $events = $grab->finish; is(@$one, 1, "Captured 1 event"); is(@$events, 3, "Captured 3 events"); like( $one, array { event Ok => { pass => 1 }; }, "Got expected event" ); like( $events, array { event Ok => { pass => 1 }; event Ok => { pass => 0 }; event Diag => { }; end; }, "Got expected events" ); done_testing; Test2-Suite-0.000129/t/modules/Tools/Ref.t0000644000175000017500000000545613615053353017707 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Tools::Ref'; { package Temp; use Test2::Tools::Ref; main::imported_ok(qw/ref_ok ref_is ref_is_not/); } like( intercept { ref_ok({}); ref_ok({}, 'HASH', 'pass'); ref_ok([], 'ARRAY', 'pass'); ref_ok({}, 'ARRAY', 'fail'); ref_ok('xxx'); ref_ok('xxx', 'xxx'); }, array { event Ok => { pass => 1 }; event Ok => { pass => 1 }; event Ok => { pass => 1 }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => qr/'HASH\(.*\)' is not a 'ARRAY' reference/ }; fail_events Ok => { pass => 0 }; event Diag => { message => qr/'xxx' is not a reference/ }; fail_events Ok => { pass => 0 }; event Diag => { message => qr/'xxx' is not a reference/ }; end; }, "ref_ok tests" ); my $x = []; my $y = []; like( intercept { ref_is($x, $x, 'same x'); ref_is($x, $y, 'not same'); ref_is_not($x, $y, 'not same'); ref_is_not($y, $y, 'same y'); ref_is('x', $x, 'no ref'); ref_is($x, 'x', 'no ref'); ref_is_not('x', $x, 'no ref'); ref_is_not($x, 'x', 'no ref'); ref_is(undef, $x, 'undef'); ref_is($x, undef, 'undef'); ref_is_not(undef, $x, 'undef'); ref_is_not($x, undef, 'undef'); }, array { event Ok => sub { call pass => 1 }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => "'$x' is not the same reference as '$y'" }; event Ok => sub { call pass => 1 }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => "'$y' is the same reference as '$y'" }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => "First argument 'x' is not a reference" }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => "Second argument 'x' is not a reference" }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => "First argument 'x' is not a reference" }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => "Second argument 'x' is not a reference" }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => "First argument '' is not a reference" }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => "Second argument '' is not a reference" }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => "First argument '' is not a reference" }; fail_events Ok => sub { call pass => 0 }; event Diag => { message => "Second argument '' is not a reference" }; end; }, "Ref checks" ); done_testing; Test2-Suite-0.000129/t/modules/Util/0000755000175000017500000000000013615053353016611 5ustar exodistexodistTest2-Suite-0.000129/t/modules/Util/Table/0000755000175000017500000000000013615053353017640 5ustar exodistexodistTest2-Suite-0.000129/t/modules/Util/Table/LineBreak.t0000644000175000017500000000313213615053353021660 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Util::Table::LineBreak; BEGIN { $ENV{TABLE_TERM_SIZE} = 80 } subtest with_unicode_linebreak => sub { my $one = Test2::Util::Table::LineBreak->new(string => 'aaaa婧bbbb'); $one->break(3); is( [ map { $one->next } 1 .. 5 ], [ 'aaa', 'a婧', 'bbb', 'b ', undef ], "Got all parts" ); $one = Test2::Util::Table::LineBreak->new(string => 'a婧bb'); $one->break(2); is( [ map { $one->next } 1 .. 4 ], [ 'a ', '婧', 'bb', undef ], "Padded the problem" ); } if $INC{'Unicode/LineBreak.pm'}; subtest without_unicode_linebreak => sub { my @parts; { local %INC = %INC; delete $INC{'Unicode/GCString.pm'}; my $one = Test2::Util::Table::LineBreak->new(string => 'aaaa婧bbbb'); $one->break(3); @parts = map { $one->next } 1 .. 5; } todo "Can't handle unicode properly without Unicode::GCString" => sub { is( \@parts, [ 'aaa', 'a婧', 'bbb', 'b ', undef ], "Got all parts" ); }; my $one = Test2::Util::Table::LineBreak->new(string => 'aaabbbx'); $one->break(2); is( [ map { $one->next } 1 .. 5 ], [ 'aa', 'ab', 'bb', 'x ', undef ], "Padded the problem" ); }; done_testing; Test2-Suite-0.000129/t/modules/Util/Table/Cell.t0000644000175000017500000000306213615053353020705 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Util::Table::Cell'; subtest sanitization => sub { my $unsanitary = <<" EOT"; This string has vertical space including        

 ‌\N{U+000B}unicode stuff and some non-whitespace ones: 婧 ʶ ๖ EOT my $sanitary = 'This string\nhas vertical space\nincluding\N{U+A0}\N{U+1680}\N{U+2000}\N{U+2001}\N{U+2002}\N{U+2003}\N{U+2004}\N{U+2008}\N{U+2028}\N{U+2029}\N{U+3000}\N{U+200C}\N{U+FEFF}\N{U+B}unicode stuff\nand some non-whitespace ones: 婧 ʶ ๖\n'; $sanitary =~ s/\\n/\\n\n/g; local *show_char = sub { Test2::Util::Table::Cell->show_char(@_) }; # Common control characters is(show_char("\a"), '\a', "translated bell"); is(show_char("\b"), '\b', "translated backspace"); is(show_char("\e"), '\e', "translated escape"); is(show_char("\f"), '\f', "translated formfeed"); is(show_char("\n"), "\\n\n", "translated newline"); is(show_char("\r"), '\r', "translated return"); is(show_char("\t"), '\t', "translated tab"); is(show_char(" "), ' ', "plain space is not translated"); # unicodes is(show_char("婧"), '\N{U+5A67}', "translated unicode 婧 (U+5A67)"); is(show_char("ʶ"), '\N{U+2B6}', "translated unicode ʶ (U+2B6)"); is(show_char("߃"), '\N{U+7C3}', "translated unicode ߃ (U+7C3)"); is(show_char("๖"), '\N{U+E56}', "translated unicode ๖ (U+E56)"); my $cell = CLASS->new(value => $unsanitary); $cell->sanitize; is($cell->value, $sanitary, "Sanitized string"); }; done_testing; Test2-Suite-0.000129/t/modules/Util/Grabber.t0000644000175000017500000000106013615053353020337 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Util::Grabber'; ok(1, "initializing"); my $grab = $CLASS->new; ok(1, "pass"); my $one = $grab->events; ok(0, "fail"); my $events = $grab->finish; is(@$one, 1, "Captured 1 event"); is(@$events, 3, "Captured 3 events"); like( $one, array { event Ok => { pass => 1 }; }, "Got expected event" ); like( $events, array { event Ok => { pass => 1 }; event Ok => { pass => 0 }; event Diag => { }; end; }, "Got expected events" ); done_testing; Test2-Suite-0.000129/t/modules/Util/Times.t0000644000175000017500000000205013615053353020054 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Util::Times qw/render_bench/; imported_ok qw{ render_bench }; sub TM() { 0.5 } is( render_bench(0, 2.123456, TM, TM, TM, TM), "2.12346s on wallclock (0.50 usr 0.50 sys + 0.50 cusr 0.50 csys = 2.00 CPU)", "Got benchmark with < 10 second duration" ); is( render_bench(0, 42.123456, TM, TM, TM, TM), "42.1235s on wallclock (0.50 usr 0.50 sys + 0.50 cusr 0.50 csys = 2.00 CPU)", "Got benchmark with < 1 minute duration" ); is( render_bench(0, 422.123456, TM, TM, TM, TM), "07m:02.12s on wallclock (0.50 usr 0.50 sys + 0.50 cusr 0.50 csys = 2.00 CPU)", "Got benchmark with minute+ duration" ); is( render_bench(0, 10422.123456, TM, TM, TM, TM), "02h:53m:42.12s on wallclock (0.50 usr 0.50 sys + 0.50 cusr 0.50 csys = 2.00 CPU)", "Got benchmark with hour+ duration" ); is( render_bench(0, 501023.123456, TM, TM, TM, TM), "05d:19h:10m:23.12s on wallclock (0.50 usr 0.50 sys + 0.50 cusr 0.50 csys = 2.00 CPU)", "Got benchmark with day+ duration" ); done_testing; Test2-Suite-0.000129/t/modules/Util/Stash.t0000644000175000017500000000632513615053353020066 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Util::Stash'; use Test2::Util::Stash qw{ get_stash get_glob get_symbol parse_symbol purge_symbol slot_to_sig sig_to_slot }; imported_ok qw{ get_stash get_glob get_symbol parse_symbol purge_symbol slot_to_sig sig_to_slot }; is(slot_to_sig('CODE'), '&', "Code slot sigil"); is(slot_to_sig('SCALAR'), '$', "Scalar slot sigil"); is(slot_to_sig('HASH'), '%', "Hash slot sigil"); is(slot_to_sig('ARRAY'), '@', "Array slot sigil"); is(sig_to_slot('&'), 'CODE', "Code slot sigil"); is(sig_to_slot('$'), 'SCALAR', "Scalar slot sigil"); is(sig_to_slot('%'), 'HASH', "Hash slot sigil"); is(sig_to_slot('@'), 'ARRAY', "Array slot sigil"); is(get_stash('main'), string(\%main::), "got stash"); is(get_glob('main::ok'), \*main::ok, "got glob ref"); is( parse_symbol("foo"), { name => 'foo', sigil => '&', type => 'CODE', symbol => '&main::foo', package => 'main', }, "Parsed simple sub" ); is( parse_symbol("&foo"), { name => 'foo', sigil => '&', type => 'CODE', symbol => '&main::foo', package => 'main', }, "Parsed simple sub with sigil" ); is( parse_symbol("&::foo"), { name => 'foo', sigil => '&', type => 'CODE', symbol => '&main::foo', package => 'main', }, "Parsed ::sub with sigil" ); is( parse_symbol("&Foo::Bar::foo"), { name => 'foo', sigil => '&', type => 'CODE', symbol => '&Foo::Bar::foo', package => 'Foo::Bar', }, "Parsed sub with package" ); is( parse_symbol('$foo'), { name => 'foo', sigil => '$', type => 'SCALAR', symbol => '$main::foo', package => 'main', }, "Parsed scalar" ); is( parse_symbol('%foo'), { name => 'foo', sigil => '%', type => 'HASH', symbol => '%main::foo', package => 'main', }, "Parsed hash" ); is( parse_symbol('@foo'), { name => 'foo', sigil => '@', type => 'ARRAY', symbol => '@main::foo', package => 'main', }, "Parsed array" ); is( parse_symbol('@foo', 'XYZ::ABC'), { name => 'foo', sigil => '@', type => 'ARRAY', symbol => '@XYZ::ABC::foo', package => 'XYZ::ABC', }, "Parsed with custom package" ); like( dies { parse_symbol('ABC::foo', 'XYZ') }, qr/Symbol package \(ABC\) and package argument \(XYZ\) do not match/, "Got exception" ); like( dies { parse_symbol({package => 'ABC'}, 'XYZ') }, qr/Symbol package \(ABC\) and package argument \(XYZ\) do not match/, "Got exception" ); sub xxx { 'xxx' } our $foo = 'xyz'; ref_is(get_symbol('xxx'), \&xxx, "got ref for &xxx"); ref_is(get_symbol('$foo'), \$foo, 'got ref for $foo'); is(get_symbol('blah'), undef, 'no ref for &blah'); is(get_symbol('$blah'), undef, 'no ref for $blah'); purge_symbol('xxx'); ok(!__PACKAGE__->can('xxx'), "removed &xxx symbol test 1"); is(get_symbol('xxx'), undef, "removed &xxx symbol test 2"); done_testing; Test2-Suite-0.000129/t/modules/Util/Table.t0000644000175000017500000001743313615053353020035 0ustar exodistexodistuse Test2::Bundle::Extended; BEGIN { $ENV{TABLE_TERM_SIZE} = 80 } use Test2::Util::Table qw/table/; use Test2::Util::Term qw/USE_GCS/; imported_ok qw/table/; subtest unicode_display_width => sub { my $wide = "foo bar baz 婧"; my $have_gcstring = eval { require Unicode::GCString; 1 }; subtest no_unicode_linebreak => sub { my @table = table('header' => [ 'a', 'b'], 'rows' => [[ '婧', '߃' ]]); like( \@table, ["Unicode::GCString is not installed, table may not display all unicode characters properly"], "got unicode note" ); } unless USE_GCS; subtest with_unicode_linebreak => sub { my @table = table( 'header' => [ 'a', 'b'], 'rows' => [[ 'a婧b', '߃' ]], 'max_width' => 80, ); is( \@table, [ '+------+---+', '| a | b |', '+------+---+', '| a婧b | ߃ |', '+------+---+', ], "Support for unicode characters that use multiple columns" ); } if USE_GCS; }; subtest width => sub { my @table = table( max_width => 40, header => [ 'a', 'b', 'c', 'd' ], rows => [ [ qw/aaaaaaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccccc ddddddddddddddddddddddddddddd/ ], [ qw/AAAAAAAAAAAAAAAAAAAAAAAAAA BBBBBBBBBBBBBBBBBBBBB CCCCCCCCCCCCCCCCCCCCCCC DDDDDDDDDDDDDDDDDDDDDDDDDDDDD/ ], ], ); is(length($table[0]), validator('<=', '40', sub { my %p = @_; $p{got} <= $p{name} }), "width of table"); is( \@table, [ '+-------+-------+-------+-------+', '| a | b | c | d |', '+-------+-------+-------+-------+', '| aaaaa | bbbbb | ccccc | ddddd |', '| aaaaa | bbbbb | ccccc | ddddd |', '| aaaaa | bbbbb | ccccc | ddddd |', '| aaaaa | bbbbb | ccccc | ddddd |', '| aaaaa | b | ccc | ddddd |', '| a | | | dddd |', '| | | | |', '| AAAAA | BBBBB | CCCCC | DDDDD |', '| AAAAA | BBBBB | CCCCC | DDDDD |', '| AAAAA | BBBBB | CCCCC | DDDDD |', '| AAAAA | BBBBB | CCCCC | DDDDD |', '| AAAAA | B | CCC | DDDDD |', '| A | | | DDDD |', '+-------+-------+-------+-------+', ], "Basic table, small width" ); @table = table( max_width => 60, header => [ 'a', 'b', 'c', 'd' ], rows => [ [ qw/aaaaaaaaaaaaaaaaaaaaaaaaaa bbbbbbbbbbbbbbbbbbbbb ccccccccccccccccccccccc ddddddddddddddddddddddddddddd/ ], [ qw/AAAAAAAAAAAAAAAAAAAAAAAAAA BBBBBBBBBBBBBBBBBBBBB CCCCCCCCCCCCCCCCCCCCCCC DDDDDDDDDDDDDDDDDDDDDDDDDDDDD/ ], ], ); is(length($table[0]), validator('<=', '60', sub { my %p = @_; $p{got} <= $p{name} }), "width of table"); is( \@table, [ '+------------+------------+------------+------------+', '| a | b | c | d |', '+------------+------------+------------+------------+', '| aaaaaaaaaa | bbbbbbbbbb | cccccccccc | dddddddddd |', '| aaaaaaaaaa | bbbbbbbbbb | cccccccccc | dddddddddd |', '| aaaaaa | b | ccc | ddddddddd |', '| | | | |', '| AAAAAAAAAA | BBBBBBBBBB | CCCCCCCCCC | DDDDDDDDDD |', '| AAAAAAAAAA | BBBBBBBBBB | CCCCCCCCCC | DDDDDDDDDD |', '| AAAAAA | B | CCC | DDDDDDDDD |', '+------------+------------+------------+------------+', ], "Basic table, bigger width" ); @table = table( max_width => 60, header => [ 'a', 'b', 'c', 'd' ], rows => [ [ qw/aaaa bbbb cccc dddd/ ], [ qw/AAAA BBBB CCCC DDDD/ ], ], ); is(length($table[0]), validator('<=', '60', sub { my %p = @_; $p{got} <= $p{name} }), "width of table"); is( \@table, [ '+------+------+------+------+', '| a | b | c | d |', '+------+------+------+------+', '| aaaa | bbbb | cccc | dddd |', '| AAAA | BBBB | CCCC | DDDD |', '+------+------+------+------+', ], "Short table, well under minimum", ); }; subtest collapse => sub { my @table = table( max_width => 60, collapse => 1, header => [ 'a', 'b', 'c', 'd' ], rows => [ [ qw/aaaa bbbb/, undef, qw/dddd/ ], [ qw/AAAA BBBB/, '', qw/DDDD/ ], ], ); is( \@table, [ '+------+------+------+', '| a | b | d |', '+------+------+------+', '| aaaa | bbbb | dddd |', '| AAAA | BBBB | DDDD |', '+------+------+------+', ], "Table collapsed", ); @table = table( max_width => 60, header => [ 'a', 'b', 'c', 'd' ], rows => [ [ qw/aaaa bbbb/, undef, qw/dddd/ ], [ qw/AAAA BBBB/, '', qw/DDDD/ ], ], ); is( \@table, [ '+------+------+---+------+', '| a | b | c | d |', '+------+------+---+------+', '| aaaa | bbbb | | dddd |', '| AAAA | BBBB | | DDDD |', '+------+------+---+------+', ], "Table not collapsed", ); @table = table( max_width => 60, collapse => 1, header => [ 'a', 'b', 'c', 'd' ], rows => [ [ qw/aaaa bbbb/, undef, qw/dddd/ ], [ qw/AAAA BBBB/, 0, qw/DDDD/ ], ], ); is( \@table, [ '+------+------+---+------+', '| a | b | c | d |', '+------+------+---+------+', '| aaaa | bbbb | | dddd |', '| AAAA | BBBB | 0 | DDDD |', '+------+------+---+------+', ], "'0' value does not cause collapse", ); }; subtest header => sub { my @table = table( max_width => 60, header => [ 'a', 'b', 'c', 'd' ], rows => [ [ qw/aaaa bbbb cccc dddd/ ], [ qw/AAAA BBBB CCCC DDDD/ ], ], ); is( \@table, [ '+------+------+------+------+', '| a | b | c | d |', '+------+------+------+------+', '| aaaa | bbbb | cccc | dddd |', '| AAAA | BBBB | CCCC | DDDD |', '+------+------+------+------+', ], "Table with header", ); }; subtest no_header => sub { my @table = table( max_width => 60, rows => [ [ qw/aaaa bbbb cccc dddd/ ], [ qw/AAAA BBBB CCCC DDDD/ ], ], ); is( \@table, [ '+------+------+------+------+', '| aaaa | bbbb | cccc | dddd |', '| AAAA | BBBB | CCCC | DDDD |', '+------+------+------+------+', ], "Table without header", ); }; subtest mark_tail => sub { my @table = table( max_width => 60, mark_tail => 1, header => [ 'data1', 'data2' ], rows => [[" abc def ", " abc def \t"]], ); is( \@table, [ '+----------------------+----------------+', '| data1 | data2 |', '+----------------------+----------------+', '| abc def \N{U+20} | abc def \t |', '+----------------------+----------------+', ], "Sanitized data" ); }; done_testing; Test2-Suite-0.000129/t/modules/Util/Ref.t0000644000175000017500000000204513615053353017513 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Util::Ref qw/rtype render_ref/; imported_ok qw{ render_ref rtype }; { package Test::A; package Test::B; use overload '""' => sub { 'A Bee!' }; } my $ref = {a => 1}; is(render_ref($ref), "$ref", "Matches normal stringification (not blessed)"); like(render_ref($ref), qr/HASH\(0x[0-9A-F]+\)/i, "got address"); bless($ref, 'Test::A'); is(render_ref($ref), "$ref", "Matches normal stringification (blessed)"); like(render_ref($ref), qr/Test::A=HASH\(0x[0-9A-F]+\)/i, "got address and package (no overload)"); bless($ref, 'Test::B'); like(render_ref($ref), qr/Test::B=HASH\(0x[0-9A-F]+\)/i, "got address and package (with overload)"); my $x = ''; $ref = \$x; is(rtype(undef), '', "not a ref"); is(rtype(''), '', "not a ref"); is(rtype({}), 'HASH', "HASH"); is(rtype([]), 'ARRAY', "ARRAY"); is(rtype($ref), 'SCALAR', "SCALAR"); is(rtype(\$ref), 'REF', "REF"); is(rtype(sub { 1 }), 'CODE', "CODE"); is(rtype(qr/xxx/), 'REGEXP', "REGEXP"); done_testing; Test2-Suite-0.000129/t/modules/Util/Sub.t0000644000175000017500000000120113615053353017521 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Util::Sub qw{ sub_name }; imported_ok qw{ sub_name }; sub named { 'named' } *unnamed = sub { 'unnamed' }; like(sub_name(\&named), qr/named$/, "got sub name (named)"); like(sub_name(\&unnamed), qr/__ANON__$/, "got sub name (anon)"); like( dies { sub_name() }, qr/sub_name requires a coderef as its only argument/, "Need an arg" ); like( dies { sub_name('xxx') }, qr/sub_name requires a coderef as its only argument/, "Need a ref" ); like( dies { sub_name({}) }, qr/sub_name requires a coderef as its only argument/, "Need a code ref" ); done_testing; Test2-Suite-0.000129/t/modules/Workflow.t0000644000175000017500000000013513615053353017672 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Workflow'; skip_all "Tests not yet written"; Test2-Suite-0.000129/t/modules/Require.t0000644000175000017500000000151413615053353017476 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Require; pass "Loaded Test2::Require"; like( dies { Test2::Require->skip() }, qr/Class 'Test2::Require' needs to implement 'skip\(\)'/, "skip must be overriden" ); my $x; { package Require::Foo; use base 'Test2::Require'; sub skip { $x } } my $events = intercept { $x = undef; Require::Foo->import(); ok(1, 'pass'); }; like( $events, array { event Ok => {pass => 1, name => 'pass'}; }, "Did not skip all" ); $events = intercept { $x = "This should skip"; Require::Foo->import(); die "Should not get here"; }; like( $events, array { event Plan => { max => 0, directive => 'SKIP', reason => 'This should skip', }; }, "Skipped all" ); done_testing; Test2-Suite-0.000129/t/modules/Compare.t0000644000175000017500000000735113615053353017455 0ustar exodistexodistuse Test2::Tools::Defer; use strict; use warnings; # Make sure convert loads necessary modules (must do before loading the # extended bundle) BEGIN { require Test2::Compare; def ok => (defined Test2::Compare::convert(undef), "convert returned something to us"); def ok => ($INC{'Test2/Compare/Undef.pm'}, "loaded the Test2::Compare::Undef module"); } use Test2::Bundle::Extended; use Test2::API qw/intercept/; use Data::Dumper; use Test2::Compare qw{ compare get_build push_build pop_build build strict_convert relaxed_convert }; pass "Loaded Test2::Compare"; imported_ok qw{ compare get_build push_build pop_build build strict_convert relaxed_convert }; do_def; { package Fake::Check; sub run { my $self = shift; return {@_, self => $self} } } my $check = bless {}, 'Fake::Check'; my $convert = sub { $_[-1]->{ran}++; $_[-1] }; my $got = compare('foo', $check, $convert); like( $got, { self => {ran => 1}, id => undef, got => 'foo', convert => sub { $_ == $convert }, seen => {}, }, "check got expected args" ); is(get_build(), undef, "no build"); like( dies { pop_build(['a']) }, qr/INTERNAL ERROR: Attempted to pop incorrect build, have undef, tried to pop ARRAY/, "Got error popping from nothing" ); push_build(['a']); is(get_build(), ['a'], "pushed build"); like( dies { pop_build() }, qr/INTERNAL ERROR: Attempted to pop incorrect build, have ARRAY\(.*\), tried to pop undef/, "Got error popping undef" ); like( dies { pop_build(['a']) }, qr/INTERNAL ERROR: Attempted to pop incorrect build, have ARRAY\(.*\), tried to pop ARRAY/, "Got error popping wrong ref" ); # Don't ever actually do this... ok(pop_build(get_build()), "Popped"); my $inner; my $build = sub { build('Test2::Compare::Array', sub { local $_ = 1; $inner = get_build(); }) }->(); is($build->lines, [__LINE__ - 4, __LINE__ - 1], "got lines"); is($build->file, __FILE__, "got file"); ref_is($inner, $build, "Build was set inside block"); like( dies { my $x = build('Test2::Compare::Array', sub { die 'xxx' }) }, qr/xxx at/, "re-threw exception" ); like( dies { build('Test2::Compare::Array', sub { }) }, qr/should not be called in void context/, "You need to retain the return from build" ); subtest convert => sub { my $true = do { bless \(my $dummy = 1), "My::Boolean" }; my $false = do { bless \(my $dummy = 0), "My::Boolean" }; my @sets = ( ['a', 'String', 'String'], [undef, 'Undef', 'Undef'], ['', 'String', 'String'], [1, 'String', 'String'], [0, 'String', 'String'], [[], 'Array', 'Array'], [{}, 'Hash', 'Hash'], [qr/x/, 'Regex', 'Pattern'], [sub { 1 }, 'Ref', 'Custom'], [\*STDERR, 'Ref', 'Ref'], [\'foo', 'Scalar', 'Scalar'], [\v1.2.3, 'Scalar', 'Scalar'], [$true, 'Scalar', 'Scalar'], [$false, 'Scalar', 'Scalar'], [ bless({}, 'Test2::Compare::Base'), 'Base', 'Base' ], [ bless({expect => 'a'}, 'Test2::Compare::Wildcard'), 'String', 'String', ], ); for my $set (@sets) { my ($item, $strict, $relaxed) = @$set; my $name = defined $item ? "'$item'" : 'undef'; my $gs = strict_convert($item); my $st = join '::', grep {$_} 'Test2::Compare', $strict; ok($gs->isa($st), "$name -> $st") || diag Dumper($item); my $gr = relaxed_convert($item); my $rt = join '::', grep {$_} 'Test2::Compare', $relaxed; ok($gr->isa($rt), "$name -> $rt") || diag Dumper($item); } }; done_testing; Test2-Suite-0.000129/t/modules/Bundle.t0000644000175000017500000000013713615053353017273 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Bundle; pass("Loaded Test2::Bundle"); done_testing; Test2-Suite-0.000129/t/modules/Plugin.t0000644000175000017500000000013713615053353017320 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Plugin; pass("Loaded Test2::Plugin"); done_testing; Test2-Suite-0.000129/t/modules/Tools.t0000644000175000017500000000013513615053353017160 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Tools; pass("Loaded Test2::Tools"); done_testing; Test2-Suite-0.000129/t/modules/Suite.t0000644000175000017500000000021413615053353017147 0ustar exodistexodistuse Test2::Bundle::Extended; use Test2::Suite; pass("Loaded Test2::Suite"); ok($Test2::Suite::VERSION, "have a version"); done_testing; Test2-Suite-0.000129/t/modules/Todo.t0000644000175000017500000000352513615053353016773 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Todo'; my $todo = Test2::Todo->new(reason => 'xyz'); def isa_ok => ($todo, $CLASS); def ok => ((grep {$_->{code} == $todo->_filter} @{Test2::API::test2_stack->top->_pre_filters}), "filter added"); def is => ($todo->reason, 'xyz', "got reason"); def ref_is => ($todo->hub, Test2::API::test2_stack->top, "used current hub"); def ok => (my $filter = $todo->_filter, "stored filter"); $todo->end; do_def; ok(!(grep {$_->{code} == $filter} @{Test2::API::test2_stack->top->_pre_filters}), "filter removed"); my $ok = Test2::Event::Ok->new(pass => 0, name => 'xxx'); my $diag = Test2::Event::Diag->new(message => 'xxx'); ok(!$ok->todo, "ok is not TODO"); ok(!$ok->effective_pass, "not effectively passing"); my $filtered_ok = $filter->(Test2::API::test2_stack->top, $ok); is($filtered_ok->todo, 'xyz', "the ok is now todo"); ok($filtered_ok->effective_pass, "now effectively passing"); isa_ok($diag, 'Test2::Event::Diag'); my $filtered_diag = $filter->(Test2::API::test2_stack->top, $diag); isa_ok($filtered_diag, 'Test2::Event::Note'); is($filtered_diag->message, $diag->message, "new note has the same message"); my $events = intercept { ok(0, 'fail'); my $todo = Test2::Todo->new(reason => 'xyz'); ok(0, 'todo fail'); $todo = undef; ok(0, 'fail'); }; like( $events, array { event Ok => { pass => 0, effective_pass => 0, todo => DNE }; event Diag => {}; event Ok => { pass => 0, effective_pass => 1, todo => 'xyz' }; event Note => {}; event Ok => { pass => 0, effective_pass => 0, todo => DNE }; event Diag => {}; }, "Got expected events" ); $todo = $CLASS->new(reason => 'this is a todo'); $todo->end; is("$todo", 'this is a todo', "Stringify's to the reason"); ok($todo eq 'this is a todo', "String comparison works"); done_testing; Test2-Suite-0.000129/t/modules/Mock.t0000644000175000017500000006525113615053353016763 0ustar exodistexodistuse Test2::Bundle::Extended -target => 'Test2::Mock'; use Test2::API qw/context/; use Scalar::Util qw/blessed/; # If we reuse the same package name (Fake) over and over we can end up # triggering some weird Perl core issues. With Perl 5.14 and 5.16 we were # seeing "panic: gp_free failed to free glob pointer - something is repeatedly # re-creating entries at ..." # # So instead we use Fake, Fake2, Fake3, etc. It's not very elegant, but it # gets the job done. subtest construction => sub { my %calls; my $c = Test2::Mock->new( class => 'Test2::Mock', before => [ class => sub { $calls{class}++ } ], override => [ parent => sub { $calls{parent}++ }, child => sub { $calls{child}++ }, ], add => [ foo => sub { $calls{foo}++ }, ], ); my $one = Test2::Mock->new( class => 'Fake', parent => 'Fake', child => 'Fake', foo => 'Fake', ); isa_ok($one, 'Test2::Mock'); is( \%calls, { foo => 1 }, "Only called foo, did not call class, parent or child" ); $c->reset_all; my @args; $c->add(foo => sub { push @args => \@_ }); $one = Test2::Mock->new( class => 'Fake', foo => 'string', foo => [qw/a list/], foo => {a => 'hash'}, ); isa_ok($one, 'Test2::Mock'); is( \@args, [ [$one, 'string'], [$one, qw/a list/], [$one, qw/a hash/], ], "Called foo with proper args, called it multiple times" ); like( dies { Test2::Mock->new }, qr/The 'class' field is required/, "Must specify a class" ); like( dies { Test2::Mock->new(class => 'Fake', foo => sub { 1 }) }, qr/'CODE\(.*\)' is not a valid argument for 'foo'/, "Val must be sane" ); }; subtest check => sub { my $one = Test2::Mock->new(class => 'Fake1'); ok(lives { $one->_check }, "did not die"); $one->set_child(1); like( dies {$one->_check}, qr/There is an active child controller, cannot proceed/, "Cannot use a controller when it has a child" ); }; subtest purge_on_destroy => sub { my $one = Test2::Mock->new(class => 'Fake2'); ok(!$one->purge_on_destroy, "Not set by default"); $one->purge_on_destroy(1); ok($one->purge_on_destroy, "Can set"); $one->purge_on_destroy(0); ok(!$one->purge_on_destroy, "Can Unset"); { # need to hide the glob assignment from the parser. no strict 'refs'; *{"Fake2::foo"} = sub { 'foo' }; } can_ok('Fake2', 'foo'); $one = undef; can_ok('Fake2', 'foo'); # Not purged $one = Test2::Mock->new(class => 'Fake2'); $one->purge_on_destroy(1); $one = undef; my $stash = do { no strict 'refs'; \%{"Fake2::"}; }; ok(!keys %$stash, "no keys left in stash"); ok(!Fake2->can('foo'), 'purged sub'); }; subtest stash => sub { my $one = Test2::Mock->new(class => 'Fake3'); my $stash = $one->stash; ok($stash, "got a stash"); is($stash, {}, "stash is empty right now"); { # need to hide the glob assignment from the parser. no strict 'refs'; *{"Fake3::foo"} = sub { 'foo' }; } ok($stash->{foo}, "See the new sub in the stash"); ok(*{$stash->{foo}}{CODE}, "Code slot is populated"); }; subtest file => sub { my $fake = Test2::Mock->new(class => 'Fake4'); my $complex = Test2::Mock->new(class => "A::Fake'Module::With'Separators"); is($fake->file, "Fake4.pm", "Got simple filename"); is($complex->file, "A/Fake/Module/With/Separators.pm", "got complex filename"); }; subtest block_load => sub { my $one; my $construction = sub { $one = Test2::Mock->new(class => 'Fake5', block_load => 1); }; my $post_construction = sub { $one = Test2::Mock->new(class => 'Fake5'); $one->block_load; }; for my $case ($construction, $post_construction) { $one = undef; ok(!$INC{'Fake5.pm'}, "Does not appear to be loaded yet"); $case->(); ok($INC{'Fake5.pm'}, '%INC is populated'); $one = undef; ok(!$INC{'Fake5.pm'}, "Does not appear to be loaded anymore"); } }; subtest block_load_fail => sub { $INC{'Fake6.pm'} = 'path/to/Fake6.pm'; my $one = Test2::Mock->new(class => 'Fake6'); like( dies { $one->block_load }, qr/Cannot block the loading of module 'Fake6', already loaded in file/, "Fails if file is already loaded" ); }; subtest constructors => sub { my $one = Test2::Mock->new( class => 'Fake7', add_constructor => [new => 'hash'], ); can_ok('Fake7', 'new'); my $i = Fake7->new(foo => 'bar'); isa_ok($i, 'Fake7'); is($i, { foo => 'bar' }, "Has params"); $one->override_constructor(new => 'ref'); my $ref = { 'foo' => 'baz' }; $i = Fake7->new($ref); isa_ok($i, 'Fake7'); is($i, { foo => 'baz' }, "Has params"); is($i, $ref, "same reference"); ok(blessed($ref), "blessed original ref"); $one->override_constructor(new => 'ref_copy'); $ref = { 'foo' => 'bat' }; $i = Fake7->new($ref); isa_ok($i, 'Fake7'); is($i, { foo => 'bat' }, "Has params"); ok($i != $ref, "different reference"); ok(!blessed($ref), "original ref is not blessed"); $ref = [ 'foo', 'bar' ]; $i = Fake7->new($ref); isa_ok($i, 'Fake7'); is($i, [ 'foo', 'bar' ], "has the items"); ok($i != $ref, "different reference"); ok(!blessed($ref), "original ref is not blessed"); like( dies { $one->override_constructor(new => 'bad') }, qr/'bad' is not a known constructor type/, "Bad constructor type (override)" ); like( dies { $one->add_constructor(uhg => 'bad') }, qr/'bad' is not a known constructor type/, "Bad constructor type (add)" ); $one->override_constructor(new => 'array'); $one = Fake7->new('a', 'b'); is($one, ['a', 'b'], "is an array"); isa_ok($one, 'Fake7'); }; subtest autoload => sub { my $one = Test2::Mock->new( class => 'Fake8', add_constructor => [new => 'hash'], ); my $i = Fake8->new; isa_ok($i, 'Fake8'); ok(!$i->can('foo'), "Cannot do 'foo'"); like(dies {$i->foo}, qr/Can't locate object method "foo" via package "Fake8"/, "Did not autload"); $one->autoload; ok(lives { $i->foo }, "Created foo") || return; can_ok($i, 'foo'); # Added the sub to the package is($i->foo, undef, "no value"); $i->foo('bar'); is($i->foo, 'bar', "set value"); $i->foo(undef); is($i->foo, undef, "unset value"); ok( dies { $one->autoload }, qr/Class 'Fake8' already has an AUTOLOAD/, "Cannot add additional autoloads" ); $one->reset_all; ok(!$i->can('AUTOLOAD'), "AUTOLOAD removed"); ok(!$i->can('foo'), "AUTOLOADed sub removed"); $one->autoload; $i->foo; ok($i->can('AUTOLOAD'), "AUTOLOAD re-added"); ok($i->can('foo'), "AUTOLOADed sub re-added"); $one = undef; ok(!$i->can('AUTOLOAD'), "AUTOLOAD removed (destroy)"); ok(!$i->can('foo'), "AUTOLOADed sub removed (destroy)"); my $two = Test2::Mock->new( class => 'Fake88', add_constructor => [new => 'hash'], track => 1, autoload => 1, ); my $j = Fake88->new; ok(lives { $j->foo }, "Created foo") || return; can_ok($j, 'foo'); # Added the sub to the package is( $two->sub_tracking, {foo => [{sub_name => 'foo', sub_ref => T, args => [exact_ref($j)]}]}, "Tracked autoloaded sub (sub tracking)" ); is( $two->call_tracking, [{sub_name => 'foo', sub_ref => T, args => [exact_ref($j)]}], "Tracked autoloaded sub (call tracking)" ); }; subtest autoload_failures => sub { my $one = Test2::Mock->new(class => 'fake'); $one->add('AUTOLOAD' => sub { 1 }); like( dies { $one->autoload }, qr/Class 'fake' already has an AUTOLOAD/, "Cannot add autoload when there is already an autoload" ); $one = undef; $one = Test2::Mock->new(class => 'bad package'); like( dies { $one->autoload }, qr/syntax error/, "Error inside the autoload eval" ); }; subtest ISA => sub { # This is to satisfy perl that My::Parent is loaded no warnings 'once'; local *My::Parent::foo = sub { 'foo' }; my $one = Test2::Mock->new( class => 'Fake9', add_constructor => [new => 'hash'], add => [ -ISA => ['My::Parent'], ], ); isa_ok('Fake9', 'My::Parent'); is(Fake9->foo, 'foo', "Inherited sub from parent"); }; subtest before => sub { { # need to hide the glob assignment from the parser. no strict 'refs'; *{"Fake10::foo"} = sub { 'foo' }; } my $thing; my $one = Test2::Mock->new(class => 'Fake10'); $one->before('foo' => sub { $thing = 'ran before foo' }); ok(!$thing, "nothing ran yet"); is(Fake10->foo, 'foo', "got expected return"); is($thing, 'ran before foo', "ran the before"); }; subtest before => sub { my $want; { # need to hide the glob assignment from the parser. no strict 'refs'; *{"Fake11::foo"} = sub { $want = wantarray; return qw/f o o/ if $want; return 'foo' if defined $want; return; }; } my $ran = 0; my $one = Test2::Mock->new(class => 'Fake11'); $one->after('foo' => sub { $ran++ }); is($ran, 0, "nothing ran yet"); is(Fake11->foo, 'foo', "got expected return (scalar)"); is($ran, 1, "ran the before"); ok(defined($want) && !$want, "scalar context"); is([Fake11->foo], [qw/f o o/], "got expected return (list)"); is($ran, 2, "ran the before"); is($want, 1, "list context"); Fake11->foo; # Void return is($ran, 3, "ran the before"); is($want, undef, "void context"); }; subtest around => sub { my @things; { # need to hide the glob assignment from the parser. no strict 'refs'; *{"Fake12::foo"} = sub { push @things => ['foo', \@_]; }; } my $one = Test2::Mock->new(class => 'Fake12'); $one->around(foo => sub { my ($orig, @args) = @_; push @things => ['pre', \@args]; $orig->('injected', @args); push @things => ['post', \@args]; }); Fake12->foo(qw/a b c/); is( \@things, [ ['pre' => [qw/Fake12 a b c/]], ['foo' => [qw/injected Fake12 a b c/]], ['post' => [qw/Fake12 a b c/]], ], "Got all the things!" ); }; subtest 'add and current' => sub { my $one = Test2::Mock->new( class => 'Fake13', add_constructor => [new => 'hash'], add => [ foo => { val => 'foo' }, bar => 'rw', baz => { is => 'rw', field => '_baz' }, -DATA => { my => 'data' }, -DATA => [ qw/my data/ ], -DATA => sub { 'my data' }, -DATA => \"data", ], ); # Do some outside constructor to test both paths $one->add( reader => 'ro', writer => 'wo', -UHG => \"UHG", rsub => { val => sub { 'rsub' } }, # Without $x the compiler gets smart and makes it always return the # same reference. nsub => sub { my $x = ''; sub { $x . 'nsub' } }, ); can_ok('Fake13', qw/new foo bar baz DATA reader writer rsub nsub/); like( dies { $one->add(foo => sub { 'nope' }) }, qr/Cannot add '&Fake13::foo', symbol is already defined/, "Cannot add a CODE symbol that is already defined" ); like( dies { $one->add(-UHG => \'nope') }, qr/Cannot add '\$Fake13::UHG', symbol is already defined/, "Cannot add a SCALAR symbol that is already defined" ); my $i = Fake13->new(); is($i->foo, 'foo', "by value"); is($i->bar, undef, "Accessor not set"); is($i->bar('bar'), 'bar', "Accessor setting"); is($i->bar, 'bar', "Accessor was set"); is($i->baz, undef, "no value yet"); ok(!$i->{_bar}, "hash element is empty"); is($i->baz('baz'), 'baz', "setting"); is($i->{_baz}, 'baz', "set field"); is($i->baz, 'baz', "got value"); is($i->reader, undef, "No value for reader"); is($i->reader('oops'), undef, "No value set"); is($i->reader, undef, "Still No value for reader"); is($i->{reader}, undef, 'element is empty'); $i->{reader} = 'yay'; is($i->{reader}, 'yay', 'element is set'); is($i->{writer}, undef, "no value yet"); $i->writer; is($i->{writer}, undef, "Set to undef"); is($i->writer('xxx'), 'xxx', "Adding value"); is($i->{writer}, 'xxx', "was set"); is($i->writer, undef, "writer always writes"); is($i->{writer}, undef, "Set to undef"); is($i->rsub, $i->rsub, "rsub always returns the same ref"); is($i->rsub->(), 'rsub', "ran rsub"); ok($i->nsub != $i->nsub, "nsub returns a new ref each time"); is($i->nsub->(), 'nsub', "ran nsub"); is($i->DATA, 'my data', "direct sub assignment"); # These need to be eval'd so the parser does not shortcut the glob references ok(eval <<' EOT', "Ran glob checks") || diag "Error: $@"; is($Fake13::UHG, 'UHG', "Set package scalar (UHG)"); is($Fake13::DATA, 'data', "Set package scalar (DATA)"); is(\%Fake13::DATA, { my => 'data' }, "Set package hash"); is(\@Fake13::DATA, [ my => 'data' ], "Set package array"); 1; EOT is($one->current($_), $i->can($_), "current works for sub $_") for qw/new foo bar baz DATA reader writer rsub nsub/; is(${$one->current('$UHG')}, 'UHG', 'got current $UHG'); is(${$one->current('$DATA')}, 'data', 'got current $DATA'); is($one->current('&DATA'), $i->can('DATA'), 'got current &DATA'); is($one->current('@DATA'), [qw/my data/], 'got current @DATA'); is($one->current('%DATA'), {my => 'data'}, 'got current %DATA'); $one = undef; ok(!Fake13->can($_), "Removed sub $_") for qw/new foo bar baz DATA reader writer rsub nsub/; $one = Test2::Mock->new(class => 'Fake13'); # Scalars are tricky, skip em for now. is($one->current('&DATA'), undef, 'no current &DATA'); is($one->current('@DATA'), undef, 'no current @DATA'); is($one->current('%DATA'), undef, 'no current %DATA'); }; subtest 'override and orig' => sub { # Define things so we can override them eval <<' EOT' || die $@; package Fake14; sub new { 'old' } sub foo { 'old' } sub bar { 'old' } sub baz { 'old' } sub DATA { 'old' } our $DATA = 'old'; our %DATA = (old => 'old'); our @DATA = ('old'); our $UHG = 'old'; sub reader { 'old' } sub writer { 'old' } sub rsub { 'old' } sub nsub { 'old' } EOT my $check_initial = sub { is(Fake14->$_, 'old', "$_ is not overriden") for qw/new foo bar baz DATA reader writer rsub nsub/; ok(eval <<' EOT', "Ran glob checks") || diag "Error: $@"; is($Fake14::UHG, 'old', 'old package scalar (UHG)'); is($Fake14::DATA, 'old', "Old package scalar (DATA)"); is(\%Fake14::DATA, {old => 'old'}, "Old package hash"); is(\@Fake14::DATA, ['old'], "Old package array"); 1; EOT }; $check_initial->(); my $one = Test2::Mock->new( class => 'Fake14', override_constructor => [new => 'hash'], override => [ foo => { val => 'foo' }, bar => 'rw', baz => { is => 'rw', field => '_baz' }, -DATA => { my => 'data' }, -DATA => [ qw/my data/ ], -DATA => sub { 'my data' }, -DATA => \"data", ], ); # Do some outside constructor to test both paths $one->override( reader => 'ro', writer => 'wo', -UHG => \"UHG", rsub => { val => sub { 'rsub' } }, # Without $x the compiler gets smart and makes it always return the # same reference. nsub => sub { my $x = ''; sub { $x . 'nsub' } }, ); like( dies { $one->override(nuthin => sub { 'nope' }) }, qr/Cannot override '&Fake14::nuthin', symbol is not already defined/, "Cannot override a CODE symbol that is not defined" ); like( dies { $one->override(-nuthin2 => \'nope') }, qr/Cannot override '\$Fake14::nuthin2', symbol is not already defined/, "Cannot override a SCALAR symbol that is not defined" ); my $i = Fake14->new(); is($i->foo, 'foo', "by value"); is($i->bar, undef, "Accessor not set"); is($i->bar('bar'), 'bar', "Accessor setting"); is($i->bar, 'bar', "Accessor was set"); is($i->baz, undef, "no value yet"); ok(!$i->{_bar}, "hash element is empty"); is($i->baz('baz'), 'baz', "setting"); is($i->{_baz}, 'baz', "set field"); is($i->baz, 'baz', "got value"); is($i->reader, undef, "No value for reader"); is($i->reader('oops'), undef, "No value set"); is($i->reader, undef, "Still No value for reader"); is($i->{reader}, undef, 'element is empty'); $i->{reader} = 'yay'; is($i->{reader}, 'yay', 'element is set'); is($i->{writer}, undef, "no value yet"); $i->writer; is($i->{writer}, undef, "Set to undef"); is($i->writer('xxx'), 'xxx', "Adding value"); is($i->{writer}, 'xxx', "was set"); is($i->writer, undef, "writer always writes"); is($i->{writer}, undef, "Set to undef"); is($i->rsub, $i->rsub, "rsub always returns the same ref"); is($i->rsub->(), 'rsub', "ran rsub"); ok($i->nsub != $i->nsub, "nsub returns a new ref each time"); is($i->nsub->(), 'nsub', "ran nsub"); is($i->DATA, 'my data', "direct sub assignment"); # These need to be eval'd so the parser does not shortcut the glob references ok(eval <<' EOT', "Ran glob checks") || diag "Error: $@"; is($Fake14::UHG, 'UHG', "Set package scalar (UHG)"); is($Fake14::DATA, 'data', "Set package scalar (DATA)"); is(\%Fake14::DATA, { my => 'data' }, "Set package hash"); is(\@Fake14::DATA, [ my => 'data' ], "Set package array"); 1; EOT is($one->current($_), $i->can($_), "current works for sub $_") for qw/new foo bar baz DATA reader writer rsub nsub/; is(${$one->current('$UHG')}, 'UHG', 'got current $UHG'); is(${$one->current('$DATA')}, 'data', 'got current $DATA'); is($one->current('&DATA'), $i->can('DATA'), 'got current &DATA'); is($one->current('@DATA'), [qw/my data/], 'got current @DATA'); is($one->current('%DATA'), {my => 'data'}, 'got current %DATA'); is($one->orig($_)->(), 'old', "got original $_") for qw/new foo bar baz DATA reader writer rsub nsub/; is(${$one->orig('$UHG')}, 'old', 'old package scalar (UHG)'); is(${$one->orig('$DATA')}, 'old', "Old package scalar (DATA)"); is($one->orig('%DATA'), {old => 'old'}, "Old package hash"); is($one->orig('@DATA'), ['old'], "Old package array"); like( dies { $one->orig('not_mocked') }, qr/Symbol '¬_mocked' is not mocked/, "Cannot get original for something not mocked" ); like( dies { Test2::Mock->new(class => 'AnotherFake14')->orig('no_mocks') }, qr/No symbols have been mocked yet/, "Cannot get original when nothing is mocked" ); $one = undef; $check_initial->(); }; subtest restore_reset => sub { my $one = Test2::Mock->new( class => 'Fake15' ); $one->add(foo => sub { 'a' }); $one->add(-foo => \'a'); $one->add(-foo => ['a']); $one->override(foo => sub { 'b' }); $one->override(foo => sub { 'c' }); $one->override(foo => sub { 'd' }); $one->override(foo => sub { 'e' }); is(Fake15->foo, 'e', "latest override"); is(eval '$Fake15::foo', 'a', "scalar override remains"); is(eval '\@Fake15::foo', ['a'], "array override remains"); $one->restore('foo'); is(Fake15->foo, 'd', "second latest override"); is(eval '$Fake15::foo', 'a', "scalar override remains"); is(eval '\@Fake15::foo', ['a'], "array override remains"); $one->restore('foo'); is(Fake15->foo, 'c', "second latest override"); is(eval '$Fake15::foo', 'a', "scalar override remains"); is(eval '\@Fake15::foo', ['a'], "array override remains"); $one->reset('foo'); ok(!Fake15->can('foo'), "no more override"); is(eval '$Fake15::foo', 'a', "scalar override remains"); is(eval '\@Fake15::foo', ['a'], "array override remains"); $one->add(foo => sub { 'a' }); is(Fake15->foo, 'a', "override"); $one->reset_all; ok(!Fake15->can('foo'), "no more override"); is(eval '$Fake15::foo', undef, "scalar override removed"); no strict 'refs'; ok(!*{'Fake15::foo'}{ARRAY}, "array override removed"); }; subtest exceptions => sub { my $one = Test2::Mock->new( class => 'Fake16' ); like( dies { $one->new(class => 'AnotherFake16') }, qr/Called new\(\) on a blessed instance, did you mean to call \$control->class->new\(\)\?/, "Cannot call new on a blessed instance" ); like( dies { Test2::Mock->new(class => 'AnotherFake16', foo => 1) }, qr/'foo' is not a valid constructor argument for Test2::Mock/, "Validate constructor args" ); like( dies { Test2::Mock->new(class => 'AnotherFake16', override_constructor => ['xxx', 'xxx']) }, qr/'xxx' is not a known constructor type/, "Invalid constructor type" ); like( dies { Test2::Mock->new(class => 'AnotherFake16', add_constructor => ['xxx', 'xxx']) }, qr/'xxx' is not a known constructor type/, "Invalid constructor type" ); like( dies { $one->orig('foo') }, qr/No symbols have been mocked yet/, "No symbols are mocked yet" ); like( dies { $one->restore('foo') }, qr/No symbols are mocked/, "No symbols yet!" ); like( dies { $one->reset('foo') }, qr/No symbols are mocked/, "No symbols yet!" ); $one->add(xxx => sub { 1 }); like( dies { $one->orig('foo') }, qr/Symbol '&foo' is not mocked/, "did not mock foo" ); like( dies { $one->restore('foo') }, qr/Symbol '&foo' is not mocked/, "did not mock foo" ); like( dies { $one->reset('foo') }, qr/Symbol '&foo' is not mocked/, "did not mock foo" ); my $bare = Test2::Mock->new( class => 'Fake17', autoload => 1, ); like( dies { $bare->override( missing => 1 ) }, qr/Cannot override '&Fake17::missing', symbol is not already defined/, "Cannot override a method that is not defined in an AUTOLOAD mock" ); }; subtest override_inherited_method => sub { package ABC; our @ISA = 'DEF'; package DEF; sub foo { 'foo' }; package main; is(ABC->foo, 'foo', "Original"); my $mock = Test2::Mock->new(class => 'ABC'); $mock->override('foo' => sub { 'bar' }); is(ABC->foo, 'bar', "Overrode method from base class"); $mock->reset('foo'); $mock->add('foo' => sub { 'baz' }); is(ABC->foo, 'baz', "Added method"); }; subtest set => sub { package My::Set; sub foo { 'foo' } package main; my $mock = Test2::Mock->new(class => 'My::Set'); $mock->set(foo => sub { 'FOO' }); $mock->set(bar => sub { 'BAR' }); is(My::Set->foo, 'FOO', "overrode 'foo'"); is(My::Set->bar, 'BAR', "injected 'bar'"); }; subtest tracking => sub { package My::Track; sub foo { 'foo' } package main; my $mock = Test2::Mock->new(class => 'My::Track', track => 1); my $FOO = sub { 'FOO' }; my $BAR = sub { 'BAR' }; $mock->set(foo => $FOO); $mock->set(bar => $BAR); is(My::Track->foo(1,2), 'FOO', "overrode 'foo'"); is(My::Track->bar(3,4), 'BAR', "injected 'bar'"); is( $mock->sub_tracking, { foo => [{sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 1, 2]}], bar => [{sub_name => 'bar', sub_ref => exact_ref($BAR), args => ['My::Track', 3, 4]}], }, "Tracked both initial calls (sub)" ); is( $mock->call_tracking, [ {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 1, 2]}, {sub_name => 'bar', sub_ref => exact_ref($BAR), args => ['My::Track', 3, 4]} ], "Tracked both initial calls (call)" ); My::Track->foo(5, 6); is( $mock->sub_tracking, { foo => [ {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 1, 2]}, {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 5, 6]}, ], bar => [{sub_name => 'bar', sub_ref => exact_ref($BAR), args => ['My::Track', 3, 4]}], }, "Tracked new call (sub)" ); is( $mock->call_tracking, [ {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 1, 2]}, {sub_name => 'bar', sub_ref => exact_ref($BAR), args => ['My::Track', 3, 4]}, {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 5, 6]}, ], "Tracked new call (call)" ); $mock->clear_sub_tracking('xxx', 'foo'); My::Track->foo(7, 8); is( $mock->sub_tracking, { foo => [{sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 7, 8]}], bar => [{sub_name => 'bar', sub_ref => exact_ref($BAR), args => ['My::Track', 3, 4]}], }, "Cleared specific sub, Tracked new call (sub)" ); is( $mock->call_tracking, [ {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 1, 2]}, {sub_name => 'bar', sub_ref => exact_ref($BAR), args => ['My::Track', 3, 4]}, {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 5, 6]}, {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 7, 8]}, ], "did not clear call tracking" ); $mock->clear_sub_tracking(); is($mock->sub_tracking, {}, "Cleared all sub tracking"); $mock->clear_call_tracking(); is($mock->call_tracking, [], "Cleared call tracking"); My::Track->foo(9, 10); is( $mock->sub_tracking, { foo => [{sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 9, 10]}], }, "Tracked new call (sub)" ); is( $mock->call_tracking, [ {sub_name => 'foo', sub_ref => exact_ref($FOO), args => ['My::Track', 9, 10]}, ], "Tracked new call (call)" ); $mock = undef; is(My::Track->foo, 'foo', "Original restored"); }; done_testing; Test2-Suite-0.000129/t/modules/V0.t0000644000175000017500000000472713615053353016360 0ustar exodistexodistuse Test2::V0; use Test2::API qw/test2_stack/; use PerlIO; # HARNESS-NO-FORMATTER imported_ok qw{ ok pass fail diag note todo skip plan skip_all done_testing bail_out gen_event intercept context cmp_ok subtest can_ok isa_ok DOES_ok set_encoding imported_ok not_imported_ok ref_ok ref_is ref_is_not mock mocked dies lives try_ok is like isnt unlike match mismatch validator hash array object meta number string bool in_set not_in_set check_set item field call call_list call_hash prop check all_items all_keys all_vals all_values etc end filter_items T F D DF E DNE FDNE U event fail_events exact_ref }; ok(Test2::Plugin::ExitSummary->active, "Exit Summary is loaded"); ok(defined(Test2::Plugin::SRand->seed), "SRand is loaded"); subtest strictures => sub { local $^H; my $hbefore = $^H; Test2::V0->import; my $hafter = $^H; my $strict = do { local $^H; strict->import(); $^H }; ok($strict, 'sanity, got $^H value for strict'); ok(!($hbefore & $strict), "strict is not on before loading Test2::V0"); ok(($hafter & $strict), "strict is on after loading Test2::V0"); }; subtest warnings => sub { local ${^WARNING_BITS}; my $wbefore = ${^WARNING_BITS} || ''; Test2::V0->import; my $wafter = ${^WARNING_BITS} || ''; my $warnings = do { local ${^WARNING_BITS}; 'warnings'->import(); ${^WARNING_BITS} || '' }; ok($warnings, 'sanity, got ${^WARNING_BITS} value for warnings'); ok($wbefore ne $warnings, "warnings are not on before loading Test2::V0") || diag($wbefore, "\n", $warnings); ok(($wafter & $warnings), "warnings are on after loading Test2::V0"); }; subtest utf8 => sub { ok(utf8::is_utf8("癸"), "utf8 pragma is on"); # -2 cause the subtest adds to the stack my $format = test2_stack()->[-2]->format; my $handles = $format->handles or return; for my $hn (0 .. @$handles) { my $h = $handles->[$hn] || next; my $layers = { map {$_ => 1} PerlIO::get_layers($h) }; ok($layers->{utf8}, "utf8 is on for formatter handle $hn"); } }; subtest "rename imports" => sub { package A::Consumer; use Test2::V0 ':DEFAULT', '!subtest', subtest => {-as => 'a_subtest'}; imported_ok('a_subtest'); not_imported_ok('subtest'); }; subtest "no meta" => sub { package B::Consumer; use Test2::V0 '!meta'; imported_ok('meta_check'); not_imported_ok('meta'); }; done_testing; 1; Test2-Suite-0.000129/t/00-report.t0000644000175000017500000000310513615053353016140 0ustar exodistexodistuse Test2::Tools::Basic; use Test2::Util::Table qw/table/; # Nothing in the tables in this file should result in a table wider than 80 # characters, so this is an optimization. BEGIN { $ENV{TABLE_TERM_SIZE} = 80 } use Test2::Util qw/CAN_FORK CAN_REALLY_FORK CAN_THREAD/; diag "\nDIAGNOSTICS INFO IN CASE OF FAILURE:\n"; diag(join "\n", table(rows => [[ 'perl', $] ]])); diag( join "\n", table( header => [qw/CAPABILITY SUPPORTED/], rows => [ ['CAN_FORK', CAN_FORK ? 'Yes' : 'No'], ['CAN_REALLY_FORK', CAN_REALLY_FORK ? 'Yes' : 'No'], ['CAN_THREAD', CAN_THREAD ? 'Yes' : 'No'], ], ) ); { my @depends = qw{ Test2 Importer Term::Table Sub::Info B Carp Exporter Scalar::Util Scope::Guard Time::HiRes overload utf8 Module::Pluggable }; my @rows; for my $mod (sort @depends) { my $installed = eval "require $mod; $mod->VERSION"; push @rows => [ $mod, $installed || "N/A" ]; } my @table = table( header => [ 'DEPENDENCY', 'VERSION' ], rows => \@rows, ); diag(join "\n", @table); } { my @options = qw{ Sub::Name Term::ReadKey Term::Size::Any Unicode::GCString Unicode::LineBreak }; my @rows; for my $mod (sort @options) { my $installed = eval "require $mod; $mod->VERSION"; push @rows => [ $mod, $installed || "N/A" ]; } my @table = table( header => [ 'OPTIONAL', 'VERSION' ], rows => \@rows, ); diag(join "\n", @table); } pass; done_testing; Test2-Suite-0.000129/appveyor.yml0000644000175000017500000000125013615053353016347 0ustar exodistexodistskip_tags: true cache: - C:\strawberry install: - if not exist "C:\strawberry" cinst strawberryperl -y - set PATH=C:\strawberry\perl\bin;C:\strawberry\perl\site\bin;C:\strawberry\c\bin;%PATH% - cd C:\projects\%APPVEYOR_PROJECT_NAME% - cpanm -n Dist::Zilla - dzil authordeps --missing | cpanm -n - dzil listdeps --author --missing | cpanm build_script: - perl -e 2 test_script: - dzil test notifications: - provider: Slack auth_token: secure: 1XmVVszAQyTtMdNkyWup8p7AC9iqXkMl6QMchq3Xu7L7rCzYgjjlS/mas+bfp3ouyjPKnoh01twl4eB0Xs/1Ig== channel: '#general' on_build_success: false on_build_failure: true on_build_status_changed: true Test2-Suite-0.000129/Makefile.PL0000644000175000017500000000362113615053353015735 0ustar exodistexodist# This file was automatically generated by Dist::Zilla::Plugin::MakeMaker v6.012. use strict; use warnings; use 5.008001; use ExtUtils::MakeMaker; my %WriteMakefileArgs = ( "ABSTRACT" => "Distribution with a rich set of tools built upon the Test2 framework.", "AUTHOR" => "Chad Granum ", "CONFIGURE_REQUIRES" => { "ExtUtils::MakeMaker" => 0 }, "DISTNAME" => "Test2-Suite", "LICENSE" => "perl", "MIN_PERL_VERSION" => "5.008001", "NAME" => "Test2::Suite", "PREREQ_PM" => { "B" => 0, "Carp" => 0, "Data::Dumper" => 0, "Exporter" => 0, "Importer" => "0.024", "Module::Pluggable" => "2.7", "Scalar::Util" => 0, "Scope::Guard" => 0, "Sub::Info" => "0.002", "Term::Table" => "0.013", "Test2::API" => "1.302158", "Time::HiRes" => 0, "overload" => 0, "utf8" => 0 }, "VERSION" => "0.000129", "test" => { "TESTS" => "t/*.t t/acceptance/*.t t/behavior/*.t t/modules/*.t t/modules/AsyncSubtest/*.t t/modules/AsyncSubtest/Event/*.t t/modules/Bundle/*.t t/modules/Compare/*.t t/modules/Plugin/*.t t/modules/Require/*.t t/modules/Tools/*.t t/modules/Util/*.t t/modules/Util/Table/*.t t/modules/Workflow/*.t t/modules/Workflow/Task/*.t t/regression/*.t" } ); my %FallbackPrereqs = ( "B" => 0, "Carp" => 0, "Data::Dumper" => 0, "Exporter" => 0, "Importer" => "0.024", "Module::Pluggable" => "2.7", "Scalar::Util" => 0, "Scope::Guard" => 0, "Sub::Info" => "0.002", "Term::Table" => "0.013", "Test2::API" => "1.302158", "Time::HiRes" => 0, "overload" => 0, "utf8" => 0 ); unless ( eval { ExtUtils::MakeMaker->VERSION(6.63_03) } ) { delete $WriteMakefileArgs{TEST_REQUIRES}; delete $WriteMakefileArgs{BUILD_REQUIRES}; $WriteMakefileArgs{PREREQ_PM} = \%FallbackPrereqs; } delete $WriteMakefileArgs{CONFIGURE_REQUIRES} unless eval { ExtUtils::MakeMaker->VERSION(6.52) }; WriteMakefile(%WriteMakefileArgs); Test2-Suite-0.000129/perltidyrc0000644000175000017500000000226013615053353016065 0ustar exodistexodist--indent-columns=4 # size of indentation --nt # no tabs --entab-leading-whitespace=4 # 4 spaces to a tab when converting to tabs --continuation-indentation=4 # indentation of wrapped lines --maximum-line-length=0 # max line length before wrapping (turn it off) --nooutdent-long-quotes # do not outdent overly long quotes --paren-tightness=2 # no spacing for parentheses --square-bracket-tightness=2 # no spacing for square brackets --brace-tightness=2 # no spacing for hash curly braces --block-brace-tightness=0 # spacing for coderef curly braces --comma-arrow-breakpoints=1 # break long key/value pair lists --break-at-old-comma-breakpoints # this attempts to retain list break points --no-blanks-before-comments # do not insert blank lines before comments --indent-spaced-block-comments # no blanks before comments --nocuddled-else # Do not cuddle else --nospace-for-semicolon # no space before semicolons in loops --nospace-terminal-semicolon # no space before termonal semicolons --notrim-qw # Do not mess with qw{} whitespace Test2-Suite-0.000129/README.md0000644000175000017500000002636613615053353015255 0ustar exodistexodist# NAME Test2::Suite - Distribution with a rich set of tools built upon the Test2 framework. # DESCRIPTION Rich set of tools, plugins, bundles, etc built upon the [Test2](https://metacpan.org/pod/Test2) testing library. If you are interested in writing tests, this is the distribution for you. ## WHAT ARE TOOLS, PLUGINS, AND BUNDLES? - TOOLS Tools are packages that export functions for use in test files. These functions typically generate events. Tools **SHOULD NEVER** alter behavior of other tools, or the system in general. - 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 **SHOULD NOT** export anything. - 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. 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. # INCLUDED BUNDLES - Test2::V# These do not live in the bundle namespace as they are the primary ways to use Test2::Suite. The current latest is [Test2::V0](https://metacpan.org/pod/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 ["INCLUDED TOOLS"](#included-tools) section below, except for [Test2::Tools::ClassicCompare](https://metacpan.org/pod/Test2::Tools::ClassicCompare). This bundle provides most of what anyone writing tests could need. This is also the preferred bundle/toolset of the [Test2](https://metacpan.org/pod/Test2) author. See [Test2::V0](https://metacpan.org/pod/Test2::V0) for complete documentation. - Extended **\*\* Deprecated \*\*** See [Test2::V0](https://metacpan.org/pod/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 ["INCLUDED TOOLS"](#included-tools) section below, except for [Test2::Tools::ClassicCompare](https://metacpan.org/pod/Test2::Tools::ClassicCompare). This bundle provides most of what anyone writing tests could need. This is also the preferred bundle/toolset of the [Test2](https://metacpan.org/pod/Test2) author. See [Test2::Bundle::Extended](https://metacpan.org/pod/Test2::Bundle::Extended) for complete documentation. - 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 _mostly_ drop-in replacement for [Test::More](https://metacpan.org/pod/Test::More). There are some notable differences to be aware of however. Some exports are missing: `eq_array`, `eq_hash`, `eq_set`, `$TODO`, `explain`, `use_ok`, `require_ok`. As well it is no longer possible to set the plan at import: `use .. tests => 5`. `$TODO` has been replaced by the `todo()` function. Planning is done using `plan`, `skip_all`, or `done_testing`. See [Test2::Bundle::More](https://metacpan.org/pod/Test2::Bundle::More) for complete documentation. - Simple use Test2::Bundle::Simple; use strict; use warnings; plan 1; ok(...); This bundle is meant to be a _mostly_ drop-in replacement for [Test::Simple](https://metacpan.org/pod/Test::Simple). See [Test2::Bundle::Simple](https://metacpan.org/pod/Test2::Bundle::Simple) for complete documentation. # INCLUDED TOOLS - Basic Basic provides most of the essential tools previously found in [Test::More](https://metacpan.org/pod/Test::More). However it does not export any tools used for comparison. The basic `pass`, `fail`, `ok` functions are present, as are functions for planning. See [Test2::Tools::Basic](https://metacpan.org/pod/Test2::Tools::Basic) for complete documentation. - Compare This provides `is`, `like`, `isnt`, `unlike`, and several additional helpers. **Note:** These are all _deep_ comparison tools and work like a combination of [Test::More](https://metacpan.org/pod/Test::More)'s `is` and `is_deeply`. See [Test2::Tools::Compare](https://metacpan.org/pod/Test2::Tools::Compare) for complete documentation. - ClassicCompare This provides [Test::More](https://metacpan.org/pod/Test::More) flavored `is`, `like`, `isnt`, `unlike`, and `is_deeply`. It also provides `cmp_ok`. See [Test2::Tools::ClassicCompare](https://metacpan.org/pod/Test2::Tools::ClassicCompare) for complete documentation. - Class This provides functions for testing objects and classes, things like `isa_ok`. See [Test2::Tools::Class](https://metacpan.org/pod/Test2::Tools::Class) for complete documentation. - 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 [Test2::Tools::Defer](https://metacpan.org/pod/Test2::Tools::Defer) for complete documentation. - Encoding This exports a single function that can be used to change the encoding of all your test output. See [Test2::Tools::Encoding](https://metacpan.org/pod/Test2::Tools::Encoding) for complete documentation. - Exports This provides tools for verifying exports. You can verify that functions have been imported, or that they have not been imported. See [Test2::Tools::Exports](https://metacpan.org/pod/Test2::Tools::Exports) for complete documentation. - Mock This provides tools for mocking objects and classes. This is based largely on [Mock::Quick](https://metacpan.org/pod/Mock::Quick), but several interface improvements have been added that cannot be added to Mock::Quick itself without breaking backwards compatibility. See [Test2::Tools::Mock](https://metacpan.org/pod/Test2::Tools::Mock) for complete documentation. - Ref This exports tools for validating and comparing references. See [Test2::Tools::Ref](https://metacpan.org/pod/Test2::Tools::Ref) for complete documentation. - Spec This is an RSPEC implementation with concurrency support. See [Test2::Tools::Spec](https://metacpan.org/pod/Test2::Tools::Spec) for more details. - Subtest This exports tools for running subtests. See [Test2::Tools::Subtest](https://metacpan.org/pod/Test2::Tools::Subtest) for complete documentation. - Target This lets you load the package(s) you intend to test, and alias them into constants/package variables. See [Test2::Tools::Target](https://metacpan.org/pod/Test2::Tools::Target) for complete documentation. # INCLUDED PLUGINS - 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 [Test2::Plugin::BailOnFail](https://metacpan.org/pod/Test2::Plugin::BailOnFail) for complete documentation. - DieOnFail The much requested "die on first failure" plugin. When this plugin is loaded, any failure will cause the test to die immediately. See [Test2::Plugin::DieOnFail](https://metacpan.org/pod/Test2::Plugin::DieOnFail) for complete documentation. - ExitSummary This plugin gives you statistics and diagnostics at the end of your test in the event of a failure. See [Test2::Plugin::ExitSummary](https://metacpan.org/pod/Test2::Plugin::ExitSummary) for complete documentation. - SRand Use this to set the random seed to a specific seed, or to the current date. See [Test2::Plugin::SRand](https://metacpan.org/pod/Test2::Plugin::SRand) for complete documentation. - 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 [Test2::Plugin::UTF8](https://metacpan.org/pod/Test2::Plugin::UTF8) for complete documentation. # INCLUDED REQUIREMENT CHECKERS - AuthorTesting Using this package will cause the test file to be skipped unless the AUTHOR\_TESTING environment variable is set. See [Test2::Require::AuthorTesting](https://metacpan.org/pod/Test2::Require::AuthorTesting) for complete documentation. - EnvVar Using this package will cause the test file to be skipped unless a custom environment variable is set. See [Test2::Require::EnvVar](https://metacpan.org/pod/Test2::Require::EnvVar) for complete documentation. - Fork Using this package will cause the test file to be skipped unless the system is capable of forking (including emulated forking). See [Test2::Require::Fork](https://metacpan.org/pod/Test2::Require::Fork) for complete documentation. - RealFork Using this package will cause the test file to be skipped unless the system is capable of true forking. See [Test2::Require::RealFork](https://metacpan.org/pod/Test2::Require::RealFork) for complete documentation. - 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 [Test2::Require::Module](https://metacpan.org/pod/Test2::Require::Module) for complete documentation. - Perl Using this package will cause the test file to be skipped unless the specified minimum perl version is met. See [Test2::Require::Perl](https://metacpan.org/pod/Test2::Require::Perl) for complete documentation. - Threads Using this package will cause the test file to be skipped unless the system has threading enabled. **Note:** This will not turn threading on for you. See [Test2::Require::Threads](https://metacpan.org/pod/Test2::Require::Threads) for complete documentation. # SEE ALSO See the [Test2](https://metacpan.org/pod/Test2) documentation for a namespace map. Everything in this distribution uses [Test2](https://metacpan.org/pod/Test2). [Test2::Manual](https://metacpan.org/pod/Test2::Manual) is the Test2 Manual. # CONTACTING US Many Test2 developers and users lurk on [irc://irc.perl.org/#perl](irc://irc.perl.org/#perl). We also have a slack team that can be joined by anyone with an `@cpan.org` email address [https://perl-test2.slack.com/](https://perl-test2.slack.com/) If you do not have an `@cpan.org` email you can ask for a slack invite by emailing Chad Granum . # SOURCE The source code repository for Test2-Suite can be found at `https://github.com/Test-More/Test2-Suite/`. # MAINTAINERS - Chad Granum # AUTHORS - Chad Granum # COPYRIGHT Copyright 2018 Chad Granum . This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See `http://dev.perl.org/licenses/` Test2-Suite-0.000129/META.json0000644000175000017500000000352713615053353015411 0ustar exodistexodist{ "abstract" : "Distribution with a rich set of tools built upon the Test2 framework.", "author" : [ "Chad Granum " ], "dynamic_config" : 0, "generated_by" : "Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : 2 }, "name" : "Test2-Suite", "prereqs" : { "configure" : { "requires" : { "ExtUtils::MakeMaker" : "0" } }, "develop" : { "requires" : { "Test::Pod" : "1.41", "Test::Spelling" : "0.12" } }, "runtime" : { "requires" : { "B" : "0", "Carp" : "0", "Data::Dumper" : "0", "Exporter" : "0", "Importer" : "0.024", "Module::Pluggable" : "2.7", "Scalar::Util" : "0", "Scope::Guard" : "0", "Sub::Info" : "0.002", "Term::Table" : "0.013", "Test2::API" : "1.302158", "Time::HiRes" : "0", "overload" : "0", "perl" : "5.008001", "utf8" : "0" }, "suggests" : { "Sub::Name" : "0.11", "Term::ReadKey" : "0", "Term::Size::Any" : "0", "Unicode::GCString" : "0", "Unicode::LineBreak" : "0" } } }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "http://github.com/Test-More/Test2-Suite/issues" }, "repository" : { "type" : "git", "url" : "http://github.com/Test-More/Test2-Suite/" } }, "version" : "0.000129", "x_generated_by_perl" : "v5.30.0", "x_serialization_backend" : "Cpanel::JSON::XS version 4.12" } Test2-Suite-0.000129/META.yml0000644000175000017500000000165013615053353015234 0ustar exodistexodist--- abstract: 'Distribution with a rich set of tools built upon the Test2 framework.' author: - 'Chad Granum ' build_requires: {} configure_requires: ExtUtils::MakeMaker: '0' dynamic_config: 0 generated_by: 'Dist::Zilla version 6.012, CPAN::Meta::Converter version 2.150010' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: '1.4' name: Test2-Suite requires: B: '0' Carp: '0' Data::Dumper: '0' Exporter: '0' Importer: '0.024' Module::Pluggable: '2.7' Scalar::Util: '0' Scope::Guard: '0' Sub::Info: '0.002' Term::Table: '0.013' Test2::API: '1.302158' Time::HiRes: '0' overload: '0' perl: '5.008001' utf8: '0' resources: bugtracker: http://github.com/Test-More/Test2-Suite/issues repository: http://github.com/Test-More/Test2-Suite/ version: '0.000129' x_generated_by_perl: v5.30.0 x_serialization_backend: 'YAML::Tiny version 1.73' Test2-Suite-0.000129/cpanfile0000644000175000017500000000144213615053353015466 0ustar exodistexodistrequires "B" => "0"; requires "Carp" => "0"; requires "Data::Dumper" => "0"; requires "Exporter" => "0"; requires "Importer" => "0.024"; requires "Module::Pluggable" => "2.7"; requires "Scalar::Util" => "0"; requires "Scope::Guard" => "0"; requires "Sub::Info" => "0.002"; requires "Term::Table" => "0.013"; requires "Test2::API" => "1.302158"; requires "Time::HiRes" => "0"; requires "overload" => "0"; requires "perl" => "5.008001"; requires "utf8" => "0"; suggests "Sub::Name" => "0.11"; suggests "Term::ReadKey" => "0"; suggests "Term::Size::Any" => "0"; suggests "Unicode::GCString" => "0"; suggests "Unicode::LineBreak" => "0"; on 'configure' => sub { requires "ExtUtils::MakeMaker" => "0"; }; on 'develop' => sub { requires "Test::Pod" => "1.41"; requires "Test::Spelling" => "0.12"; }; Test2-Suite-0.000129/MANIFEST0000644000175000017500000001505713615053353015122 0ustar exodistexodist# This file was automatically generated by Dist::Zilla::Plugin::Manifest v6.012. Changes LICENSE MANIFEST META.json META.yml Makefile.PL README README.md appveyor.yml cpanfile lib/Test2/AsyncSubtest.pm lib/Test2/AsyncSubtest/Event/Attach.pm lib/Test2/AsyncSubtest/Event/Detach.pm lib/Test2/AsyncSubtest/Formatter.pm lib/Test2/AsyncSubtest/Hub.pm lib/Test2/Bundle.pm lib/Test2/Bundle/Extended.pm lib/Test2/Bundle/More.pm lib/Test2/Bundle/Simple.pm lib/Test2/Compare.pm lib/Test2/Compare/Array.pm lib/Test2/Compare/Bag.pm lib/Test2/Compare/Base.pm lib/Test2/Compare/Bool.pm lib/Test2/Compare/Custom.pm lib/Test2/Compare/DeepRef.pm lib/Test2/Compare/Delta.pm lib/Test2/Compare/Event.pm lib/Test2/Compare/EventMeta.pm lib/Test2/Compare/Float.pm lib/Test2/Compare/Hash.pm lib/Test2/Compare/Meta.pm lib/Test2/Compare/Negatable.pm lib/Test2/Compare/Number.pm lib/Test2/Compare/Object.pm lib/Test2/Compare/OrderedSubset.pm lib/Test2/Compare/Pattern.pm lib/Test2/Compare/Ref.pm lib/Test2/Compare/Regex.pm lib/Test2/Compare/Scalar.pm lib/Test2/Compare/Set.pm lib/Test2/Compare/String.pm lib/Test2/Compare/Undef.pm lib/Test2/Compare/Wildcard.pm lib/Test2/Manual.pm lib/Test2/Manual/Anatomy.pm lib/Test2/Manual/Anatomy/API.pm lib/Test2/Manual/Anatomy/Context.pm lib/Test2/Manual/Anatomy/EndToEnd.pm lib/Test2/Manual/Anatomy/Event.pm lib/Test2/Manual/Anatomy/Hubs.pm lib/Test2/Manual/Anatomy/IPC.pm lib/Test2/Manual/Anatomy/Utilities.pm lib/Test2/Manual/Concurrency.pm lib/Test2/Manual/Contributing.pm lib/Test2/Manual/Testing.pm lib/Test2/Manual/Testing/Introduction.pm lib/Test2/Manual/Testing/Migrating.pm lib/Test2/Manual/Testing/Planning.pm lib/Test2/Manual/Testing/Todo.pm lib/Test2/Manual/Tooling.pm lib/Test2/Manual/Tooling/FirstTool.pm lib/Test2/Manual/Tooling/Formatter.pm lib/Test2/Manual/Tooling/Nesting.pm lib/Test2/Manual/Tooling/Plugin/TestExit.pm lib/Test2/Manual/Tooling/Plugin/TestingDone.pm lib/Test2/Manual/Tooling/Plugin/ToolCompletes.pm lib/Test2/Manual/Tooling/Plugin/ToolStarts.pm lib/Test2/Manual/Tooling/Subtest.pm lib/Test2/Manual/Tooling/TestBuilder.pm lib/Test2/Manual/Tooling/Testing.pm lib/Test2/Mock.pm lib/Test2/Plugin.pm lib/Test2/Plugin/BailOnFail.pm lib/Test2/Plugin/DieOnFail.pm lib/Test2/Plugin/ExitSummary.pm lib/Test2/Plugin/SRand.pm lib/Test2/Plugin/Times.pm lib/Test2/Plugin/UTF8.pm lib/Test2/Require.pm lib/Test2/Require/AuthorTesting.pm lib/Test2/Require/EnvVar.pm lib/Test2/Require/Fork.pm lib/Test2/Require/Module.pm lib/Test2/Require/Perl.pm lib/Test2/Require/RealFork.pm lib/Test2/Require/Threads.pm lib/Test2/Suite.pm lib/Test2/Todo.pm lib/Test2/Tools.pm lib/Test2/Tools/AsyncSubtest.pm lib/Test2/Tools/Basic.pm lib/Test2/Tools/Class.pm lib/Test2/Tools/ClassicCompare.pm lib/Test2/Tools/Compare.pm lib/Test2/Tools/Defer.pm lib/Test2/Tools/Encoding.pm lib/Test2/Tools/Event.pm lib/Test2/Tools/Exception.pm lib/Test2/Tools/Exports.pm lib/Test2/Tools/GenTemp.pm lib/Test2/Tools/Grab.pm lib/Test2/Tools/Mock.pm lib/Test2/Tools/Ref.pm lib/Test2/Tools/Spec.pm lib/Test2/Tools/Subtest.pm lib/Test2/Tools/Target.pm lib/Test2/Tools/Tester.pm lib/Test2/Tools/Warnings.pm lib/Test2/Util/Grabber.pm lib/Test2/Util/Ref.pm lib/Test2/Util/Stash.pm lib/Test2/Util/Sub.pm lib/Test2/Util/Table.pm lib/Test2/Util/Table/Cell.pm lib/Test2/Util/Table/LineBreak.pm lib/Test2/Util/Term.pm lib/Test2/Util/Times.pm lib/Test2/V0.pm lib/Test2/Workflow.pm lib/Test2/Workflow/BlockBase.pm lib/Test2/Workflow/Build.pm lib/Test2/Workflow/Runner.pm lib/Test2/Workflow/Task.pm lib/Test2/Workflow/Task/Action.pm lib/Test2/Workflow/Task/Group.pm perltidyrc t/00-report.t t/acceptance/OO.t t/acceptance/Tools.t t/acceptance/Workflow-Acceptance.t t/acceptance/Workflow-Acceptance2.t t/acceptance/Workflow-Acceptance3.t t/acceptance/Workflow-Acceptance4.t t/acceptance/Workflow-Acceptance5.t t/acceptance/skip.t t/acceptance/spec.t t/behavior/Mocking.t t/behavior/async_trace.t t/behavior/filtering.t t/behavior/no_done_testing.t t/behavior/no_leaks_any.t t/behavior/no_leaks_no_fork.t t/behavior/no_leaks_no_iso.t t/behavior/no_leaks_no_threads.t t/behavior/simple.t t/lib/MyTest/Target.pm t/load_manual.t t/modules/AsyncSubtest.t t/modules/AsyncSubtest/Event/Attach.t t/modules/AsyncSubtest/Event/Detach.t t/modules/AsyncSubtest/Hub.t t/modules/Bundle.t t/modules/Bundle/Extended.t t/modules/Bundle/More.t t/modules/Bundle/Simple.t t/modules/Compare.t t/modules/Compare/Array.t t/modules/Compare/Bag.t t/modules/Compare/Base.t t/modules/Compare/Bool.t t/modules/Compare/Custom.t t/modules/Compare/Delta.t t/modules/Compare/Event.t t/modules/Compare/EventMeta.t t/modules/Compare/Float.t t/modules/Compare/Hash.t t/modules/Compare/Meta.t t/modules/Compare/Number.t t/modules/Compare/Object.t t/modules/Compare/OrderedSubset.t t/modules/Compare/Pattern.t t/modules/Compare/Ref.t t/modules/Compare/Regex.t t/modules/Compare/Scalar.t t/modules/Compare/Set.t t/modules/Compare/String.t t/modules/Compare/Undef.t t/modules/Compare/Wildcard.t t/modules/Mock.t t/modules/Plugin.t t/modules/Plugin/BailOnFail.t t/modules/Plugin/DieOnFail.t t/modules/Plugin/ExitSummary.t t/modules/Plugin/SRand.t t/modules/Plugin/Times.t t/modules/Plugin/UTF8.t t/modules/Require.t t/modules/Require/AuthorTesting.t t/modules/Require/EnvVar.t t/modules/Require/Fork.t t/modules/Require/Module.t t/modules/Require/Perl.t t/modules/Require/RealFork.t t/modules/Require/Threads.t t/modules/Suite.t t/modules/Todo.t t/modules/Tools.t t/modules/Tools/AsyncSubtest.t t/modules/Tools/Basic.t t/modules/Tools/Class.t t/modules/Tools/ClassicCompare.t t/modules/Tools/ClassicCompare2.t t/modules/Tools/Compare.t t/modules/Tools/Defer.t t/modules/Tools/Encoding.t t/modules/Tools/Event.t t/modules/Tools/Exception.t t/modules/Tools/Exports.t t/modules/Tools/GenTemp.t t/modules/Tools/Grab.t t/modules/Tools/Mock.t t/modules/Tools/Ref.t t/modules/Tools/Spec.t t/modules/Tools/Subtest.t t/modules/Tools/Target.t t/modules/Tools/Tester.t t/modules/Tools/Warnings.t t/modules/Util/Grabber.t t/modules/Util/Ref.t t/modules/Util/Stash.t t/modules/Util/Sub.t t/modules/Util/Table.t t/modules/Util/Table/Cell.t t/modules/Util/Table/LineBreak.t t/modules/Util/Times.t t/modules/V0.t t/modules/Workflow.t t/modules/Workflow/BlockBase.t t/modules/Workflow/Build.t t/modules/Workflow/Runner.t t/modules/Workflow/Task.t t/modules/Workflow/Task/Action.t t/modules/Workflow/Task/Group.t t/regression/10-set_and_dne.t t/regression/132-bool.t t/regression/27-1-Test2-Bundle-More.t t/regression/27-2-Test2-Tools-Compare.t t/regression/27-3-Test2-Tools-ClassicCompare.t t/regression/43-bag-on-empty.t t/regression/Test2-Mock.t t/regression/Test2-Tools-Class.t t/regression/async_subtest_missing_parent.t t/regression/todo_and_facets.t t/regression/utf8-mock.t Test2-Suite-0.000129/Changes0000644000175000017500000005226213615053353015263 0ustar exodistexodist0.000129 2020-01-31 08:33:46-08:00 America/Los_Angeles - José Joaquín Atria Improve error handling of mock->override with AUTOLOADed methods 0.000128 2020-01-30 08:45:43-08:00 America/Los_Angeles - Nicolas R Import option to skip utf8 import - Victoria Mihell-Hale Correct POD for Test2/Tools/Mock.pm's mocked() method - Victoria Mihell-Hale Fix miscellaneous typos in Test2(/Tools)/Mock.pm POD - Nicolas R Add GitHub actions - Daniel Mita Fix PKG case for Test2::Tools::Target docs - Daniel Mita Document target change in V0 and Bundle::Extended - Daniel Mita Allow hashref to be used for Test2::Tools::Target 0.000127 2019-10-30 21:25:29-07:00 America/Los_Angeles - Fix srand toggling 0.000126 2019-08-28 12:44:59-07:00 America/Los_Angeles - Mention HUGE caveat in Test2::Plugin::Times - Make Test2::Util::Times::render_duration support 1 arg form 0.000125 2019-08-19 10:40:20-07:00 America/Los_Angeles - Add harness_job_fields to Times plugin 0.000124 2019-08-16 14:54:25-07:00 America/Los_Angeles - Make Times plugin use INFO facets for display 0.000123 2019-08-16 13:21:29-07:00 America/Los_Angeles - Fix double-load bug on Plugin::Times 0.000122 2019-05-18 08:21:20-07:00 America/Los_Angeles - Fix diag issues with ClassicCompare 0.000121 2019-05-07 12:00:27-07:00 America/Los_Angeles - Tracking for mocked methods - Include raw table in facet data when compare fails 0.000120 2019-04-26 05:19:18-07:00 America/Los_Angeles - Allow all_items inside bag 0.000119 2019-03-16 15:17:33-07:00 America/Los_Angeles - Allow meta-checks in bag/array/hash (Thanks jjatria) 0.000118 2019-01-18 13:44:06-08:00 America/Los_Angeles - Fix typo Test::Workflow -> Test2::Workflow #170 - Fix test broken by new Test-Simple #175 0.000117 2018-12-04 11:37:15-08:00 America/Los_Angeles - Remove test that belongs in another dist 0.000116 2018-11-28 15:47:12-08:00 America/Los_Angeles - Add 'set' to mock tools - Fix 'overload' issue in deep check cycle detection. - Minor updates 0.000115 2018-07-11 09:39:37-07:00 America/Los_Angeles - Fix warning on undefined note/diag - Improve an error message. 0.000114 2018-04-19 08:39:56-07:00 America/Los_Angeles - Fix missing manual section 0.000113 2018-04-19 08:03:42-07:00 America/Los_Angeles - Fix typo 0.000112 2018-04-19 07:15:40-07:00 America/Los_Angeles - Switch spec to use the testing_done callback - Update copyright dates - Finish the Anatomy manual section - Finish the Tooling manual section 0.000111 2018-03-14 12:37:45-07:00 America/Los_Angeles - No Changes since last trial 0.000110 2018-03-13 13:36:37-07:00 America/Los_Angeles (TRIAL RELEASE) - Allow events from unattached processes in AsyncSubtest 0.000109 2018-03-12 13:20:18-07:00 America/Los_Angeles (TRIAL RELEASE) - Add AsyncSubtest retrieval to hubs 0.000108 2018-03-11 12:51:56-07:00 America/Los_Angeles - No changes since last release 0.000107 2018-03-09 15:43:30-08:00 America/Los_Angeles (TRIAL RELEASE) - Add rounded() and within() wrappers for approximate comparisons 0.000106 2018-03-06 13:10:55-08:00 America/Los_Angeles - No changes since trial 0.000105 2018-03-06 09:13:36-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix nesting bug in Test2::Workflow 0.000104 2018-03-05 09:27:44-08:00 America/Los_Angeles - Add Data::Dumper to dep list (#154) 0.000103 2018-03-02 13:00:54-08:00 America/Los_Angeles (TRIAL RELEASE) - AsyncSubtest now works with UUIDs and adds other proper meta-data 0.000102 2018-03-02 09:45:27-08:00 America/Los_Angeles - No Changes since last trial 0.000101 2018-02-21 16:27:18-08:00 America/Los_Angeles (TRIAL RELEASE) - Add much needed verbosity to 'You must attach to an AsyncSubtest ...' errors - Documentation updates 0.000100 2018-02-13 21:41:30-08:00 America/Los_Angeles - No changes from last TRIAL 0.000099 2018-02-06 12:53:16-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix AsyncSubtest plan to be at the right nesting, and buffered 0.000098 2018-02-06 12:05:28-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix AsyncSubtest main event buffered/nesting values - Fix bug where AsyncSub test vanishes with no error when finished after its parent ends. 0.000097 2017-12-10 20:23:21-08:00 America/Los_Angeles - Documentation fixes 0.000096 2017-12-09 10:13:21-08:00 America/Los_Angeles - No changes since last trial 0.000095 2017-12-08 14:14:16-08:00 America/Los_Angeles (TRIAL RELEASE) - Discoruage use of fragile thread features (rarely used) - Skip fragile/discrouaged tests outside author testing. - Document the above, and an env var to activate tests when desired 0.000094 2017-11-29 18:51:54-08:00 America/Los_Angeles - No Changes since last trial 0.000093 2017-11-28 20:21:09-08:00 America/Los_Angeles (TRIAL RELEASE) - Minor test changes for thread safety 0.000092 2017-11-28 10:17:37-08:00 America/Los_Angeles - No changes since last trial 0.000091 2017-11-27 14:17:00-08:00 America/Los_Angeles (TRIAL RELEASE) - Remove experiments from last several trials 0.000090 2017-11-26 18:52:06-08:00 America/Los_Angeles (TRIAL RELEASE) - Fix potential infinite hang in temp debugging 0.000089 2017-11-26 11:16:15-08:00 America/Los_Angeles (TRIAL RELEASE) - More debugging 0.000088 2017-11-26 10:18:46-08:00 America/Los_Angeles (TRIAL RELEASE) - Add some debugging and an alternate IPC driver - Temporary, this will be reverted 0.000087 2017-11-24 12:28:27-08:00 America/Los_Angeles (TRIAL RELEASE) - Merge in Test2::Workflow - Merge in Test2::AsyncSubtest - Merge in Test2::Manual Test2-Suite 0.000086 2017-11-22 22:15:41-08:00 America/Los_Angeles (TRIAL RELEASE) - Make an AUTHOR_TEST require 5.20 Test2-Suite 0.000085 2017-11-22 22:05:11-08:00 America/Los_Angeles (TRIAL RELEASE) - Ensure that objects are not used in Boolean contexts, second attempt. (djerius) Test2-Suite 0.000084 2017-11-18 16:17:29-08:00 America/Los_Angeles - Add Test2::Tools::Tester Test2-Suite 0.000083 2017-10-25 08:12:18-07:00 America/Los_Angeles - Mark a float tests TODO until the PR author can fix it Test2-Suite 0.000082 2017-10-20 07:11:08-07:00 America/Los_Angeles - No Changes since last trial Test2-Suite 0.000081 2017-10-19 09:09:14-07:00 America/Los_Angeles (TRIAL RELEASE) - Add Test2::Compare::Float to handle floating point comparison issues with representation error. - Add float() to Test2::Utils::Compare and import Test2::Compare::Float - Import and Export Test2::Utils::Compare::float in Test2::V0 - Documentation fixes - Better 5.10.0/utf8 fix - VSTRING comparisons - Bag compare now handles duplicates better Test2-Suite 0.000080 2017-10-15 10:13:30-07:00 America/Los_Angeles - No changes since last trial Test2-Suite 0.000079 2017-10-14 20:18:51-07:00 America/Los_Angeles (TRIAL RELEASE) - (Colin Newell) Fix UTF8 issue with perl 5.10.0 Test2-Suite 0.000078 2017-10-14 20:15:21-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix for TODO + new ok style Test2-Suite 0.000077 2017-09-12 07:49:16-07:00 America/Los_Angeles - No changes since last TRIAL release Test2-Suite 0.000076 2017-09-11 15:21:07-07:00 America/Los_Angeles (TRIAL RELEASE) - Add Test2::Tools::GenTemp Test2-Suite 0.000075 2017-09-10 21:22:17-07:00 America/Los_Angeles - Add version to Test2::Event::Times Test2-Suite 0.000074 2017-08-31 20:37:47-07:00 America/Los_Angeles (TRIAL RELEASE) - Add Test2::Event::Times - Fix some tests that were failing in yath Test2-Suite 0.000073 2017-08-30 23:11:28-07:00 America/Los_Angeles (TRIAL RELEASE) - Add Test2::Plugin::Times Test2-Suite 0.000072 2017-06-17 21:48:14-07:00 America/Los_Angeles - No change since last trial Test2-Suite 0.000071 2017-06-10 13:40:27-07:00 America/Los_Angeles (TRIAL RELEASE) - Introduce Test2::V# bundles - Deprecate Test2::Bundle::Extended - Test2::V0 added - Fix Test2::Mock doesn't accept non-ref values (Mike Raynham) - Fix isa_ok overload issue (Mike Raynham) Test2-Suite 0.000070 2017-03-19 13:34:25-07:00 America/Los_Angeles - Revert Boolean overload fixes from djerius until they can be fixed - Do not mention Term::ReadKey in docs - Add Term::Size::Any to test report Test2-Suite 0.000069 2017-03-16 20:57:43-07:00 America/Los_Angeles - No changes from trial Test2-Suite 0.000068 2017-03-08 20:22:23-08:00 America/Los_Angeles (TRIAL RELEASE) - Set the term size for all tests that use tables - Boolean overload fixes from djerius Test2-Suite 0.000067 2017-01-03 19:41:52-08:00 America/Los_Angeles - No changes Test2-Suite 0.000066 2016-12-23 15:16:18-08:00 America/Los_Angeles (TRIAL RELEASE) - Move sub_info to Sub::Info Test2-Suite 0.000065 2016-12-19 19:46:47-08:00 America/Los_Angeles - AUTHOR_TESTING a fragile test Test2-Suite 0.000064 2016-12-19 11:56:28-08:00 America/Los_Angeles (TRIAL RELEASE) - Move Test2::Util::Table to Term::Table Test2-Suite 0.000063 2016-12-17 12:11:39-08:00 America/Los_Angeles - No notable changes since the last trial release. Test2-Suite 0.000062 2016-12-03 14:03:44-08:00 America/Los_Angeles (TRIAL RELEASE) - An event without a trace object throw would an exception when using Test2::Compare::Event and the comparison failed - Fix tests for small terminals (#106) - Enhance the table library - UTF8 plugin does not set STDERR/STDOUT Test2-Suite 0.000061 2016-11-26 12:39:14-08:00 America/Los_Angeles - Fix mocked objects so that they respond properly to ->can when using AUTOLOAD. - Fix some meta-files - Small build improvements - Minor fixes Test2-Suite 0.000060 2016-09-25 12:38:43-07:00 America/Los_Angeles - Fix some docs - Fix defer.t to work in windows - Fix stack stomping bug triggered by certain Term::Readkey conditions Test2-Suite 0.000059 2016-09-15 13:00:03-07:00 America/Los_Angeles (TRIAL RELEASE) - Create Test2::Compare::Negatable - Add bool() for deep comparisons - Implicit end() for checks inside is() - Add try_ok to Tools/Exception - Export convert() in Test2::Compare - Make convert more flexible - Document how to write a compare tool with custom behavior Test2-Suite 0.000058 2016-08-13 13:06:10-07:00 America/Los_Angeles - No changes from last trial Test2-Suite 0.000057 2016-08-10 22:13:39-07:00 America/Los_Angeles (TRIAL RELEASE) - Add contact info to docs Test2-Suite 0.000056 2016-08-09 14:09:17-07:00 America/Los_Angeles (TRIAL RELEASE) - Make sure Test2::Compare::convert loads deps Test2-Suite 0.000055 2016-07-30 13:18:13-07:00 America/Los_Angeles - Spelling fix from Debian (Thanks gregor herrmann) - Fix \d -> [0-9] in several places (Thanks Mark F.) Test2-Suite 0.000054 2016-07-28 07:10:34-07:00 America/Los_Angeles - No changes from last trial Test2-Suite 0.000053 2016-07-22 22:51:37-07:00 America/Los_Angeles (TRIAL RELEASE) - Make bag check fail when given an empty array - Clean up bag diagnostics Test2-Suite 0.000052 2016-07-18 09:07:25-07:00 America/Los_Angeles - No changes from last TRIAL Test2-Suite 0.000051 2016-07-13 18:00:17-07:00 America/Los_Angeles (TRIAL RELEASE) - Switch Extended bundle to use Importer - Add meta_check as alias for meta Test2-Suite 0.000050 2016-07-09 16:58:59-07:00 America/Los_Angeles - No Changes since trial Test2-Suite 0.000049 2016-07-07 22:02:24-07:00 America/Los_Angeles (TRIAL RELEASE) - Doc fixes - Add U() quick check to Test2::Tools::Compare Test2-Suite 0.000048 2016-07-02 22:08:10-07:00 America/Los_Angeles - No changes from last trial Test2-Suite 0.000047 2016-07-01 18:09:26-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix global destruction warning - Minor test fix to keep 5.8 working Test2-Suite 0.000046 2016-07-01 17:31:23-07:00 America/Los_Angeles (TRIAL RELEASE) - ref-ref's can be used in deep comparisons - Fix mocking to override a base class's method Test2-Suite 0.000045 2016-07-01 09:30:09-07:00 America/Los_Angeles - Spelling and POD fixes Test2-Suite 0.000044 2016-06-29 15:48:33-07:00 America/Los_Angeles (TRIAL RELEASE) - Add DF() shortcut (JBerger) Test2-Suite 0.000043 2016-06-28 06:23:46-07:00 America/Los_Angeles (TRIAL RELEASE) - Restructure Delta.pm to try and solve read-only problem Test2-Suite 0.000042 2016-06-27 21:37:22-07:00 America/Los_Angeles - Change Encoding.t to spit out debug message without failing Test2-Suite 0.000041 2016-06-27 09:00:46-07:00 America/Los_Angeles - Add perltidy rc to dist - Documentation fixes (Thanks petdance) - revert "Attempt a fix to Delta #29" Test2-Suite 0.000039 2016-06-25 13:44:03-07:00 America/Los_Angeles (TRIAL RELEASE) - Stop leaking temp files - clean up STDERR - Fix #28 Test2-Suite 0.000038 2016-06-25 13:20:07-07:00 America/Los_Angeles - No Changes from last TRIAL release Test2-Suite 0.000037 2016-06-24 14:03:52-07:00 America/Los_Angeles (TRIAL RELEASE) - Add all_keys() to Compare tools - add all_vals() to Compare tools - add all_items() to Compare tools - Fix in_set(DNE) (#10) - Add E() - Proper line reporting for shortcuts. Test2-Suite 0.000036 2016-06-24 05:58:51-07:00 America/Los_Angeles - Better comments in SRAND (#7) Test2-Suite 0.000035 2016-06-23 14:48:54-07:00 America/Los_Angeles (TRIAL RELEASE) - Make it possible to provide a name to isa_ok, can_ok, and DOES_ok - Add some regression tests for previous fixes - Allow 'tests' and 'skip_all' prefixes support to plan() #25 Test2-Suite 0.000034 2016-06-22 11:30:00-07:00 America/Los_Angeles (TRIAL RELEASE) - Bump minimum Test2 version Test2-Suite 0.000033 2016-06-22 08:41:22-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix ClassicCompare to load deps (#23) Test2-Suite 0.000032 2016-06-17 06:58:17-07:00 America/Los_Angeles - Add 'bag' comparison (dakkar) - Add 'call_list()' for DSL (dakkar) - Add 'call_hash()' for DSL (dakkar) Test2-Suite 0.000031 2016-06-15 21:32:05-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix TODO to use pre-filters Test2-Suite 0.000030 2016-05-09 07:55:17-07:00 America/Los_Angeles - Doc Changes Test2-Suite 0.000029 2016-04-30 15:17:01-07:00 America/Los_Angeles - Doc updates from jkeroes - Doc updates from stevieb9 - SRand now works without harness - Fix emails Test2-Suite 0.000028 2016-04-15 14:32:30-07:00 America/Los_Angeles - Add Tools/Event gen_event() - Add Tools/Event to Extended bundle Test2-Suite 0.000027 2016-04-13 20:22:17-07:00 America/Los_Angeles - Make some tests ignore custom formatters Test2-Suite 0.000026 2016-04-05 11:11:35-07:00 America/Los_Angeles - Add OrderedSubset compare tools - Use OrderedSubset compare tool in subtest tests. - Bump minimumTest2 version Test2-Suite 0.000025 2016-04-03 15:39:59-07:00 America/Los_Angeles - Allow column aliasing in Deltas (jkeroes) - Bump required Test2 version Test2-Suite 0.000024 2016-03-20 13:40:06-07:00 America/Los_Angeles - Add back missing README and README.md files - Documentation fixes - No logic/code changes Test2-Suite 0.000023 2016-03-17 23:02:50-07:00 America/Los_Angeles - Fix Changes file - Fix bug where SRand plugin comment could appear in subtest Test2-Suite 0.000022 2016-03-07 12:18:25-08:00 America/Los_Angeles - Ability to disable subtest skip_all flow control Test2-Suite 0.000021 2016-03-06 20:24:46-08:00 America/Los_Angeles - Bump minimum Test2 version - Add version to all modules - Minor doc fixes - No logic changes Test2-Suite 0.000020 2016-02-05 09:32:52-08:00 America/Los_Angeles - Fix typo that made mock tool look in the wrong place for handlers Test2-Suite 0.000019 2016-01-28 21:28:37-08:00 America/Los_Angeles - Formally add the warning and exception tools - warning and exception tools added to the extended bundle Test2-Suite 0.000018 2016-01-12 16:09:44-08:00 America/Los_Angeles - Add grab tool - Fix documentation Test2-Suite 0.000017 2016-01-12 05:54:43-08:00 America/Los_Angeles - Fix poorly written test Test2-Suite 0.000016 2016-01-11 15:18:04-08:00 America/Los_Angeles - Add diagnostics test report - Fix tests on older perls Test2-Suite 0.000015 2016-01-10 22:50:54-08:00 America/Los_Angeles - Fix documentation problem Test2-Suite 0.000014 2016-01-10 22:42:56-08:00 America/Los_Angeles - Initial conversion from Test::Stream Test2-Harness 0.000018 2017-01-31 21:33:34-08:00 America/Los_Angeles - Use Sub::Info to silence a warning Test2-Harness 0.000017 2016-07-31 21:24:00-07:00 America/Los_Angeles - Fix acceptance5.t to not assume fork is used. Test2-Harness 0.000016 2016-07-29 12:37:29-07:00 America/Los_Angeles - Require newer Importer.pm for :ALL tag Test2-Harness 0.000015 2016-07-28 07:07:37-07:00 America/Los_Angeles - Run blocks when done_testing is missing (#3) - Add spec_defaults() Test2-Harness 0.000014 2016-07-02 22:11:29-07:00 America/Los_Angeles - No Changes from last trial Test2-Harness 0.000013 2016-07-01 17:33:24-07:00 America/Los_Angeles (TRIAL RELEASE) - Do not apply mock defined on root action. Test2-Harness 0.000012 2016-06-24 06:01:16-07:00 America/Los_Angeles - No changes since last trial Test2-Harness 0.000011 2016-06-22 11:32:58-07:00 America/Los_Angeles (TRIAL RELEASE) - Require newer Test2::AsyncSubtest for bugfixes Test2-Harness 0.000010 2016-06-22 09:16:07-07:00 America/Los_Angeles - Fix for (and require) Test2-Suite 0.000032 (#2) - Better TODO handling Test2-Harness 0.000009 2016-05-31 07:18:50-07:00 America/Los_Angeles - Require perl 5.10 Test2-Harness 0.000008 2016-05-30 07:38:55-07:00 America/Los_Angeles - Require newer Test2::AsyncSubtest Test2-Harness 0.000007 2016-05-30 06:58:17-07:00 America/Los_Angeles - Complete rewrite Test2-Harness 0.000006 2016-02-05 15:45:57-08:00 America/Los_Angeles - Prep for a new Trace::Mask version Test2-Harness 0.000005 2016-02-05 11:56:11-08:00 America/Los_Angeles - Bump minimum Test2::Suite version (fixes issue found in windows tests) Test2-Harness 0.000004 2016-02-04 21:48:07-08:00 America/Los_Angeles - Add Spec bundle Test2-Harness 0.000003 2016-02-04 10:46:41-08:00 America/Los_Angeles - Fix test that needs to be conditional - Fix constant in NoIso Test2-Harness 0.000002 2016-02-03 08:12:34-08:00 America/Los_Angeles - Major overhaul - Add isolation runners - Lots of fixes - Masking traces properly - Better filtering Test2-Harness 0.000001 2016-01-18 10:54:17-08:00 America/Los_Angeles - Initial conversion from Test::Stream Test2-AsyncSubtest 0.000020 2017-09-10 21:23:49-07:00 America/Los_Angeles - No Changes from last release Test2-AsyncSubtest 0.000019 2017-09-08 12:21:34-07:00 America/Los_Angeles (TRIAL RELEASE) - Fix support for formatters that show buffered events Test2-AsyncSubtest 0.000018 2016-06-24 06:00:04-07:00 America/Los_Angeles - No changes since last trial Test2-AsyncSubtest 0.000017 2016-06-22 11:32:15-07:00 America/Los_Angeles (TRIAL RELEASE) - Make our hub inherit pre_filters properly Test2-AsyncSubtest 0.000016 2016-05-30 07:36:39-07:00 America/Los_Angeles - Fix bug where subtest results were repeated Test2-AsyncSubtest 0.000015 2016-05-09 08:03:51-07:00 America/Los_Angeles Test2-AsyncSubtest 0.000014 2016-04-14 09:40:01-07:00 America/Los_Angeles - Support custom formatters - Add subtest info to events Test2-AsyncSubtest 0.000013 2016-03-20 13:47:39-07:00 America/Los_Angeles - Add subtest name to pending warning Test2-AsyncSubtest 0.000012 2016-03-18 17:52:46-07:00 America/Los_Angeles - Fix trigger conditions for pending warning Test2-AsyncSubtest 0.000011 2016-03-18 08:12:05-07:00 America/Los_Angeles - Inherit listeners and filters (make TODO work) - Add 'todo' option to finish() Test2-AsyncSubtest 0.000010 2016-03-17 23:21:58-07:00 America/Los_Angeles - Fix bug in 'skip' option when nesting Test2-AsyncSubtest 0.000009 2016-03-17 11:51:08-07:00 America/Los_Angeles - Add 'skip' option for finish() Test2-AsyncSubtest 0.000008 2016-03-10 16:53:55-08:00 America/Los_Angeles - Add 'silent', 'no_plan' and 'collapse' options for finish() Test2-AsyncSubtest 0.000007 2016-03-09 10:07:53-08:00 America/Los_Angeles - Fix tests for some perl+thread combos Test2-AsyncSubtest 0.000006 2016-03-08 08:47:22-08:00 America/Los_Angeles - Fix #6, make tools more argument aware Test2-AsyncSubtest 0.000005 2016-03-07 12:21:28-08:00 America/Los_Angeles - Add ability to bypass subtest skip_all flow control Test2-AsyncSubtest 0.000004 2016-03-06 20:19:02-08:00 America/Los_Angeles - Require newer Test2 - Add extended skip_all tests - Add version to all modules (autarch) Test2-AsyncSubtest 0.000003 2016-03-05 17:33:15-08:00 America/Los_Angeles - Update for min threads version Test2-AsyncSubtest 0.000002 2016-03-02 13:49:22-08:00 America/Los_Angeles - Complete Rewrite Test2-AsyncSubtest 0.000001 2016-02-23 15:35:07-08:00 America/Los_Angeles - Initial Release Test2-Suite-0.000129/LICENSE0000644000175000017500000004365213615053353015000 0ustar exodistexodistThis software is copyright (c) 2020 by Chad Granum. This is free software; you can redistribute it and/or modify it under the same terms as the Perl 5 programming language system itself. Terms of the Perl programming language system itself a) the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version, or b) the "Artistic License" --- The GNU General Public License, Version 1, February 1989 --- This software is Copyright (c) 2020 by Chad Granum. This is free software, licensed under: The GNU General Public License, Version 1, February 1989 GNU GENERAL PUBLIC LICENSE Version 1, February 1989 Copyright (C) 1989 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The license agreements of most software companies try to keep users at the mercy of those companies. By contrast, our General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. The General Public License applies to the Free Software Foundation's software and to any other program whose authors commit to using it. You can use it for your programs, too. When we speak of free software, we are referring to freedom, not price. Specifically, the General Public License is designed to make sure that you have the freedom to give away or sell copies of free software, that you receive source code or can get it if you want it, that you can change the software or use pieces of it in new free programs; and that you know you can do these things. To protect your rights, we need to make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of a such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. You must make sure that they, too, receive or can get the source code. And you must tell them their rights. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License Agreement applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any work containing the Program or a portion of it, either verbatim or with modifications. Each licensee is addressed as "you". 1. You may copy and distribute verbatim copies of the Program's source code as you receive it, in any medium, provided that you conspicuously and appropriately publish on each copy an appropriate copyright notice and disclaimer of warranty; keep intact all the notices that refer to this General Public License and to the absence of any warranty; and give any other recipients of the Program a copy of this General Public License along with the Program. You may charge a fee for the physical act of transferring a copy. 2. You may modify your copy or copies of the Program or any portion of it, and copy and distribute such modifications under the terms of Paragraph 1 above, provided that you also do the following: a) cause the modified files to carry prominent notices stating that you changed the files and the date of any change; and b) cause the whole of any work that you distribute or publish, that in whole or in part contains the Program or any part thereof, either with or without modifications, to be licensed at no charge to all third parties under the terms of this General Public License (except that you may choose to grant warranty protection to some or all third parties, at your option). c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the simplest and most usual way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this General Public License. d) You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. Mere aggregation of another independent work with the Program (or its derivative) on a volume of a storage or distribution medium does not bring the other work under the scope of these terms. 3. You may copy and distribute the Program (or a portion or derivative of it, under Paragraph 2) in object code or executable form under the terms of Paragraphs 1 and 2 above provided that you also do one of the following: a) accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Paragraphs 1 and 2 above; or, b) accompany it with a written offer, valid for at least three years, to give any third party free (except for a nominal charge for the cost of distribution) a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Paragraphs 1 and 2 above; or, c) accompany it with the information you received as to where the corresponding source code may be obtained. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form alone.) Source code for a work means the preferred form of the work for making modifications to it. For an executable file, complete source code means all the source code for all modules it contains; but, as a special exception, it need not include source code for modules which are standard libraries that accompany the operating system on which the executable file runs, or for standard header files or definitions files that accompany that operating system. 4. You may not copy, modify, sublicense, distribute or transfer the Program except as expressly provided under this General Public License. Any attempt otherwise to copy, modify, sublicense, distribute or transfer the Program is void, and will automatically terminate your rights to use the Program under this License. However, parties who have received copies, or rights to use copies, from you under this General Public License will not have their licenses terminated so long as such parties remain in full compliance. 5. By copying, distributing or modifying the Program (or any work based on the Program) you indicate your acceptance of this license to do so, and all its terms and conditions. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. 7. The Free Software Foundation may publish revised and/or new versions of the General Public License from time to time. Such new versions will be similar in spirit to the present version, but may differ in detail to address new problems or concerns. Each version is given a distinguishing version number. If the Program specifies a version number of the license which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of the license, you may choose any version ever published by the Free Software Foundation. 8. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 9. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, THERE IS NO WARRANTY FOR THE PROGRAM, TO THE EXTENT PERMITTED BY APPLICABLE LAW. EXCEPT WHEN OTHERWISE STATED IN WRITING THE COPYRIGHT HOLDERS AND/OR OTHER PARTIES PROVIDE THE PROGRAM "AS IS" WITHOUT WARRANTY OF ANY KIND, EITHER EXPRESSED OR IMPLIED, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE. THE ENTIRE RISK AS TO THE QUALITY AND PERFORMANCE OF THE PROGRAM IS WITH YOU. SHOULD THE PROGRAM PROVE DEFECTIVE, YOU ASSUME THE COST OF ALL NECESSARY SERVICING, REPAIR OR CORRECTION. 10. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE THE PROGRAM AS PERMITTED ABOVE, BE LIABLE TO YOU FOR DAMAGES, INCLUDING ANY GENERAL, SPECIAL, INCIDENTAL OR CONSEQUENTIAL DAMAGES ARISING OUT OF THE USE OR INABILITY TO USE THE PROGRAM (INCLUDING BUT NOT LIMITED TO LOSS OF DATA OR DATA BEING RENDERED INACCURATE OR LOSSES SUSTAINED BY YOU OR THIRD PARTIES OR A FAILURE OF THE PROGRAM TO OPERATE WITH ANY OTHER PROGRAMS), EVEN IF SUCH HOLDER OR OTHER PARTY HAS BEEN ADVISED OF THE POSSIBILITY OF SUCH DAMAGES. END OF TERMS AND CONDITIONS Appendix: How to Apply These Terms to Your New Programs If you develop a new program, and you want it to be of the greatest possible use to humanity, the best way to achieve this is to make it free software which everyone can redistribute and change under these terms. To do so, attach the following notices to the program. It is safest to attach them to the start of each source file to most effectively convey the exclusion of warranty; and each file should have at least the "copyright" line and a pointer to where the full notice is found. Copyright (C) 19yy This program is free software; you can redistribute it and/or modify it under the terms of the GNU General Public License as published by the Free Software Foundation; either version 1, or (at your option) any later version. This program is distributed in the hope that it will be useful, but WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License for more details. You should have received a copy of the GNU General Public License along with this program; if not, write to the Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) 19xx name of author Gnomovision comes with ABSOLUTELY NO WARRANTY; for details type `show w'. This is free software, and you are welcome to redistribute it under certain conditions; type `show c' for details. The hypothetical commands `show w' and `show c' should show the appropriate parts of the General Public License. Of course, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (a program to direct compilers to make passes at assemblers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice That's all there is to it! --- The Artistic License 1.0 --- This software is Copyright (c) 2020 by Chad Granum. This is free software, licensed under: The Artistic License 1.0 The Artistic License Preamble The intent of this document is to state the conditions under which a Package may be copied, such that the Copyright Holder maintains some semblance of artistic control over the development of the package, while giving the users of the package the right to use and distribute the Package in a more-or-less customary fashion, plus the right to make reasonable modifications. Definitions: - "Package" refers to the collection of files distributed by the Copyright Holder, and derivatives of that collection of files created through textual modification. - "Standard Version" refers to such a Package if it has not been modified, or has been modified in accordance with the wishes of the Copyright Holder. - "Copyright Holder" is whoever is named in the copyright or copyrights for the package. - "You" is you, if you're thinking about copying or distributing this Package. - "Reasonable copying fee" is whatever you can justify on the basis of media cost, duplication charges, time of people involved, and so on. (You will not be required to justify it to the Copyright Holder, but only to the computing community at large as a market that must bear the fee.) - "Freely Available" means that no fee is charged for the item itself, though there may be fees involved in handling the item. It also means that recipients of the item may redistribute it under the same conditions they received it. 1. You may make and give away verbatim copies of the source form of the Standard Version of this Package without restriction, provided that you duplicate all of the original copyright notices and associated disclaimers. 2. You may apply bug fixes, portability fixes and other modifications derived from the Public Domain or from the Copyright Holder. A Package modified in such a way shall still be considered the Standard Version. 3. You may otherwise modify your copy of this Package in any way, provided that you insert a prominent notice in each changed file stating how and when you changed that file, and provided that you do at least ONE of the following: a) place your modifications in the Public Domain or otherwise make them Freely Available, such as by posting said modifications to Usenet or an equivalent medium, or placing the modifications on a major archive site such as ftp.uu.net, or by allowing the Copyright Holder to include your modifications in the Standard Version of the Package. b) use the modified Package only within your corporation or organization. c) rename any non-standard executables so the names do not conflict with standard executables, which must also be provided, and provide a separate manual page for each non-standard executable that clearly documents how it differs from the Standard Version. d) make other distribution arrangements with the Copyright Holder. 4. You may distribute the programs of this Package in object code or executable form, provided that you do at least ONE of the following: a) distribute a Standard Version of the executables and library files, together with instructions (in the manual page or equivalent) on where to get the Standard Version. b) accompany the distribution with the machine-readable source of the Package with your modifications. c) accompany any non-standard executables with their corresponding Standard Version executables, giving the non-standard executables non-standard names, and clearly documenting the differences in manual pages (or equivalent), together with instructions on where to get the Standard Version. d) make other distribution arrangements with the Copyright Holder. 5. You may charge a reasonable copying fee for any distribution of this Package. You may charge any fee you choose for support of this Package. You may not charge a fee for this Package itself. However, you may distribute this Package in aggregate with other (possibly commercial) programs as part of a larger (possibly commercial) software distribution provided that you do not advertise this Package as a product of your own. 6. The scripts and library files supplied as input to or produced as output from the programs of this Package do not automatically fall under the copyright of this Package, but belong to whomever generated them, and may be sold commercially, and may be aggregated with this Package. 7. C or perl subroutines supplied by you and linked into this Package shall not be considered part of this Package. 8. The name of the Copyright Holder may not be used to endorse or promote products derived from this software without specific prior written permission. 9. THIS PACKAGE IS PROVIDED "AS IS" AND WITHOUT ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, WITHOUT LIMITATION, THE IMPLIED WARRANTIES OF MERCHANTIBILITY AND FITNESS FOR A PARTICULAR PURPOSE. The End Test2-Suite-0.000129/README0000644000175000017500000002312313615053353014642 0ustar exodistexodistNAME Test2::Suite - Distribution with a rich set of tools built upon the Test2 framework. DESCRIPTION Rich set of tools, plugins, bundles, etc built upon the Test2 testing library. If you are interested in writing tests, this is the distribution for you. WHAT ARE TOOLS, PLUGINS, AND BUNDLES? TOOLS Tools are packages that export functions for use in test files. These functions typically generate events. Tools SHOULD NEVER alter behavior of other tools, or the system in general. 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 SHOULD NOT export anything. 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. 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. INCLUDED BUNDLES Test2::V# These do not live in the bundle namespace as they are the primary ways to use Test2::Suite. The current latest is 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 "INCLUDED TOOLS" section below, except for Test2::Tools::ClassicCompare. This bundle provides most of what anyone writing tests could need. This is also the preferred bundle/toolset of the Test2 author. See Test2::V0 for complete documentation. Extended ** Deprecated ** See 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 "INCLUDED TOOLS" section below, except for Test2::Tools::ClassicCompare. This bundle provides most of what anyone writing tests could need. This is also the preferred bundle/toolset of the Test2 author. See Test2::Bundle::Extended for complete documentation. 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 mostly drop-in replacement for Test::More. There are some notable differences to be aware of however. Some exports are missing: eq_array, eq_hash, eq_set, $TODO, explain, use_ok, require_ok. As well it is no longer possible to set the plan at import: use .. tests => 5. $TODO has been replaced by the todo() function. Planning is done using plan, skip_all, or done_testing. See Test2::Bundle::More for complete documentation. Simple use Test2::Bundle::Simple; use strict; use warnings; plan 1; ok(...); This bundle is meant to be a mostly drop-in replacement for Test::Simple. See Test2::Bundle::Simple for complete documentation. INCLUDED TOOLS Basic Basic provides most of the essential tools previously found in Test::More. However it does not export any tools used for comparison. The basic pass, fail, ok functions are present, as are functions for planning. See Test2::Tools::Basic for complete documentation. Compare This provides is, like, isnt, unlike, and several additional helpers. Note: These are all deep comparison tools and work like a combination of Test::More's is and is_deeply. See Test2::Tools::Compare for complete documentation. ClassicCompare This provides Test::More flavored is, like, isnt, unlike, and is_deeply. It also provides cmp_ok. See Test2::Tools::ClassicCompare for complete documentation. Class This provides functions for testing objects and classes, things like isa_ok. See Test2::Tools::Class for complete documentation. 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 Test2::Tools::Defer for complete documentation. Encoding This exports a single function that can be used to change the encoding of all your test output. See Test2::Tools::Encoding for complete documentation. Exports This provides tools for verifying exports. You can verify that functions have been imported, or that they have not been imported. See Test2::Tools::Exports for complete documentation. Mock This provides tools for mocking objects and classes. This is based largely on Mock::Quick, but several interface improvements have been added that cannot be added to Mock::Quick itself without breaking backwards compatibility. See Test2::Tools::Mock for complete documentation. Ref This exports tools for validating and comparing references. See Test2::Tools::Ref for complete documentation. Spec This is an RSPEC implementation with concurrency support. See Test2::Tools::Spec for more details. Subtest This exports tools for running subtests. See Test2::Tools::Subtest for complete documentation. Target This lets you load the package(s) you intend to test, and alias them into constants/package variables. See Test2::Tools::Target for complete documentation. INCLUDED PLUGINS 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 Test2::Plugin::BailOnFail for complete documentation. DieOnFail The much requested "die on first failure" plugin. When this plugin is loaded, any failure will cause the test to die immediately. See Test2::Plugin::DieOnFail for complete documentation. ExitSummary This plugin gives you statistics and diagnostics at the end of your test in the event of a failure. See Test2::Plugin::ExitSummary for complete documentation. SRand Use this to set the random seed to a specific seed, or to the current date. See Test2::Plugin::SRand for complete documentation. 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 Test2::Plugin::UTF8 for complete documentation. INCLUDED REQUIREMENT CHECKERS AuthorTesting Using this package will cause the test file to be skipped unless the AUTHOR_TESTING environment variable is set. See Test2::Require::AuthorTesting for complete documentation. EnvVar Using this package will cause the test file to be skipped unless a custom environment variable is set. See Test2::Require::EnvVar for complete documentation. Fork Using this package will cause the test file to be skipped unless the system is capable of forking (including emulated forking). See Test2::Require::Fork for complete documentation. RealFork Using this package will cause the test file to be skipped unless the system is capable of true forking. See Test2::Require::RealFork for complete documentation. 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 Test2::Require::Module for complete documentation. Perl Using this package will cause the test file to be skipped unless the specified minimum perl version is met. See Test2::Require::Perl for complete documentation. Threads Using this package will cause the test file to be skipped unless the system has threading enabled. Note: This will not turn threading on for you. See Test2::Require::Threads for complete documentation. SEE ALSO See the Test2 documentation for a namespace map. Everything in this distribution uses Test2. Test2::Manual is the Test2 Manual. CONTACTING US Many Test2 developers and users lurk on irc://irc.perl.org/#perl. We also have a slack team that can be joined by anyone with an @cpan.org email address https://perl-test2.slack.com/ If you do not have an @cpan.org email you can ask for a slack invite by emailing Chad Granum . SOURCE The source code repository for Test2-Suite can be found at https://github.com/Test-More/Test2-Suite/. MAINTAINERS Chad Granum AUTHORS Chad Granum COPYRIGHT Copyright 2018 Chad Granum . This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. See http://dev.perl.org/licenses/