cpan/Test-Simple/lib/Test2/Event/Bail.pm
cpan/Test-Simple/lib/Test2/Event/Diag.pm
cpan/Test-Simple/lib/Test2/Event/Exception.pm
+cpan/Test-Simple/lib/Test2/Event/Generic.pm
cpan/Test-Simple/lib/Test2/Event/Note.pm
cpan/Test-Simple/lib/Test2/Event/Ok.pm
cpan/Test-Simple/lib/Test2/Event/Plan.pm
cpan/Test-Simple/lib/Test/Tester.pm
cpan/Test-Simple/lib/Test/Tutorial.pod
cpan/Test-Simple/lib/Test/use/ok.pm
-cpan/Test-Simple/t/00compile.t
cpan/Test-Simple/t/Legacy/00test_harness_check.t
cpan/Test-Simple/t/Legacy/01-basic.t
cpan/Test-Simple/t/Legacy/478-cmp_ok_hash.t
cpan/Test-Simple/t/Test2/modules/Event/Bail.t
cpan/Test-Simple/t/Test2/modules/Event/Diag.t
cpan/Test-Simple/t/Test2/modules/Event/Exception.t
+cpan/Test-Simple/t/Test2/modules/Event/Generic.t
cpan/Test-Simple/t/Test2/modules/Event/Note.t
cpan/Test-Simple/t/Test2/modules/Event/Ok.t
cpan/Test-Simple/t/Test2/modules/Event/Plan.t
},
'Test::Simple' => {
- 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.001014.tar.gz',
+ 'DISTRIBUTION' => 'EXODIST/Test-Simple-1.302026.tar.gz',
'FILES' => q[cpan/Test-Simple],
'EXCLUDED' => [
qr{^t/xt},
qr{^xt},
qw( .perlcriticrc
.perltidyrc
+ perltidyrc
+ dist.ini
examples/indent.pl
examples/subtest.t
+ examples/tools.t
+ examples/tools.t
t/00compile.t
t/xxx-changes_updated.t
+ t/00-report.t
+ t/zzz-check-breaks.t
),
],
- # https://github.com/Test-More/test-more/issues/679
- CUSTOMIZED => [ 't/Test2/modules/API/Instance.t' ],
},
'Text::Abbrev' => {
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN {
if( $] < 5.008 ) {
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN { require Test2::Formatter::TAP; our @ISA = qw(Test2::Formatter::TAP) }
require Exporter;
our @ISA = qw(Exporter);
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
=head1 NAME
package Test::Builder::Tester;
use strict;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Test::Builder;
use Symbol;
package Test::Builder::Tester::Color;
use strict;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
require Test::Builder::Tester;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN { require Test2::Event::Diag; our @ISA = qw(Test2::Event::Diag) }
use all the usual CPAN testing modules. It is the best and most
perlish way to do xUnit style testing.
-L<Test::Unit> is a more direct port of XUnit to Perl, but it does not use
+L<Test::Unit> is a more direct port of xUnit to Perl, but it does not use
the Perl conventions and does not play well with other CPAN testing
modules. As of this writing, it is abandoned. B<Do not use>.
could tell her to run naked across campus with a powercord rammed
up her backside and she'd probably do it... Hmmm...
-There seems to be a Dummy Mode WRT testing. An otherwise competent
+There seems to be a Dummy Mode with respect to testing. An otherwise competent
person goes to write a test and they suddenly forget all basic
programming practice.
return warn @_, " at $file line $line\n";
}
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Test::Builder::Module;
our @ISA = qw(Test::Builder::Module);
use strict;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Test::Builder::Module;
our @ISA = qw(Test::Builder::Module);
use vars qw( @ISA @EXPORT );
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
@EXPORT = qw( run_tests check_tests check_test cmp_results show_space );
@ISA = qw( Exporter );
package Test::Tester::Capture;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Test::Builder;
package Test::Tester::CaptureRunner;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Test::Tester::Capture;
package Test::Tester::Delegate;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use vars '$AUTOLOAD';
package Test::use::ok;
use 5.005;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
__END__
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
1;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
my $INST;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Test2::Util qw/pkg_to_file/;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Carp qw/confess croak longmess/;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
our @CARP_NOT = qw/Test2::API Test2::API::Instance Test2::IPC::Driver Test2::Formatter/;
sub enable_ipc_polling {
my $self = shift;
+ $self->{+_PID} = $$ unless defined $self->{+_PID};
+ $self->{+_TID} = get_tid() unless defined $self->{+_TID};
+
$self->add_context_init_callback(
# This is called every time a context is created, it needs to be fast.
# $_[0] is a context object
return 1 if defined $self->{+IPC_SHM_ID};
+ $self->{+_PID} = $$ unless defined $self->{+_PID};
+ $self->{+_TID} = get_tid() unless defined $self->{+_TID};
+
my ($ok, $err) = try {
require IPC::SysV;
$new_exit = 255 if $new_exit > 255;
- if ($new_exit) {
- require Test2::API::Breakage;
+ if ($new_exit && eval { require Test2::API::Breakage; 1 }) {
my @warn = Test2::API::Breakage->report();
if (@warn) {
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Test2::Hub();
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Test2::Util::HashBase qw/trace nested in_subtest subtest_id/;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
--- /dev/null
+package Test2::Event::Generic;
+use strict;
+use warnings;
+
+use Carp qw/croak/;
+use Scalar::Util qw/reftype/;
+
+our $VERSION = '1.302026';
+
+BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
+use Test2::Util::HashBase;
+
+my @FIELDS = qw{
+ causes_fail increments_count diagnostics no_display callback terminate
+ global sets_plan summary
+};
+my %DEFAULTS = (
+ causes_fail => 0,
+ increments_count => 0,
+ diagnostics => 0,
+ no_display => 0,
+);
+
+sub init {
+ my $self = shift;
+
+ for my $field (@FIELDS) {
+ my $val = defined $self->{$field} ? delete $self->{$field} : $DEFAULTS{$field};
+ next unless defined $val;
+
+ my $set = "set_$field";
+ $self->$set($val);
+ }
+}
+
+for my $field (@FIELDS) {
+ no strict 'refs';
+ my $stash = \%{__PACKAGE__ . "::"};
+
+ *$field = sub { exists $_[0]->{$field} ? $_[0]->{$field} : () }
+ unless defined $stash->{$field}
+ && defined *{$stash->{$field}}{CODE};
+
+ *{"set_$field"} = sub { $_[0]->{$field} = $_[1] }
+ unless defined $stash->{"set_$field"}
+ && defined *{$stash->{"set_$field"}}{CODE};
+}
+
+sub summary {
+ my $self = shift;
+ return $self->{summary} if defined $self->{summary};
+ $self->SUPER::summary();
+}
+
+sub sets_plan {
+ my $self = shift;
+ return unless $self->{sets_plan};
+ return @{$self->{sets_plan}};
+}
+
+sub callback {
+ my $self = shift;
+ my $cb = $self->{callback} || return;
+ $self->$cb(@_);
+}
+
+sub set_global {
+ my $self = shift;
+ my ($bool) = @_;
+
+ if(!defined $bool) {
+ delete $self->{global};
+ return undef;
+ }
+
+ $self->{global} = $bool;
+}
+
+sub set_callback {
+ my $self = shift;
+ my ($cb) = @_;
+
+ if(!defined $cb) {
+ delete $self->{callback};
+ return undef;
+ }
+
+ croak "callback must be a code reference"
+ unless ref($cb) && reftype($cb) eq 'CODE';
+
+ $self->{callback} = $cb;
+}
+
+sub set_terminate {
+ my $self = shift;
+ my ($exit) = @_;
+
+ if(!defined $exit) {
+ delete $self->{terminate};
+ return undef;
+ }
+
+ croak "terminate must be a positive integer"
+ unless $exit =~ m/^\d+$/;
+
+ $self->{terminate} = $exit;
+}
+
+sub set_sets_plan {
+ my $self = shift;
+ my ($plan) = @_;
+
+ if(!defined $plan) {
+ delete $self->{sets_plan};
+ return undef;
+ }
+
+ croak "'sets_plan' must be an array reference"
+ unless ref($plan) && reftype($plan) eq 'ARRAY';
+
+ $self->{sets_plan} = $plan;
+}
+
+1;
+
+__END__
+
+=pod
+
+=encoding UTF-8
+
+=head1 NAME
+
+Test2::Event::Generic - Generic event type.
+
+=head1 DESCRIPTION
+
+This is a generic event that lets you customize all fields in the event API.
+This is useful if you have need for a custom event that does not make sense as
+a published reusable event subclass.
+
+=head1 SYNOPSIS
+
+ use Test2::API qw/context/;
+
+ sub send_custom_fail {
+ my $ctx = shift;
+
+ $ctx->send_event('Generic', causes_fail => 1, summary => 'The sky is falling');
+
+ $ctx->release;
+ }
+
+ send_custom_fail();
+
+=head1 METHODS
+
+=over 4
+
+=item $e->callback($hub)
+
+Call the custom callback if one is set, otherwise this does nothing.
+
+=item $e->set_callback(sub { ... })
+
+Set the custom callback. The custom callback must be a coderef. The first
+argument to your callback will be the event itself, the second will be the
+L<Test2::Event::Hub> that is using the callback.
+
+=item $bool = $e->causes_fail
+
+=item $e->set_causes_fail($bool)
+
+Get/Set the C<causes_fail> attribute. This defaults to C<0>.
+
+=item $bool = $e->diagnostics
+
+=item $e->set_diagnostics($bool)
+
+Get/Set the C<diagnostics> attribute. This defaults to C<0>.
+
+=item $bool_or_undef = $e->global
+
+=item @bool_or_empty = $e->global
+
+=item $e->set_global($bool_or_undef)
+
+Get/Set the C<diagnostics> attribute. This defaults to an empty list which is
+undef in scalar context.
+
+=item $bool = $e->increments_count
+
+=item $e->set_increments_count($bool)
+
+Get/Set the C<increments_count> attribute. This defaults to C<0>.
+
+=item $bool = $e->no_display
+
+=item $e->set_no_display($bool)
+
+Get/Set the C<no_display> attribute. This defaults to C<0>.
+
+=item @plan = $e->sets_plan
+
+Get the plan if this event sets one. The plan is a list of up to 3 items:
+C<($count, $directive, $reason)>. C<$count> must be defined, the others may be
+undef, or may not exist at all.
+
+=item $e->set_sets_plan(\@plan)
+
+Set the plan. You must pass in an arrayref with up to 3 elements.
+
+=item $summary = $e->summary
+
+=item $e->set_summary($summary_or_undef)
+
+Get/Set the summary. This will default to the event package
+C<'Test2::Event::Generic'>. You can set it to any value. Setting this to
+C<undef> will reset it to the default.
+
+=item $int_or_undef = $e->terminate
+
+=item @int_or_empty = $e->terminate
+
+=item $e->set_terminate($int_or_undef)
+
+This will get/set the C<terminate> attribute. This defaults to undef in scalar
+context, or an empty list in list context. Setting this to undef will clear it
+completely. This must be set to a positive integer (0 or larger).
+
+=back
+
+=head1 SOURCE
+
+The source code repository for Test2 can be found at
+F<http://github.com/Test-More/test-more/>.
+
+=head1 MAINTAINERS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 AUTHORS
+
+=over 4
+
+=item Chad Granum E<lt>exodist@cpan.orgE<gt>
+
+=back
+
+=head1 COPYRIGHT
+
+Copyright 2016 Chad Granum E<lt>exodist@cpan.orgE<gt>.
+
+This program is free software; you can redistribute it and/or
+modify it under the same terms as Perl itself.
+
+See F<http://dev.perl.org/licenses/>
+
+=cut
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN { require Test2::Event::Ok; our @ISA = qw(Test2::Event::Ok) }
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN { require Test2::Event; our @ISA = qw(Test2::Event) }
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
my %ADDED;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Test2::Util::HashBase qw{
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Carp qw/carp croak confess/;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Test2::Hub::Interceptor::Terminator();
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
1;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN { require Test2::Hub; our @ISA = qw(Test2::Hub) }
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Test2::API::Instance;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Carp qw/confess longmess/;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
BEGIN { require Test2::IPC::Driver; our @ISA = qw(Test2::IPC::Driver) }
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Config qw/%Config/;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Carp qw/croak/;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
require Carp;
use strict;
use warnings;
-our $VERSION = '1.302022';
+our $VERSION = '1.302026';
use Test2::Util qw/get_tid/;
package ok;
-$ok::VERSION = '1.302022';
+$ok::VERSION = '1.302026';
use strict;
use Test::More ();
+++ /dev/null
-#!/usr/bin/perl -w
-
-BEGIN {
- if( $ENV{PERL_CORE} ) {
- @INC = ('../lib', 'lib');
- }
- else {
- unshift @INC, 't/lib';
- }
-}
-chdir 't';
-
-use Test::More;
-
-my $Has_Test_Pod;
-BEGIN {
- $Has_Test_Pod = eval 'use Test::Pod 0.95; 1';
-}
-
-chdir "..";
-my $manifest = "MANIFEST";
-open(my $manifest_fh, "<", $manifest) or plan(skip_all => "Can't open $manifest: $!");
-my @modules = map { m{^lib/(\S+)}; $1 }
- grep { m{^lib/Test/\S*\.pm} }
- grep { !m{/t/} } <$manifest_fh>;
-
-chomp @modules;
-close $manifest_fh;
-
-chdir 'lib';
-plan tests => scalar @modules * 2;
-foreach my $file (@modules) {
- # Make sure we look at the local files and do not reload them if
- # they're already loaded. This avoids recompilation warnings.
- local @INC = @INC;
- unshift @INC, ".";
- my @warnings;
- ok eval {
- local $SIG{__WARN__} = sub { push @warnings => @_ };
- require($file);
- 1
- } or diag "require $file failed.", "\n", @warnings, "\n", $@;
-
- SKIP: {
- skip "Test::Pod not installed", 1 unless $Has_Test_Pod;
- pod_file_ok($file);
- }
-}
use Test2::Util qw/CAN_THREAD/;
BEGIN {
unless(CAN_THREAD) {
- require Test::More;
- Test::More->import(skip_all => "threads are not supported");
+ print "1..0 # Skip threads are not supported.\n";
+ exit 0;
}
}
+
+BEGIN {
+ unless ( $ENV{AUTHOR_TESTING} ) {
+ print "1..0 # Skip many perls have broken threads. Enable with AUTHOR_TESTING.\n";
+ exit 0;
+ }
+}
+
+use Test2::IPC;
use threads;
use Test::More;
BEGIN { require "t/tools.pl" };
use Test2::Util qw/CAN_THREAD CAN_REALLY_FORK USE_THREADS get_tid/;
-skip_all("Leaks shm blocks");
-
my $CLASS = 'Test2::API::Instance';
my $one = $CLASS->new;
{
$one->reset;
+
ok(!@{$one->context_init_callbacks}, "no callbacks");
is($one->ipc_polling, undef, "no polling, undef");
use warnings;
$one->enable_ipc_polling;
+ ok(defined($one->{_pid}), "pid is defined");
+ ok(defined($one->{_tid}), "tid is defined");
is(@{$one->context_init_callbacks}, 1, "added the callback");
is($one->ipc_polling, 1, "polling on");
$one->set_ipc_shm_last('abc1');
--- /dev/null
+use strict;
+use warnings;
+
+BEGIN { require "t/tools.pl" };
+use Test2::Util::Trace;
+
+use Test2::API qw/context intercept/;
+
+sub tool {
+ my $ctx = context();
+ my $e = $ctx->send_event('Generic', @_);
+ $ctx->release;
+ return $e;
+}
+
+my $e;
+intercept { $e = tool() };
+
+ok($e, "got event");
+ok($e->isa('Test2::Event'), "It is an event");
+ok($e->isa('Test2::Event::Generic'), "It is an event");
+delete $e->{trace};
+is_deeply(
+ $e,
+ {
+ causes_fail => 0,
+ increments_count => 0,
+ diagnostics => 0,
+ no_display => 0,
+ },
+ "Defaults"
+);
+
+for my $f (qw/causes_fail increments_count diagnostics no_display/) {
+ is($e->$f, 0, "'$f' is 0");
+ is_deeply([$e->$f], [0], "'$f' is 0 is list context as well");
+
+ my $set = "set_$f";
+ $e->$set(1);
+ is($e->$f, 1, "'$f' was set to 1");
+}
+
+for my $f (qw/callback terminate global sets_plan/) {
+ is($e->$f, undef, "no $f");
+ is_deeply([$e->$f], [], "$f is empty in list context");
+}
+
+like($e->summary, qr/Test2::Event::Generic/, "Got base class summary");
+
+like(
+ exception { $e->set_sets_plan('bad') },
+ qr/'sets_plan' must be an array reference/,
+ "Must provide an arrayref"
+);
+
+$e->set_sets_plan([0, skip => 'cause']);
+is_deeply([$e->sets_plan], [0, skip => 'cause'], "sets_plan returns a list, not a ref");
+$e->set_sets_plan(undef);
+ok(!exists $e->{sets_plan}, "Removed sets_plan key");
+ok(!$e->sets_plan, "sets_plan is cleared");
+
+$e->set_global(0);
+is($e->global, 0, "global is off");
+$e->set_global(1);
+is($e->global, 1, "global is on");
+$e->set_global(0);
+is($e->global, 0, "global is again");
+$e->set_global(undef);
+ok(!exists $e->{global}, "removed global key");
+is($e->global, undef, "global is not defined");
+
+like(
+ exception { $e->set_callback('dogfood') },
+ qr/callback must be a code reference/,
+ "Callback must be code"
+);
+
+my $ran = 0;
+$e->set_callback(sub {
+ $ran++;
+ my $self = shift;
+ is($self, $e, "got self");
+ is_deeply( \@_, ['a', 'b', 'c'], "Got args" );
+ return 'foo';
+});
+is($e->callback('a', 'b', 'c'), 'foo', "got callback's return");
+ok($ran, "ran callback");
+
+$e->set_callback(undef);
+ok(!$e->callback, "no callback");
+ok(!exists $e->{callback}, "no callback key");
+
+like(
+ exception { $e->set_terminate('1.1') },
+ qr/terminate must be a positive integer/,
+ "terminate only takes integers"
+);
+
+like(
+ exception { $e->set_terminate('foo') },
+ qr/terminate must be a positive integer/,
+ "terminate only takes numbers"
+);
+
+like(
+ exception { $e->set_terminate('-1') },
+ qr/terminate must be a positive integer/,
+ "terminate only takes positive integers"
+);
+
+$e->set_terminate(0),
+is($e->terminate, 0, "set to 0, 0 is valid");
+$e->set_terminate(1),
+is($e->terminate, 1, "set to 1");
+$e->set_terminate(123),
+is($e->terminate, 123, "set to 123");
+$e->set_terminate(0),
+is($e->terminate, 0, "set to 0, 0 is valid");
+
+$e->set_terminate(undef);
+is($e->terminate, undef, "terminate is not defined");
+ok(!exists $e->{terminate}, "no terminate key");
+
+# Test constructor args
+intercept { $e = tool(causes_fail => 1, increments_count => 'a') };
+is($e->causes_fail, 1, "attr from constructor");
+is($e->increments_count, 'a', "attr from constructor");
+
+done_testing;