Test-Effects-0.001005/000755 000765 000765 00000000000 12405450751 013622 5ustar00damian000000 000000 Test-Effects-0.001005/Changes000644 000765 000765 00000001360 12405450730 015112 0ustar00damian000000 000000 Revision history for Test-Effects 0.000001 Wed Mar 14 06:32:40 2012 Initial release. 0.000005 Thu May 10 12:32:17 2012 - Added TIME => 1 and timing => $SPEC - Included missing file (sorry Swen!) 0.000007 Thu May 10 14:40:10 2012 No changes logged 0.001000 Wed Jul 18 14:00:00 2012 First public release 0.001002 Thu Feb 21 13:21:42 2013 - Fixed minor bug in checking string return values 0.001003 Fri Jul 26 13:09:23 2013 - Fixed 5.18 madness 0.001004 Sat May 3 10:03:21 2014 - Patched to avoid experimental warnings under 5.19+ 0.001005 Mon Sep 15 12:41:28 2014 - Doc patch to overcome stupid limitations on module descriptions under =head1 NAME (thanks Gordon) Test-Effects-0.001005/lib/000755 000765 000765 00000000000 12405450750 014367 5ustar00damian000000 000000 Test-Effects-0.001005/Makefile.PL000644 000765 000765 00000001040 11743447746 015605 0ustar00damian000000 000000 use strict; use warnings; use ExtUtils::MakeMaker; use 5.014; WriteMakefile( NAME => 'Test::Effects', AUTHOR => 'Damian Conway ', LICENSE => 'perl', VERSION_FROM => 'lib/Test/Effects.pm', ABSTRACT_FROM => 'lib/Test/Effects.pm', PL_FILES => {}, PREREQ_PM => { 'Test::Trap' => 0.002001, }, dist => { COMPRESS => 'gzip -9f', SUFFIX => 'gz', }, clean => { FILES => 'Test-Effects-*' }, ); Test-Effects-0.001005/MANIFEST000644 000765 000765 00000001156 12405450751 014756 0ustar00damian000000 000000 Changes MANIFEST Makefile.PL README lib/Test/Effects.pm lib/Test/Effects/ONLY.pm lib/Test/Effects/VERBOSE.pm lib/Test/Effects/TIME.pm t/00.load.t t/ONLY_scoped.t t/ONLY_sub.t t/VERBOSE_ONLY_subs.t t/VERBOSE_scoped.t t/VERBOSE_sub.t t/WITHOUT_dir.t t/WITHOUT_dir_pat.t t/WITHOUT_module.t t/WITHOUT_module_pat.t t/basic.t t/expected_string.t t/import_minimal.t t/import_more.t t/only.t t/verbose.t t/ONLY_VERBOSE_TIME.t t/TIME_scoped.t t/TIME_sub.t t/diagnostics.t t/time.t t/timing.t t/lib/Test/Effects/Module1.pm t/lib/Test/Effects/Module2.pm META.yml Module meta-data (added by MakeMaker) Test-Effects-0.001005/META.yml000644 000765 000765 00000001132 12405450751 015070 0ustar00damian000000 000000 --- #YAML:1.0 name: Test-Effects version: 0.001005 abstract: Test all effects at once (return value, I/O, warnings, exceptions, etc.) author: - Damian Conway license: perl distribution_type: module configure_requires: ExtUtils::MakeMaker: 0 build_requires: ExtUtils::MakeMaker: 0 requires: Test::Trap: 0.002001 no_index: directory: - t - inc generated_by: ExtUtils::MakeMaker version 6.57_05 meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 Test-Effects-0.001005/README000644 000765 000765 00000001276 12405450730 014505 0ustar00damian000000 000000 Test::Effects version 0.001005 Test::Effects provides a single exported subroutine: effects_ok(); This sub expects a code block to execute, followed by a hash that specifies which side-effects of that code shoudl be tested (and how). The module can test everything that Test::Trap does, as well as timing information, but provides a much more convenient interface for specifying those tests. INSTALLATION To install this module, run the following commands: perl Makefile.PL make make test make install DEPENDENCIES None. COPYRIGHT AND LICENCE Copyright (C) 2012, Damian Conway This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself. Test-Effects-0.001005/t/000755 000765 000765 00000000000 12405450750 014064 5ustar00damian000000 000000 Test-Effects-0.001005/t/00.load.t000644 000765 000765 00000000302 11743445327 015411 0ustar00damian000000 000000 use Test::More tests => 1; BEGIN { use_ok( 'Test::Effects' ) or BAIL_OUT q{Test::Effects did not load successfully}; } diag( "Testing Test::Effects $Test::Effects::VERSION" ); Test-Effects-0.001005/t/basic.t000644 000765 000765 00000000470 11746251744 015344 0ustar00damian000000 000000 use Test::Effects; plan tests => 1; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'Basic features work'; Test-Effects-0.001005/t/diagnostics.t000644 000765 000765 00000001101 11752714104 016551 0ustar00damian000000 000000 use Test::Effects; plan tests => 2; effects_ok { effects_ok { die "Shouldn't happen" } 'Not a spec' => 'Bad spec'; } ONLY { die => qr/\A\QSecond argument to effects_ok() must be hash or hash reference, not scalar value at\E/, } => 'Bad effects_ok() specification diagnostic'; effects_ok { effects_ok { die "Shouldn't happen" } { timing => 'all' } => 'Bad spec'; } ONLY { die => qr/\A\QInvalid timing specification: timing => 'all'\E/, } => 'Bad timing specification diagnostic'; done_testing(); Test-Effects-0.001005/t/expected_string.t000644 000765 000765 00000000262 12111301306 017422 0ustar00damian000000 000000 use Test::Effects; plan tests => 1; $SIG{__WARN__} = sub { die @_; }; effects_ok { return 'a string'; } { return => 'a string', } => 'String checking works silently'; Test-Effects-0.001005/t/import_minimal.t000644 000765 000765 00000000547 11743447054 017306 0ustar00damian000000 000000 use Test::Effects tests => 1, import => [':minimal']; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; VERBOSE({}); } { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\AUndefined subroutine &main::VERBOSE called}, } => 'import minimal works'; Test-Effects-0.001005/t/import_more.t000644 000765 000765 00000000554 11743447066 016623 0ustar00damian000000 000000 use Test::Effects tests => 1, import => [':more']; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; ok 1; VERBOSE({}); } { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\AUndefined subroutine &main::VERBOSE called}, } => 'import more works'; Test-Effects-0.001005/t/lib/000755 000765 000765 00000000000 12405450750 014632 5ustar00damian000000 000000 Test-Effects-0.001005/t/only.t000644 000765 000765 00000000512 11743447105 015234 0ustar00damian000000 000000 use Test::Effects; plan tests => 1; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, ONLY => 1, } => 'ONLY in hash works'; Test-Effects-0.001005/t/ONLY_scoped.t000644 000765 000765 00000002451 11743446705 016402 0ustar00damian000000 000000 use Test::Effects; plan tests => 4; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } VERBOSE { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'Not in scope'; { use Test::Effects::ONLY; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } VERBOSE { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'In scope'; no Test::Effects::ONLY; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } VERBOSE { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'In scope (after no)'; } effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } VERBOSE { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'Back out of scope'; Test-Effects-0.001005/t/ONLY_sub.t000644 000765 000765 00000000470 11743446731 015714 0ustar00damian000000 000000 use Test::Effects; plan tests => 1; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } ONLY { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'ONLY works'; Test-Effects-0.001005/t/ONLY_VERBOSE_TIME.t000644 000765 000765 00000000534 11746253074 017046 0ustar00damian000000 000000 use Test::Effects; plan tests => 1; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } ONLY VERBOSE TIME { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'ONLY VERBOSE TIME features work'; Test-Effects-0.001005/t/time.t000644 000765 000765 00000002603 11752714110 015205 0ustar00damian000000 000000 use Test::Effects; # How long we're going to test timing for... my $sleepy_time = 0.25; # Use a +/- 10% margin of error... my ($min, $max) = ($sleepy_time * 0.9, $sleepy_time * 1.1); # Short sleep... sub nap { my $time = shift; select undef, undef, undef, $time; return $time; } # Select a random testing context... my @contexts = ( [ void_return => undef ], [ scalar_return => $sleepy_time ], [ list_return => [$sleepy_time] ], ); sub select_random_context { return @{ $contexts[rand @contexts] } } # The various possible test specifications... my %timing_spec = ( 'empty hash' => {}, 'empty array' => [], 'number' => $max, 'array' => [$min, $max], 'hash min' => { min => $min }, 'hash max' => { max => $max }, 'hash min/max' => { min => $min, max => $max }, ); # How many tests in total??? plan tests => 2 * keys %timing_spec; # Run them all... for my $test (keys %timing_spec) { # Test quietly... effects_ok { nap $sleepy_time } TIME { select_random_context(), } => "Didn't oversleep: $test"; # Test verbosely... effects_ok { nap $sleepy_time } VERBOSE { TIME => 1, select_random_context(), } => "Didn't oversleep: $test"; } done_testing(); Test-Effects-0.001005/t/TIME_scoped.t000644 000765 000765 00000002562 11752714072 016355 0ustar00damian000000 000000 use Test::Effects; plan tests => 4; effects_ok { sleep 1; print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } VERBOSE { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'Not in scope'; { use Test::Effects::TIME; effects_ok { sleep 1; print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } VERBOSE { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'In scope'; no Test::Effects::TIME; effects_ok { sleep 1; print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } VERBOSE { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'In scope (after no)'; } effects_ok { sleep 1; print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } VERBOSE { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'Back out of scope'; done_testing(); Test-Effects-0.001005/t/TIME_sub.t000644 000765 000765 00000000505 11747570252 015670 0ustar00damian000000 000000 use Test::Effects; plan tests => 1; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; sleep 1; warn 'warning'; die 'died'; } TIME { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'TIME works'; Test-Effects-0.001005/t/timing.t000644 000765 000765 00000003075 11752714236 015553 0ustar00damian000000 000000 use Test::Effects; # How long we're going to test timing for... my $sleepy_time = 0.1; # Use a +/- 34% margin of error... my ($min, $max) = ($sleepy_time * 0.6, $sleepy_time * 1.4); # Short sleep... sub nap { my $time = shift; select undef, undef, undef, $time; return $time; } # Select a random testing context... my @contexts = ( [ void_return => undef ], [ scalar_return => $sleepy_time ], [ list_return => [$sleepy_time] ], ); # The various possible test specifications... my %timing_spec = ( 'empty hash' => {}, 'empty array' => [], 'number' => $max, 'array' => [$min, $max], 'hash min' => { min => $min }, 'hash max' => { max => $max }, 'hash min/max' => { min => $min, max => $max }, ); # How many tests in total??? plan -e '.developer' ? (tests => 2 * keys(%timing_spec) * @contexts ) : (skip_all => 'Developer test only' ); # Run them all... for my $context (@contexts) { for my $test (keys %timing_spec) { # Test quietly... effects_ok { nap $sleepy_time } { timing => $timing_spec{$test}, @$context, } => "Didn't oversleep: $test under $context->[0] "; # Test verbosely... effects_ok { nap $sleepy_time } VERBOSE { timing => $timing_spec{$test}, @$context, } => "Didn't oversleep: $test under $context->[0]"; } } done_testing(); Test-Effects-0.001005/t/verbose.t000644 000765 000765 00000000516 11743447470 015731 0ustar00damian000000 000000 use Test::Effects; plan tests => 1; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, VERBOSE => 1, } => 'VERBOSE in hash works'; Test-Effects-0.001005/t/VERBOSE_ONLY_subs.t000644 000765 000765 00000000461 11743446754 017271 0ustar00damian000000 000000 use Test::Effects; plan tests => 1; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } VERBOSE ONLY { stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'VERBOSE ONLY works'; Test-Effects-0.001005/t/VERBOSE_scoped.t000644 000765 000765 00000002417 11743447013 016721 0ustar00damian000000 000000 use Test::Effects; plan tests => 4; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'Not in scope'; { use Test::Effects::VERBOSE; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'In scope'; no Test::Effects::VERBOSE; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'In scope (after no)'; } effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'Back out of scope'; Test-Effects-0.001005/t/VERBOSE_sub.t000644 000765 000765 00000000474 11743447025 016241 0ustar00damian000000 000000 use Test::Effects; plan tests => 1; effects_ok { print 'stdout'; say {*STDERR} 'stderr'; warn 'warning'; die 'died'; } VERBOSE { stdout => "stdout", stderr => qr{stderr\nwarning \s+ at}x, warn => [qr{\A warning \s+ at}x], die => qr{\A died \s+ at}x, } => 'VERBOSE works'; Test-Effects-0.001005/t/WITHOUT_dir.t000644 000765 000765 00000000633 11752714100 016250 0ustar00damian000000 000000 use Test::Effects; use lib 't/lib'; plan tests => 2; effects_ok { require Test::Effects::Module1; 1; } { VERBOSE => 1, } => 'with dir works'; effects_ok { require Test::Effects::Module2; 1; } { scalar_return => sub { (shift//0) != 1 }, die => qr{\ACan't locate Test/Effects/Module2.pm in \@INC}, VERBOSE => 1, WITHOUT => 't/lib/', } => 'WITHOUT dir works'; Test-Effects-0.001005/t/WITHOUT_dir_pat.t000644 000765 000765 00000000460 11743444467 017132 0ustar00damian000000 000000 use Test::Effects; plan tests => 1; effects_ok { require Test::Effects::VERBOSE; 1; } { scalar_return => sub { (shift//0) != 1 }, die => qr{\ACan't locate Test/Effects/VERBOSE.pm in \@INC}, VERBOSE => 1, WITHOUT => qr{lib (?# / )}x, } => 'WITHOUT dir pat works'; Test-Effects-0.001005/t/WITHOUT_module.t000644 000765 000765 00000000465 11743444471 016775 0ustar00damian000000 000000 use Test::Effects; plan tests => 1; effects_ok { require Test::Effects::VERBOSE; 1; } { scalar_return => sub { (shift//0) != 1 }, die => qr{\ACan't locate Test/Effects/VERBOSE.pm in \@INC}, VERBOSE => 1, WITHOUT => 'Test::Effects::VERBOSE', } => 'WITHOUT module works'; Test-Effects-0.001005/t/WITHOUT_module_pat.t000644 000765 000765 00000000463 11743444475 017643 0ustar00damian000000 000000 use Test::Effects; plan tests => 1; effects_ok { require Test::Effects::VERBOSE; 1; } { scalar_return => sub { (shift//0) != 1 }, die => qr{\ACan't locate Test/Effects/VERBOSE.pm in \@INC}, VERBOSE => 1, WITHOUT => qr{Test::Effects::.*}, } => 'WITHOUT module works'; Test-Effects-0.001005/t/lib/Test/000755 000765 000765 00000000000 12405450750 015551 5ustar00damian000000 000000 Test-Effects-0.001005/t/lib/Test/Effects/000755 000765 000765 00000000000 12405450750 017130 5ustar00damian000000 000000 Test-Effects-0.001005/t/lib/Test/Effects/Module1.pm000644 000765 000765 00000000424 11746240753 021003 0ustar00damian000000 000000 package Test::Effects::Module1; use warnings; use strict; use autodie; use 5.010; our $VERSION = '0.000001'; # Module implementation here 1; # Magic true value required at end of module __END__ =head1 NAME Test::Effects::Module1 - Dummy module to test WITHOUT feature Test-Effects-0.001005/t/lib/Test/Effects/Module2.pm000644 000765 000765 00000000424 11746241005 020773 0ustar00damian000000 000000 package Test::Effects::Module2; use warnings; use strict; use autodie; use 5.010; our $VERSION = '0.000001'; # Module implementation here 1; # Magic true value required at end of module __END__ =head1 NAME Test::Effects::Module2 - Dummy module to test WITHOUT feature Test-Effects-0.001005/lib/Test/000755 000765 000765 00000000000 12405450750 015306 5ustar00damian000000 000000 Test-Effects-0.001005/lib/Test/Effects/000755 000765 000765 00000000000 12405450750 016665 5ustar00damian000000 000000 Test-Effects-0.001005/lib/Test/Effects.pm000644 000765 000765 00000105727 12405450730 017235 0ustar00damian000000 000000 package Test::Effects; use warnings; no if $] >= 5.018, 'warnings', "experimental::smartmatch"; use strict; use 5.014; our $VERSION = '0.001005'; use Test::More; use Test::Trap; use base 'Test::Builder::Module'; # Export the modules interface (and that of Test::More)... our @EXPORT = ( qw( effects_ok ), qw( ONLY VERBOSE TIME ), @Test::More::EXPORT, ); our @EXPORT_OK = ( @Test::More::Export_OK, ); our %EXPORT_TAGS = ( 'minimal' => [ 'effects_ok' ], 'more' => [ 'effects_ok', @Test::More::EXPORT], ); # Magic number tells Test::More how many stack levels to go up when reporting errors # (Unfortunately, this depends on the internals of Test::More) # [TODO: Send a patch for Test::More that autoskips a named class when reporting] my $LEVEL_OFFSET = 6; my $LEVEL_OFFSET_NESTED = 2 * $LEVEL_OFFSET + 1; # Adjust tests used in the module to account for nesting... sub _subtest { my ($desc) = @_; # Report problems as being in the appropriate place... local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET; &subtest(@_); } sub _fail { # Report problems as being in the appropriate place... local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET_NESTED; &fail(@_); } use Scalar::Util 'looks_like_number'; sub is_num { Test::Effects->builder->is_num(@_) } sub _is_or_like { my ($got, $expected, $desc) = @_; # Report problems as being in the appropriate place... local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET_NESTED; given (ref $expected) { when ('CODE') { no warnings; my $ok = \&Test::Builder::ok; local *Test::Builder::ok = sub { $_[2] = $desc unless defined $_[2]; $ok->(@_); }; ok($expected->($got, $desc), $desc); } when ('Regexp') { &like(@_); } when (looks_like_number($expected)) { &is_num(@_); } default { &is(@_); } } } sub _is_deeply { my ($got, $expected, $desc) = @_; # Report problems as being in the appropriate place... local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET_NESTED; given (ref $expected) { when ('CODE') { no warnings; my $ok = \&Test::Builder::ok; local *Test::Builder::ok = sub { $_[2] = $desc unless defined $_[2]; $ok->(@_); }; ok($expected->($got, $desc), $desc); } default { &is_deeply(@_) } } } sub _is_like_or_deeply { my ($got, $expected, $desc) = @_; # Report problems as being in the appropriate place... local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET_NESTED; given (ref $expected) { when ('CODE') { no warnings; my $ok = \&Test::Builder::ok; local *Test::Builder::ok = sub { $_[2] = $desc unless defined $_[2]; $ok->(@_); }; ok($expected->($got, $desc), $desc); } when ('Regexp') { my $got_val = ref($got) eq 'ARRAY' && @{$got} == 1 ? $got->[0] : $got; like($got_val, $expected, $desc); } when (q{}) { if (looks_like_number($expected)) { &is_num(@_) } else { &is(@_) } } default { &is_deeply(@_) } } } sub _is_like_or_list { my ($got, $expected, $desc) = @_; # Report problems as being in the appropriate place... local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET_NESTED; given (ref $expected) { when ('CODE') { no warnings; my $ok = \&Test::Builder::ok; local *Test::Builder::ok = sub { $_[2] = $desc unless defined $_[2]; $ok->(@_); }; ok($expected->($got, $desc), $desc); } when ('Regexp') { my $got_val = ref($got) eq 'ARRAY' && @{$got} == 1 ? $got->[0] : $got; like($got_val, $expected, $desc); } when (q{} && looks_like_number($expected)) { &is_num(@_); } when (q{}) { &is(@_); } when (q{ARRAY}) { for my $n (0..$#{$expected}) { _is_or_like($got->[$n], $expected->[$n], "$desc [warning $n]"); } } default { &is_deeply(@_) } } } # Utility sub: dump values... sub _explain { use Data::Dumper 'Dumper'; local $Data::Dumper::Terse = 1; local $Data::Dumper::Indent = 0; return Dumper(shift) =~ s/\s+/ /gr =~ s/\s+$//gr; } # Utility subs: build subs that append the right verb, when requested.... sub _was_were_sub { my ($desc) = @_; return sub { my (undef, $was_were) = @_; return $desc if !$was_were; return "$desc was"; }; } sub _was_were_warn_sub { return sub { my ($expected, $was_were) = @_; my $count = eval{ @{$expected} } // 1; return $count == 1 ? 'warning' . ($was_were ? ' was' : q{}) : 'warnings' . ($was_were ? ' were' : q{}); } } # Utility sub: load carp() and croak() only on demand... sub _croak { if (eval{ require Carp }) { Carp::croak(@_); } else { die @_; } } # Module is largely table-driven (from these tables)... my (%TEST_FOR, %NULL_VALUE_FOR, %BAD_NULL_VALUE_FOR, %DESCRIBE); BEGIN { %TEST_FOR = ( 'stdout' => \&_is_or_like, 'stderr' => \&_is_or_like, 'warn' => \&_is_like_or_list, 'die' => \&_is_or_like, 'exit' => \&_is_or_like, ); %NULL_VALUE_FOR = ( 'stdout' => q{}, 'stderr' => q{}, 'warn' => [], 'die' => undef, 'exit' => undef, ); %BAD_NULL_VALUE_FOR = ( 'stdout' => undef, 'stderr' => undef, 'warn' => undef, 'die' => q{}, 'exit' => q{}, ); %DESCRIBE = ( 'stdout' => _was_were_sub( 'output to STDOUT' ), 'stderr' => _was_were_sub( 'output to STDERR' ), 'warn' => _was_were_warn_sub(), 'die' => _was_were_sub( 'exception' ), 'exit' => _was_were_sub( 'call to exit()' ), ); } # Make a copy of a hash with an appropriate flag added... sub ONLY (+) { return { ONLY => 1, %{shift()} } } sub VERBOSE (+) { return { VERBOSE => 1, %{shift()} } } sub TIME (+) { return { TIME => 1, %{shift()} } } my $MS_THRESHHOLD = 0.1; # seconds (anything less reported in ms) # Test all trapped info, as requested... sub effects_ok (&;+$) { my ($block, $expected, $desc) = @_; my $expected_ref = ref $expected; # Handle case where hash is missing, but description isn't... if (@_ == 2 && !$expected_ref) { $desc = "$expected"; $expected = undef; } # Expectations are passed in a hash... $expected //= {}; if (ref($expected) ne 'HASH') { _croak 'Second argument to effects_ok() must be hash or hash reference, not ' . lc(ref($expected) || 'scalar value'); } # If there's a timing request, the value has to make sense... my $timing; if (exists $expected->{'timing'}) { my $spec = $expected->{'timing'}; my $valid_time = ref($spec) =~ m{ \A (?: HASH | ARRAY ) \Z}xms || !ref($spec) && looks_like_number($spec); if (!$valid_time) { _croak("Invalid timing specification: timing => '$spec'"); } } # Get lexical hints... my %lexical_hint = %{ (caller 0)[10] // {} }; # Fill in default tests, unless requested not to... my $is_only = exists $expected->{'ONLY'} ? $expected->{'ONLY'} : $lexical_hint{'Test::Effects::ONLY'}; # Time the test, if requested my $timed_test = exists $expected->{'TIME'} ? $expected->{'TIME'} : $lexical_hint{'Test::Effects::TIME'}; if (!$is_only) { my $warn = $expected->{'warn'}; $expected = { %NULL_VALUE_FOR, 'stderr' => (ref $warn eq 'ARRAY' ? join(q{}, @{$warn}) : $warn), %{$expected}, }; } # Correct common mispecifications... for my $option (keys %BAD_NULL_VALUE_FOR) { next if !exists $expected->{$option}; if ($expected->{$option} ~~ $BAD_NULL_VALUE_FOR{$option}) { $expected->{$option} = $NULL_VALUE_FOR{$option}; } } # Ensure there's a description... $desc //= sprintf "Testing effects_ok() at %s line %d", (caller)[1,2]; # Are we echoing this test??? my $is_terse = exists $expected->{'VERBOSE'} ? !$expected->{'VERBOSE'} : !$lexical_hint{'Test::Effects::VERBOSE'}; # Show the description... my $preview_desc = !$is_terse || exists $expected->{'timing'}; if ($preview_desc) { note '_' x (3 + length $desc); note exists $expected->{'timing'} ? "$desc (being timed)..." : "$desc..."; } # Redirect test output, so we can retrospectively de-terse on errors... my $tests_output; given (Test::Builder->new()) { $_->output(\$tests_output); $_->failure_output(\$tests_output); $_->todo_output(\$tests_output); } # Preview description under terse too, in case of failures... if (!$preview_desc) { note '_' x (3 + length $desc); note "$desc..."; } # Are we WITHOUT any modules in this test??? my @real_INC = @INC; local @INC = @INC; local %INC = %INC; if (exists $expected->{'WITHOUT'}) { my $without_list = $expected->{'WITHOUT'}; # Normalize list... if (ref $without_list ne 'ARRAY') { $without_list = [ $without_list ]; } # Translate list to filepaths... for my $module_name ( @{$without_list} ) { # Classify the argument... my $is_pattern = ref $module_name eq 'Regexp'; my $is_libpath = $module_name =~ m{/}; # Modules get translated to paths... if (!$is_libpath) { if (not $module_name =~ s{::}{/}gxms) { diag "WARNING: ambiguous WITHOUT => " . ($is_pattern ? "qr{$module_name}" : "'$module_name'") . "\ntreated as module name (not library path)" . "\n(use " . ($is_pattern ? "qr{::$module_name}" : "'::$module_name'") . " or " . ($is_pattern ? "qr{$module_name/}" : "'$module_name/'") . " to silence this warning)"; } if (!$is_pattern) { $module_name .= '.pm'; } else { $module_name = qr{$module_name}; } } # Libpaths winnow @INC directly... elsif (!$is_pattern && $is_libpath) { $module_name =~ s{/\Z}{}xms; if ($module_name =~ m{\A /}x) { @INC = grep { !m{\A $module_name /? \Z}x } @INC; } else { @INC = grep { !m{\A (?: [.]/ )? $module_name /? \Z}x } @INC; } } else { # Pattern spec for libpath @INC = grep { !m{$module_name} } @INC; } # Libpaths then don't need to be checked with @INC... if ($is_libpath) { $module_name = undef; } } # Put an interceptor sub at the start of @INC... unshift @INC, sub { my ($self, $target) = @_; # If what you're looking for is WITHOUT'd, pretend to fail... if ($target ~~ $without_list || "/$target" ~~ $without_list) { _croak "Can't locate $target in \@INC (\@INC contains: @real_INC)"; } return; }; } # Test in a subtest... my $failed = _subtest $desc => sub { # Find the specified return value (if any)... my @return_specs = grep /return/, keys %{$expected}; if (@return_specs > 1) { _fail "Ambiguous specification for testing of return value."; diag "ERROR: Found request for " . scalar(@return_specs), " mutually exclusive tests:\n", " {\n", (map { " '$_' => " . _explain($expected->{$_}) . ",\n" } @return_specs), " }\n", " Call to effects_ok() terminated without testing anything."; return; } # Infer context, if necessary... if (exists $expected->{'return'}) { given (ref $expected->{'return'}) { when ('ARRAY') { $expected->{'list_return'} = delete $expected->{'return'} } default { $expected->{'scalar_return'} = delete $expected->{'return'} } } } # Call the block and test the return value in the appropriate context... # 1. Explicit void context... if (exists $expected->{'void_return'}) { if (defined $expected->{'void_return'}) { note "WARNING: Meaningless option {void_return => '$expected->{void_return}'} ignored.\n" . " To silence this warning, either remove the option entirely\n" . " or replace it with: {void_return => undef})"; } if ($timed_test) { _time_calls_to($block, $timed_test => $timing); } else { trap { $block->() }; } pass 'Tested in void context, so ignored return value' } # 2. Explicit scalar context... elsif (exists $expected->{'scalar_return'}) { my $return_val = do { if ($timed_test) { _time_calls_to($block, $timed_test => $timing); } else { trap { $block->() }; } }; _is_like_or_deeply $return_val, $expected->{'scalar_return'} => 'Scalar context return value was as expected'; } # 3. Explicit list context... elsif (exists $expected->{'list_return'}) { my @return_vals = do { if ($timed_test) { _time_calls_to($block, $timed_test => $timing); } else { trap { $block->() }; } }; _is_deeply \@return_vals, $expected->{'list_return'} => 'List context return value was as expected'; } # 4. Implied void context... else { if ($timed_test) { _time_calls_to($block, $timed_test => $timing); } else { trap { $block->() }; } pass 'No return value specified, so tested in void context'; } # Test side-effects... for my $info (qw< stdout stderr warn die exit>) { if (exists $expected->{$info}) { no strict 'refs'; my $desc = $expected->{$info} ~~ $NULL_VALUE_FOR{$info} ? 'No ' . $DESCRIBE{$info}->($expected->{$info}) . ' (as expected)' : ucfirst $DESCRIBE{$info}->($expected->{$info},'was') . ' as expected'; $TEST_FOR{$info}->($trap->$info, $expected->{$info}, $desc); } } # Do timing, if requested... if (exists $expected->{'timing'}) { # Work out the parameters... my $time_spec = $expected->{'timing'}; my $spec_type = ref $time_spec; my $min = $spec_type eq 'HASH' ? $time_spec->{'min'} // 0 : $spec_type eq 'ARRAY' ? $time_spec->[0] // 0 : 0; state $INF = 0 + 'inf'; my $max = $spec_type eq 'HASH' ? $time_spec->{'max'} // $INF : $spec_type eq 'ARRAY' ? $time_spec->[-1] // $INF : 0+$time_spec; # Run the test... my $duration = _time_calls_to($block); # Compute a handy alternate measure of performance... my $speed = $duration ? 1/$duration : 0; $speed = $speed > 1 ? sprintf('(%1.0lf/sec)', $speed) : $speed > 0 ? sprintf('(%0.4g/sec)', $speed) : '(unmeasurably fast)'; # Was the result acceptable??? my $in_range = $min <= $duration && $duration <= $max; # Report outcome... ok $in_range => $duration > $MS_THRESHHOLD ? sprintf('Ran in %0.3f sec %s', $duration, $speed) : sprintf('Ran in %dms %s', 1000*$duration, $speed); # Clean up report... if (!$in_range) { $tests_output =~ s{\N*\n\N*\n\z}{}xms; } # Report any problems (as being in the appropriate place)... local $Test::Builder::Level = $Test::Builder::Level + $LEVEL_OFFSET_NESTED - 1; if (!$in_range) { diag sprintf " Expected to run in: $min to $max sec", $min, $max; } } }; # Clean up... my $builder = Test::Builder->new; $builder->reset_outputs; # Report outcomes... my $passed = ($builder->summary)[-1]; # If passed in terse mode, just print the summary (i.e. last line)... if ( $is_terse && $passed ) { $tests_output =~ s{ .* \n (?= .*\n )}{}xms; } # Otherwise print the probems... elsif ( $is_terse ) { $tests_output =~ s{^ \s*+ (?! not | [#] ) [^\n]* \n}{}gxms; } # Add the timing info, if requested... if ($timed_test) { $tests_output =~ s{^ ( (?:not|ok) \s \N*) }{$1\t$timing}xms; } print {$builder->output} $tests_output; return $passed; } BEGIN { eval{ require Time::HiRes and Time::HiRes->import('time') } } sub _time_calls_to { my ($block, $time_one_call) = @_; state $MAX_CPU_TIME = 1; state $MIN_CREDIBLE_UTILIZATION = 0.1; my ($cpu_time, $wall_time) = (0,0); my $count = 0; my (@start, @end); my $wantarray = wantarray; my (@result, $result); while (1) { if ($time_one_call && $wantarray) { @start = (time, times); @result = trap { $block->() }; @end = (time, times); } elsif ($time_one_call && defined $wantarray) { @start = (time, times); $result = trap { $block->() }; @end = (time, times); } else { @start = (time, times); trap { $block->() }; @end = (time, times); } $wall_time += $end[0] - $start[0]; $cpu_time += $end[$_] - $start[$_] for 1..4; $count++; last if $cpu_time > $MAX_CPU_TIME || $wall_time > 2 * $MAX_CPU_TIME || $time_one_call; } my $utilization = $cpu_time / ($wall_time||1); my $timing = !$cpu_time || $utilization < $MIN_CREDIBLE_UTILIZATION ? $wall_time / $count : $cpu_time / $count; if ($time_one_call) { if ($timing < $MS_THRESHHOLD) { $_[2] = '[' . int($timing * 1000) . 'ms]'; } else { $_[2] = sprintf '[%0.2lf sec]', $timing; } return $wantarray ? @result : $result; } else { return $timing; } } 1; # Magic true value required at end of module __END__ =head1 NAME Test::Effects - Test all effects at once (return value, I/O, warnings, exceptions, etc.) =head1 VERSION This document describes Test::Effects version 0.001005 =head1 SYNOPSIS =for test-synopsis my $expected_scalar_context_return_value; my @expected_list_context_return_values; use Test::Effects; # Test all possible detectable side-effects of some code... effects_ok { your_code_here() } { return => $expected_scalar_context_return_value, warn => qr/match expected warning text/, stdout => '', # i.e. Doesn't print anything. } => 'Description of test'; # Test only specifically requested side-effects of some code... effects_ok { your_code_here() } ONLY { return => \@expected_list_context_return_values, stderr => 'Expected output to STDERR', die => undef, # i.e. Doesn't die. exit => undef, # i.e. Doesn't exit either. } => 'Description of test'; # Test that some code has no detectable side-effects... effects_ok { your_code_here() }; =head1 DESCRIPTION Test::Effects provides a single exported subroutine: C This sub expects a block of code (or sub ref) as its first argument, followed by an optional hash ref as its second, and an optional string as its third. The first argument specifies some code to be tested. This code is run in void context by default, but may instead be called in either list or scalar context, depending on the test specification provided by the second argument. The block is run within a call to C, so all warnings, exceptions, output, and exit attempts are trapped. The block may contain calls to other Test::Builder-based testing modules; these are handled correctly within the overall test. The second argument is a hash reference, whose entries specify the expected side-effects of executing the block. You specify the name of the side-effect you're interested in as the key, and the "effect" you expected as the value. Side-effects that are not explicitly specified are automatically tested for default behaviour (e.g. no warnings, no exceptions, no output, not call to C, etc. If the entire hash is omitted, all possible side-effects are tested for default behaviour (in other words, did the block of code have I side-effects whatsoever?) The third argument is the overall description of the test (i.e. the usual final argument for Perl tests). If omitted, C generates a description based on the line number at which it was called. =head1 INTERFACE =head2 C Loads the module, and exports the C, C, C, and C subroutines (see below). Also exports the standard interface from the Test::More module. =head2 C<< use Test::Effects tests => $N; >> Exactly the same as: use Test::More tests => $N; In fact, S> can take all the same arguments as S>. =head2 C<< use Test::Effects import => [':minimal']; >> Only export the C subroutine. Do not export C, C, C, or any of the Test::More interface. =head2 C<< use Test::Effects import => [':more']; >> Only export the C subroutine and the Test::More interface Do not export C, C, or C. =head2 C<< effects_ok {BLOCK} {EFFECTS_HASH} => 'TEST_DESCRIPTION'; >> Test the code in the block, ensuring that the side-effects named by the keys of the hash match the corresponding hash values. Both the hash and the description arguments are optional. The effects that can be specified as key/value pairs in the hash are: =over =item C<< void_return => undef >> Call the block in void context. =item C<< return => $ARRAY_REFERENCE >> =item C<< list_return => $ANY_SCALAR_VALUE >> Call the block in list context. The final value evaluated in the block should (deeply) match the specified array ref or scalar value of the option. =item C<< return => $NON_ARRAYREF >> =item C<< scalar_return => $ANY_SCALAR_VALUE >> Call the block in scalar context. The final value evaluated in block should match the specified scalar value of the option. =item C<< stdout => $STRING >> What the block wrote to C should be C to $STRING. =item C<< stdout => $REGEX >> What the block wrote to C should be match $REGEX. =item C<< stdout => $CODE_REF >> The subroutine specified by the code ref should return true when passed what the block wrote to C. The subroutine can call nested tests (such as Test::More's C) or Test::Tolerant's C) and these will be correctly handled. =item C<< stderr => $STRING >> =item C<< stderr => $REGEX >> =item C<< stderr => $CODE_REF >> What the block writes to C should "match" the specified value (either C, or C<=~>, or return true when passed as an argument). Note that, if this option is not specified, but the C<'warn'> option (see below) I specified, then this option defaults to the value of the C<'warn'> option. =item C<< warn => $STRING >> =item C<< warn => $REGEX >> =item C<< warn => $CODE_REF >> =item C<< warn => [ $STRING1, $REGEX2, $CODE_REF3, $ETC ] >> The block should issue the specified number of warnings, and each of these warnings should match the corresponding value specified, in the order specified. =item C<< die => $STRING >> =item C<< die => $REGEX >> =item C<< die => $CODE_REF >> The block should raise an exception, which should match the value specified. Note: when using OO exceptions, use a code ref to test them: die => sub { shift->isa('X::BadData') } You can also use Test::More-ish tests, if you prefer: die => sub { isa_ok(shift, 'X::BadData') } =item C<< exit => $NUMBER >> =item C<< exit => $REGEX >> =item C<< exit => $CODE_REF >> The block should call C and the exit code should match the value specified. =item C<< timing => { min => $MIN_SEC, max => $MAX_SEC } >> =item C<< timing => [$MIN_SEC, $MAX_SEC] >> =item C<< timing => $MAX_SEC >> This option performs a separate timing measurment for the block, by running it multiple times over at least 1 cpu-second and averaging the times required for each run (i.e. like the Benchmark module does). When passed a hash reference, the C<'min'> and C<'max'> entries specify the range of allowable timings (in seconds) for the block. For example: # Test our new snooze() function... effects_ok { snooze(1.5, plus_or_minus=>0.2); } { timing => { min => 1.3, max => 1.7 }, } => 'snooze() slept about the right amount of time'; The default for C<'min'> is zero seconds; the default for C<'max'> is eternity. If you use an array reference instead of a hash reference, the first value in the array is taken as the minimum time, and the final value is taken as the maximum allowed time. Hence the above time specification could also be written: timing => [ 1.3, 1.7 ], But don't write: timing => [ 1.3 .. 1.7 ], (unless your limits are integers), because Perl truncates the bounds of a range, so it treats C<[1.3 .. 1.7]> as C<[1 .. 1]>. If you use a number instead of a reference, then number is taken as the maximum time allowed: timing => 3.2, # Same as: timing => { min => 0, max => 3.2 } If you do not specify either time limit: timing => {}, or: timing => [], then the "zero-to-eternity" defaults are used and C simply times the block and reports the timing (as a success). Note that the timings measured using this option are considerably more accurate than those produced by the C<< TIME => 1 >> option (see below), but also take significantly longer to measure. =back Other configuration options that can be specified as key/value pairs in the hash are: =over =item C<< VERBOSE => $BOOLEAN >> If the value is true, all side-effect tests are reported individually (running them in a subtest). When this option is false (or omitted) only the overall result, plus any individual failures, are reported. =item C<< ONLY => $BOOLEAN >> If the value is true, only the effects explicitly requested by the other keys of this hash are tested for. In other words, this option causes C to omit the "default" tests for unnamed side-effects. When this option is false (or omitted) unspecified options are tested for their expected default behaviour. =item C<< TIME => $BOOLEAN >> If the value is true, the block is timed as it is executed. The timing is reported in the final TAP line. Note that this option is entirely independent of the C<'timing'> option (which times the block repeatedly and then tests it against specified limits). In contrast, the C<'TIME'> option merely times the block once, while it is being evaluated for the other tests. This is much less accurate, but also much faster and much less intrusive, when you merely want an rough indication of performance. =item C<< WITHOUT => 'Module::Name' >> =item C<< WITHOUT => qr/Module::.*/ >> Execute the block as if the specified module (or all modules matching the specified pattern) were not installed. =item C<< WITHOUT => 'lib/path/' >> =item C<< WITHOUT => qr{lib/*} >> Execute the block as if the specified library directory (or all directories matching the specified pattern) were not accessible. The specified patch I include at least one slash (C), otherwise it will be interpreted as a module name (see above). You can always add a redundant slash at the end of the path, if necessary: WITHOUT => 'lib', # Test without the C module WITHOUT => 'lib/', # Test without the C directory =back =head2 C<< VERBOSE I<$HASH_REF> >> A call to: effects_ok { BLOCK } VERBOSE { return => 0, stdout => 'ok' } is just a shorthand for: effects_ok { BLOCK } { return => 0, stdout => 'ok', VERBOSE => 1 } =head2 C<< ONLY I<$HASH_REF> >> A call such as: effects_ok { BLOCK } ONLY { return => 0, stdout => 'ok' } is just a shorthand for: effects_ok { BLOCK } { return => 0, stdout => 'ok', ONLY => 1 } =head2 C<< TIME I<$HASH_REF> >> A call such as: effects_ok { BLOCK } TIME { return => 0, stdout => 'ok' } is just a shorthand for: effects_ok { BLOCK } { return => 0, stdout => 'ok', TIME => 1 } Note that the C, C, and C