Test-Spec-0.51/000755 000765 000024 00000000000 12555501370 014406 5ustar00andyjonesstaff000000 000000 Test-Spec-0.51/.travis.yml000644 000765 000024 00000000142 12501367077 016521 0ustar00andyjonesstaff000000 000000 language: perl perl: - "5.20" - "5.18" - "5.16" - "5.14" - "5.12" - "5.10" - "5.8" Test-Spec-0.51/Changes000644 000765 000024 00000007257 12555500572 015717 0ustar00andyjonesstaff000000 000000 Revision history for Perl extension Test::Spec. 0.51 Mon Jul 27 20:05:00 BST 2015 - Fixed top level describe blocks running out of order Contributed by @mla (issue #28) 0.50 Sun Apr 19 18:13:00 BST 2015 - Removed several memory leaks Reported by @JRaspass (issue #24) - any_number() no longer fails if it is never called Contributed by @ptolemarch and @cavemanpi (issue #25) 0.49 Sun Jan 18 12:56:00 EST 2015 - Added with_deep Contributed by Andy Jones (issue #21) - Documented memory leak in stub() Reported by Victor Efimov (issue #14) - Added Travis CI info Contributed by Andy Jones (issue #23) - Fixed mock() example documentation Reported by Victor Efimov (issue #15) Contributed by Andy Jones (issue #22) 0.48 Tue Jan 06 22:52:00 EST 2015 - Testing fixes for Alpha branch of Test::More Contributed by Chad Granum (issue #18) - Metadata fixes Contributed by Graham Knop (issue #19) 0.47 Fri Oct 11 01:22:00 EDT 2012 - added repository metadata for CPAN Contributed by David Steinbrunner (issue #13) 0.46 Tue Oct 2 13:23:00 EDT 2012 - with() enables argument matching on mocked methods - raises() makes mocked methods raise exceptions Contributed by Kjell-Magne Øierud (issue #12) 0.45 Mon May 7 10:08:13 EDT 2012 - Add support for TAP version 13. Contributed by Michael G. Schwern (issue #11) 0.44 Mon Apr 30 11:04:00 CST 2012 - Allow shared_examples_for to be defined in any context. 0.43 Sat Apr 14 16:22:00 EST 2012 - Fixed runtests() to honor its contract to run only the examples specified in its @patterns parameter or SPEC environment variable. 0.42 Mon Mar 05 21:18:00 CST 2012 - Added context() and xcontext() aliases for describe/xdescribe (reported by intrigeri) 0.41 Sat Mar 03 19:04:00 EST 2012 - Added license info to Makefile.PL (RT #75400) - Fixed test suite problems on Windows 0.40 Mon Jan 30 18:38:00 EST 2012 - Fixed problem that caused Test::Spec usage errors (e.g. 'describe "foo";' without a subroutine argument) to be reported from inside the library, instead of the caller's perspective where the actual error is. 0.39 Wed Aug 31 00:52:00 EST 2011 - Added xit/xthey/xdescribe to mark TODO tests, inspired by the Jasmine JavaScript framework. Contributed by Marian Schubert (issue #10). 0.38 Sat Jul 09 23:16:00 EST 2011 - Added share() function to facilitate spec refactoring. 0.37 Thu Jul 07 13:55:00 EST 2011 - Fixed bug where shared examples defined in one package could not be used in another package. 0.36 Tue Jul 05 18:23:00 EST 2011 - Improved reporting of errors using spec_helper. - Minor documentation formatting fixes 0.35 Wed Jun 29 16:52:00 UTC 2011 - Fixed test suite for Windows environments. 0.34 - Added spec_helper utility function to load helper scripts relative to the spec. 0.33 Mon Jun 13 15:03:03 UTC 2011 - Added shared_examples_for/it_should_behave_like to allow factorization of tests. 0.32 Thu Jun 9 16:09:55 UTC 2011 - Fixed a problem with the tests that occurred only when Package::Stash::XS was not installed (issue #8). 0.31 - "use Test::Spec" now enables strict and warnings in the calling scope to lessen boilerplate code in specs. Contributed by Marian Schubert (issues #2, #3, #4, #7) - 6x speed improvement by removing Moose (test suite went from 8.33s to 1.25s). - Diagnostics improvements (issue #5) 0.30 Fri Jun 3 04:55:54 2011 - Examples that die will now display the error message even when run through a harness like prove(1). 0.29 Thu May 19 18:49:00 2011 - Quell annoying Test::Deep::isa() warnings. 0.28 Thu May 19 11:15:58 2011 - Extracted from ICA::Test::Spec Test-Spec-0.51/lib/000755 000765 000024 00000000000 12555501370 015154 5ustar00andyjonesstaff000000 000000 Test-Spec-0.51/Makefile.PL000644 000765 000024 00000003064 12501367077 016370 0ustar00andyjonesstaff000000 000000 use 5.008005; use ExtUtils::MakeMaker; # See lib/ExtUtils/MakeMaker.pm for details of how to influence # the contents of the Makefile that is written. my %MM_ARGS = ( NAME => 'Test::Spec', VERSION_FROM => 'lib/Test/Spec.pm', # finds $VERSION PREREQ_PM => { 'Carp' => 0, 'Exporter' => 0, 'List::Util' => 0, 'Package::Stash' => 0.23, 'Scalar::Util' => 1.11, 'Test::Deep' => 0.103, # earlier versions clash with UNIVERSAL::isa 'Test::More' => 0.88, 'Test::Trap' => 0, 'Tie::IxHash' => 0, 'constant' => 0, }, TEST_REQUIRES => { 'TAP::Parser' => 0, }, ABSTRACT_FROM => 'lib/Test/Spec.pm', # retrieve abstract from module AUTHOR => 'Philip Garrett ', LICENSE => 'perl', META_MERGE => { 'meta-spec' => { version => 2.0 }, resources => { repository => { type => 'git', web => 'https://github.com/kingpong/perl-Test-Spec', url => 'https://github.com/kingpong/perl-Test-Spec', }, bugtracker => { web => 'https://github.com/kingpong/perl-Test-Spec/issues', }, }, }, ); $MM_ARGS{BUILD_REQUIRES} = {%{$MM_ARGS{BUILD_REQUIRES}}, %{delete $MM_ARGS{TEST_REQUIRES}}} if $eumm_version < 6.63_03; $MM_ARGS{PREREQ_PM} = {%{$MM_ARGS{PREREQ_PM}}, %{delete $MM_ARGS{BUILD_REQUIRES}}} if $eumm_version < 6.55_01; WriteMakefile(%MM_ARGS); Test-Spec-0.51/MANIFEST000644 000765 000024 00000001536 12555501370 015544 0ustar00andyjonesstaff000000 000000 .travis.yml Changes lib/Test/Spec.pm lib/Test/Spec/Context.pm lib/Test/Spec/Example.pm lib/Test/Spec/Mocks.pm lib/Test/Spec/SharedHash.pm lib/Test/Spec/TodoExample.pm Makefile.PL MANIFEST README.md t/another_shared_examples_spec.pl t/auto_inherit.t t/data_sharing.t t/define.t t/disabled.t t/disabled_spec.pl t/dying_spec.pl t/empty.t t/helper_test.pl t/import_strict.t t/import_warnings.t t/mocks.t t/mocks_imports.t t/ordering.t t/perl_warning_spec.pl t/predictable_destroy.pl t/predictable_destroy_spec.t t/runtests_subset.t t/shared_examples.t t/shared_examples_spec.pl t/show_exceptions.t t/spec_helper.t t/strict_violating_spec.pl t/subset_spec.pl t/test_helper.pl t/uncompilable_spec.pl META.yml Module YAML meta-data (added by MakeMaker) META.json Module JSON meta-data (added by MakeMaker) Test-Spec-0.51/META.json000644 000765 000024 00000001577 12555501370 016041 0ustar00andyjonesstaff000000 000000 { "abstract" : "Write tests in a declarative specification style", "author" : [ "Philip Garrett " ], "dynamic_config" : 1, "generated_by" : "ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630", "license" : [ "perl_5" ], "meta-spec" : { "url" : "http://search.cpan.org/perldoc?CPAN::Meta::Spec", "version" : "2" }, "name" : "Test-Spec", "no_index" : { "directory" : [ "t", "inc" ] }, "release_status" : "stable", "resources" : { "bugtracker" : { "web" : "https://github.com/kingpong/perl-Test-Spec/issues" }, "repository" : { "type" : "git", "url" : "https://github.com/kingpong/perl-Test-Spec", "web" : "https://github.com/kingpong/perl-Test-Spec" } }, "version" : "0.51" } Test-Spec-0.51/META.yml000644 000765 000024 00000001064 12555501370 015660 0ustar00andyjonesstaff000000 000000 --- abstract: 'Write tests in a declarative specification style' author: - 'Philip Garrett ' build_requires: {} dynamic_config: 1 generated_by: 'ExtUtils::MakeMaker version 6.6302, CPAN::Meta::Converter version 2.120630' license: perl meta-spec: url: http://module-build.sourceforge.net/META-spec-v1.4.html version: 1.4 name: Test-Spec no_index: directory: - t - inc resources: bugtracker: https://github.com/kingpong/perl-Test-Spec/issues repository: https://github.com/kingpong/perl-Test-Spec version: 0.51 Test-Spec-0.51/README.md000644 000765 000024 00000003025 12501367077 015672 0ustar00andyjonesstaff000000 000000 Test::Spec ![Travis CI Build Status](https://travis-ci.org/kingpong/perl-Test-Spec.svg?branch=master) ========== Test::Spec is a declarative specification‐style testing system for behavior‐ driven development (BDD) in Perl. The tests (a.k.a. examples) are named with strings instead of subroutine names, so your fingers will suffer less fatigue from underscore−itis, with the side benefit that the test reports are more legible. This module is inspired by and borrows heavily from RSpec (http://rspec.info/documentation/), a BDD tool for the Ruby programming language. See `perldoc Test::Spec` for syntax examples and usage information. Installation ------------ To install this module type the following: perl Makefile.PL make make test make install Dependencies ------------ This module requires these other modules and libraries: * constant * List::Util * Package::Stash (>= 0.23) * Scalar::Util (XS version) * TAP::Parser * Test::Deep (>= 0.103) * Test::More * Test::Trap * Tie::IxHash Author ------ Philip Garrett Source Code ----------- The source code for Test::Spec lives at github: https://github.com/kingpong/perl-Test-Spec Copyright and License --------------------- Copyright (c) 2011 by Informatics Corporation of America. Copyright (c) 2015 by Philip Garrett. This library is free software; you can redistribute it and/or modify it under the same terms as Perl itself, either Perl version 5.8.8 or, at your option, any later version of Perl 5 you may have available. Test-Spec-0.51/t/000755 000765 000024 00000000000 12555501370 014651 5ustar00andyjonesstaff000000 000000 Test-Spec-0.51/t/another_shared_examples_spec.pl000755 000765 000024 00000001510 12501367077 023111 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # another_shared_examples_spec.pl # # Test cases for Test::Spec shared example definition and inclusion. # # This spec requires a shared example group that is expected to already # have been defined in shared_examples_spec.pl. # ######################################################################## # package Testcase::Spec::AnotherSharedExamplesSpec; use Test::Spec; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; spec_helper 'shared_examples_spec.pl'; describe "A context in a second spec importing an example group defined in another package" => sub { it_should_behave_like "example group"; # it "can take at least one example"; # it "can take more than one example"; # describe "with an inner block" => # it "nests properly"; # it "can be reopened"; }; runtests unless caller; Test-Spec-0.51/t/auto_inherit.t000755 000765 000024 00000000604 12501367077 017540 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # auto_inherit.t # ######################################################################## # package Testcase::Spec::AutoInherit; use Test::Spec; describe "Test::Spec" => sub { it "should insert itself into the inheritance chain of any package that imports it" => sub { ok( Testcase::Spec::AutoInherit->isa('Test::Spec') ); }; }; runtests unless caller; Test-Spec-0.51/t/data_sharing.t000755 000765 000024 00000002305 12501367077 017472 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # stash.t # # Test cases for context stash. # ######################################################################## # package Testcase::Spec::Stash; use strict; use warnings; use Test::Spec; describe "An example group" => sub { share my %stash; $stash{outside} = "outside"; $stash{inside} = "outside"; # expected to be overridden before all => sub { $stash{inside} .= 'inside'; # overrides earlier }; before each => sub { $stash{each1} = 'each1'; }; before each => sub { $stash{each2} = 'each2'; }; my %expected = ( outside => 'outside', inside => 'outsideinside', each1 => 'each1', each2 => 'each2', ); it "should set up the stash properly" => sub { is_deeply({ %stash }, \%expected); }; describe "within an example group" => sub { it "should get the same stash as its parents" => sub { is_deeply({ %stash }, { %expected, each3 => 'each3' }); }; before each => sub { $stash{each3} = 'each3'; }; share my %second; it "should have the same data in every shared hash" => sub { $second{key} = 'value'; is_deeply({ %second }, { %stash }); }; }; }; runtests unless caller; Test-Spec-0.51/t/define.t000755 000765 000024 00000006600 12501367077 016302 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # define.t # # Test cases for Test::Spec definitions # ######################################################################## # package Testcase::Spec::Define; use strict; use warnings; use Test::More tests => 18; # builds a hash of "parent name" => { "child name" => ... } sub build_context_tree { my $node = shift; my $tree = shift || {}; for my $ctx ($node->contexts) { build_context_tree($ctx, $tree->{$ctx->name} = {}); } return $tree; } { package Stub; sub new { bless do { \my $stub }, shift() } sub AUTOLOAD { shift } } my ($outer,$inner) = (0,0); my ($before_all,$before_each) = (0,0); my ($after_all,$after_each) = (0,0); my ($ctx_in_desc, $ctx_in_before, $ctx_in_after); my $enter_leave_state = undef; my ($on_enter,$on_leave) = (0,0); { package A; use Test::Spec; # imports use base qw(Test::Spec); describe "Outer 1" => sub { $outer++; $ctx_in_desc = A->current_context; before all => sub { $before_all++; $ctx_in_before = A->current_context; }; before each => sub { $before_each++; }; it "runs outer test 1" => sub { ok(1, "ran outer test 1") }; describe "Inner 1" => sub { $inner++; A->current_context->on_enter(sub { $enter_leave_state = 'ENTER'; $on_enter++; }); A->current_context->on_leave(sub { $enter_leave_state = 'LEAVE' if $enter_leave_state eq 'ENTER'; $on_leave++; }); it "runs inner test 1" => sub { ok(1) }; }; after each => sub { $after_each++; $ctx_in_after = A->current_context; }; after all => sub { $after_all++; }; }; context "Outer 1" => sub { $outer++; context "Inner 1" => sub { $inner++; }; context "Inner 2" => sub { }; }; # tests describe "Outer 2" => sub { }; } is( $outer, 2, "both outer blocks ran"); is( $inner, 2, "both inner blocks ran"); my $tree = build_context_tree('A'); is_deeply( $tree, { "Outer 1" => { "Inner 1" => {}, "Inner 2" => {} }, "Outer 2" => {}, }, "contexts shallow-merged"); is( $before_all, 0, "before-all not run during definition" ); is( $before_each, 0, "before-all not run during definition" ); is( $after_each, 0, "after-each not run during definition" ); is( $after_all, 0, "after-all not run during definition" ); ok( $on_enter > 0, "enter block called"); is( $on_enter, $on_leave, "entered and left symmetrically" ); is( A->phase, Test::Spec::DEFINITION_PHASE, "definition phase" ); { if ($INC{'Test/Stream.pm'}) { Test::Stream->intercept(sub { A->runtests }); } else { no warnings 'once'; my $stub = Stub->new; local *A::builder = sub { $stub }; local *Test::More::builder = sub { $stub }; A->runtests; } } is( A->phase, Test::Spec::EXECUTION_PHASE, "execution phase" ); is( $ctx_in_desc, $ctx_in_before, "describe() and before() contexts are the same (for hooks, esp. mocks)"); is( $ctx_in_desc, $ctx_in_after, "describe() and after() contexts are the same (for hooks, esp. mocks)"); is( $outer, 2, "describe blocks did not re-run"); is( $before_all, 1, "before-all ran once before all tests" ); is( $before_each, 2, "before-each ran before each test"); is( $after_each, 2, "after-each ran after each test"); TODO: { local $TODO = "after-all untestable without changes to Spec.pm"; is($after_all, 1, "after-all ran once after all tests" ); } Test-Spec-0.51/t/disabled.t000755 000765 000024 00000002153 12501367077 016616 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # disabled.t # # Test cases for disabled specs (xit, xdescribe, xthey). # Executes disabled_spec.pl and validates its TAP output. # ######################################################################## # use strict; use warnings; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; use Test::More; my @results = parse_tap("disabled_spec.pl"); my %passing = map { $_->description => $_ } grep { $_->is_test } @results; sub test_passed { my $desc = shift; my $testdesc = "- $desc"; ok($passing{$testdesc}, $desc); } sub test_todo { my $desc = shift; my $testdesc = "- $desc"; ok($passing{$testdesc} && $passing{$testdesc}->directive eq 'TODO', $desc); } test_todo('Test::Spec disabled spec should not execute "it" examples'); test_todo('Test::Spec disabled spec should not execute "they" examples'); test_todo('Test::Spec should not execute disabled "it" example'); test_todo('Test::Spec should not execute disabled "they" example'); test_passed('Test::Spec should execute enabled "it" example'); test_passed('Test::Spec should execute enabled "they" example'); done_testing(); Test-Spec-0.51/t/disabled_spec.pl000755 000765 000024 00000001601 12501367077 017775 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # disabled.t # # Disabled specs. # ######################################################################## # package Testcase::Spec::Disabled; use Test::Spec; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; describe 'Test::Spec' => sub { xdescribe 'disabled spec' => sub { it 'should not execute "it" examples' => sub { fail; }; they 'should not execute "they" examples' => sub { fail; }; }; xcontext "disabled spec 2" => sub { it 'should not execute "it" examples' => sub { fail; }; }; xit 'should not execute disabled "it" example' => sub { fail; }; xthey 'should not execute disabled "they" example' => sub { fail; }; it 'should execute enabled "it" example' => sub { pass; }; they 'should execute enabled "they" example' => sub { pass; }; }; runtests unless caller; Test-Spec-0.51/t/dying_spec.pl000755 000765 000024 00000000765 12501367077 017352 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # dying_test.pl # # Expected to fail. It should output TAP in such a way that prove(1) # will display the exception message. # ######################################################################## # use Test::Spec; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; describe "Test::Spec" => sub { it "should trap die message" => sub { die "this should be displayed"; }; it "should continue testing" => sub { ok(1); }; }; runtests unless caller; Test-Spec-0.51/t/empty.t000755 000765 000024 00000001324 12501367077 016204 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # empty.t # # Test behavior of empty specs # ######################################################################## # package Testcase::Spec::Define; use strict; use warnings; use FindBin qw($Bin); use Test::More; use Test::Trap; BEGIN { require "$Bin/test_helper.pl" }; { package A; use base qw(Test::Spec); } trap { stub_builder_in_packages("A", sub { A->runtests; }); }; warn $trap->die if $trap->die; is( $trap->leaveby, 'return', 'expected empty test to return, not die' ); like( $trap->stderr, qr/no examples defined/, 'expected warning for empty test' ); like( $trap->stderr, qr/at .*empty\.t line \d+/, 'expected warning from context of caller (issue #5)'); done_testing(); Test-Spec-0.51/t/helper_test.pl000644 000765 000024 00000000122 12501367077 017524 0ustar00andyjonesstaff000000 000000 # # just increment the value of $foo in the current package. # no strict; $foo++; Test-Spec-0.51/t/import_strict.t000755 000765 000024 00000001236 12501367077 017752 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # import_strict.t # ######################################################################## package Testcase::Spec::ImportStrict; use Test::Spec; use FindBin qw($Bin); use warnings; BEGIN { require "$Bin/test_helper.pl" }; describe "Test::Spec" => sub { describe "test file that violates strict" => sub { my $tap = capture_tap("strict_violating_spec.pl"); it "does not compile" => sub { like($tap, qr/aborted due to compilation errors/); }; it "shows reason for failure" => sub { like($tap, qr/undefined_variable_violates_strict_mode_and_test_should_not_compile/); } } }; runtests unless caller; Test-Spec-0.51/t/import_warnings.t000755 000765 000024 00000000674 12501367077 020277 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl package Testcase::Spec::ImportWarnings; use Test::Spec; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; describe "Test::Spec" => sub { describe "test file that contains code that triggers Perl warnings" => sub { my $tap = capture_tap("perl_warning_spec.pl"); it "shows reason for the warning" => sub { like($tap, qr/Odd number of elements/); } } }; runtests unless caller; Test-Spec-0.51/t/mocks.t000755 000765 000024 00000044067 12514760574 016200 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # mocks.t # # Object mocking and stubs. # ######################################################################## # package Testcase::Spec::Mocks; use Test::Spec; use base qw(Test::Spec); use List::Util (); # Just a dummy class hierarchy for our testing { package TestOO; sub new { bless {}, shift; } sub desc { my $self = shift; "bottom"; } } { package TestORM; our @ISA = qw(TestOO); sub create { 'ORIGINAL' } sub retrieve { 'ORIGINAL' } sub desc { shift->SUPER::desc . " middle"; } } { package TestProduct; our @ISA = qw(TestORM); use overload eq => sub { 1 }; # stub for with() test sub prices { 'ORIGINAL' } sub desc { # normally "bottom middle top" shift->SUPER::desc . " top"; } } sub contains_ok { my ($array,$matcher) = @_; local $Test::Builder::Level = $Test::Builder::Level + 1; my $ok; if (ref $matcher eq 'Regexp') { ok( $ok = List::Util::first { $_ =~ $matcher } @$array ); } else { ok( $ok = List::Util::first { $_ eq $matcher } ); } if (not $ok) { # ganked from Test::Builder::_regex_ok my $candidates = join("\n" . (" " x 18), map { "'$_'" } @$array); my $match = "don't match"; Test::More->builder->diag(sprintf <<'DIAGNOSTIC', $candidates, "don't match", $matcher); %s %13s '%s' DIAGNOSTIC } } describe 'Test::Mocks' => sub { # describe "->stubs()" => sub { # replace TestProduct->create for this scope (which is actually TestORM->create) my $class; my $test_product = TestProduct->new; TestProduct->stubs('create' => sub { $class = shift; return $test_product; }); # after each => sub { # # # # TODO: WHAT SHOULD HAPPEN HERE? # # # }; # # after all => sub { # # # # TODO: WHAT SHOULD HAPPEN HERE? # # # }; it 'stubs a class method' => sub { my $product = TestProduct->create(price => 1000); is($product, $test_product); }; it 'calls the stubbed method with the correct class invocant' => sub { TestProduct->create(price => 1000); # stub should have set $class is($class, 'TestProduct'); }; describe "with a before:all block" => sub { my $i = 0; before all => sub { $i++; TestProduct->stubs('retrieve' => sub { $i }); }; it 'stubs methods in before:all blocks' => sub { is(TestProduct->retrieve, 1); }; it 'stubs only once' => sub { is(TestProduct->retrieve, 1); }; }; describe "outside and after the before:all block" => sub { it "restored the original method" => sub { is(TestProduct->retrieve, 'ORIGINAL'); }; }; describe "with a before:each block" => sub { my $i = 0; my $tests_run; # in case only specific tests are run before each => sub { $i++; TestProduct->stubs('retrieve' => sub { $i }); }; it "stubs once per test" => sub { is(TestProduct->retrieve, ++$tests_run); }; it "continues to stub once per test" => sub { is(TestProduct->retrieve, ++$tests_run); }; }; describe "outside and after the before:each block" => sub { it "restored the original method" => sub { is(TestProduct->retrieve, 'ORIGINAL'); }; }; it 'stubs an instance method on all instances of a class' => sub { TestProduct->stubs('name')->returns('stubbed_name'); my $product = TestProduct->new; is($product->name, 'stubbed_name'); # TestProduct->name is un-stubbed automatically }; it 'calls stubbed instance methods with the correct instance invocant' => sub { my $invocant; TestProduct->stubs(name => sub { $invocant = shift }); my $product = TestProduct->new; $product->name; is($invocant, $product); }; it 'stubs instance methods' => sub { my @prices = (1000, 2000); my $product = TestProduct->new; $product->stubs('prices')->returns(\@prices); is_deeply( $product->prices, \@prices ); }; my $shared_product; it 'stubs only the instances requested' => sub { my $before_unstubbed = TestProduct->new; my @prices = (1000, 2000); $shared_product = TestProduct->new; $shared_product->stubs('prices')->returns(\@prices); my $after_unstubbed = TestProduct->new; is_deeply( [$before_unstubbed->prices, $after_unstubbed->prices], ['ORIGINAL','ORIGINAL'] ); }; it 'restores stubbed instance methods' => sub { is_deeply($shared_product->prices, 'ORIGINAL'); }; # "necessarily," because you have to specify the package in your code it 'does not necessarily break SUPER::' => sub { TestORM->stubs('desc' => sub { package TestORM; shift->SUPER::desc . " STUBBED"; }); is(TestProduct->new->desc, 'bottom STUBBED top'); }; it 'does not break inheritance chains after restoring a method' => sub { # usefulness depends on previous test having been run first is(TestProduct->new->desc, 'bottom middle top'); }; }; describe "::stub()" => sub { it 'creates anonymous stubs' => sub { my $stub = stub(stubbed_method => 'result'); is( $stub->stubbed_method, 'result' ); }; }; describe "->expects()" => sub { it 'mocks a class method' => sub { TestProduct->expects('retrieve')->returns(42); is(TestProduct->retrieve(1), 42); }; it 'mocks an instance method' => sub { my $product = TestProduct->new; $product->expects('save')->returns(42); is($product->save, 42); }; it 'expects exactly one call by default' => sub { # looking for something like "expected retrieve to be called # exactly once, but it was called 0 times" my $expectation = TestProduct->expects('retrieve')->returns(42); $expectation->cancel; contains_ok([$expectation->problems], qr/expected.*exactly once.*0 times/); }; it 'dies if there are any problems' => sub { my $expectation = TestProduct->expects('retrieve')->returns(42); $expectation->cancel; eval { $expectation->verify }; like($@, qr/expected.*exactly once.*0 times/); }; it 'runs verify after a test block' => sub { my $verified = 0; my $block_ended = 0; Test::Spec::Mocks::Expectation->stubs(verify => sub { # ensure it actually happens die "verify called before block ended" unless $block_ended; $verified++; }); # yuck, private method. maybe change later. Test::Spec->current_context->_in_anonymous_context(sub { TestProduct->expects('retrieve')->returns(42); $block_ended++; }); ok($verified); }; describe "raising exceptions" => sub { it "raises the exception" => sub { my $stub = stub(); my $expectation = $stub->expects('run'); $expectation->cancel; # don't verify $expectation->raises("Foo\n"); eval { $stub->run; }; if ($@ eq "Foo\n") { pass("As expected"); } else { fail("Told the mock to raise an exception, but it didn't happen"); } }; }; describe "argument matching" => sub { my ($stub, $expectation); my ($with_method, $num_args_mismatch_err, $args_mismatch_err); before each => sub { $stub = stub(); $expectation = $stub->expects('run'); $expectation->cancel; # don't verify }; shared_examples_for "number of arguments" => sub { it "passes when expecting no arguments" => sub { $expectation->$with_method(); $stub->run(); is(scalar($expectation->problems), 0); }; it "passes when expecting no arguments and never called" => sub { $expectation->any_number->$with_method(); # $stub->run(); # nope! is(scalar($expectation->problems), 0); }; it "passes when expecting one argument and never called" => sub { $expectation->any_number->$with_method("Foo"); # $stub->run(); # nope! is(scalar($expectation->problems), 0); }; it "fails when expecting no arguments and one argument given" => sub { $expectation->$with_method(); $stub->run(1); contains_ok([$expectation->problems], $num_args_mismatch_err); }; it "fails when expecting one argument but given none" => sub { $expectation->$with_method("Foo"); $stub->run(); contains_ok([$expectation->problems], $num_args_mismatch_err); }; it "fails when expecting one argument but given two" => sub { $expectation->$with_method("Foo"); $stub->run("Foo", "Bar"); contains_ok([$expectation->problems], $num_args_mismatch_err); }; }; shared_examples_for "shallow string comparisons" => sub { it "passes when expecting one String('Foo') argument" => sub { $expectation->$with_method("Foo"); $stub->run("Foo"); is(scalar($expectation->problems), 0); }; it "fails when expecting one String('Foo') argument but given a different String" => sub { $expectation->$with_method("Foo"); $stub->run("Bar"); contains_ok([$expectation->problems], $args_mismatch_err); }; it "fails when expecting many string arguments but given different arguments" => sub { $expectation->$with_method('Foo', 'Bar', 'Baz'); $stub->run('Foo', 'Bar', 'Bat'); contains_ok([$expectation->problems], $args_mismatch_err); }; }; describe "with eq" => sub { before all => sub { $with_method = 'with'; $num_args_mismatch_err = qr/^Number of arguments don't match expectation$/; $args_mismatch_err = qr/^Expected argument in position/; }; it_should_behave_like "number of arguments"; it_should_behave_like "shallow string comparisons"; it "passes when expecting an object argument that was given" => sub { my $obj = TestOO->new; $expectation->with($obj); $stub->run($obj); is(scalar($expectation->problems), 0); }; it "fails when expecting an object argument but given a different one" => sub { $expectation->with(TestOO->new); $stub->run(TestOO->new); contains_ok([$expectation->problems], qr/^Expected argument in position 0 to be 'TestOO=HASH.+ but it was 'TestOO=HASH/); }; it "passes when expecting an object argument and given a different one that compares with eq operator" => sub { $expectation->with(TestProduct->new); $stub->run(TestProduct->new); is(scalar($expectation->problems), 0); }; }; describe "with Test::Deep" => sub { before all => sub { $with_method = 'with_deep'; $num_args_mismatch_err = qr/^Compared array length/; $args_mismatch_err = qr/^Compared .*(?!length)/; }; it_should_behave_like "number of arguments"; it_should_behave_like "shallow string comparisons"; it "passes when expecting an object argument that was given" => sub { my $obj = TestOO->new; $expectation->with_deep($obj); $stub->run($obj); is(scalar($expectation->problems), 0); }; it "passes when expecting an empty hash and given a different one" => sub { $expectation->with_deep({}); $stub->run({}); is(scalar($expectation->problems), 0); }; it "passes when given a copy of the data structure it is expecting" => sub { $expectation->with_deep({ key => 'value' }); $stub->run({ key => 'value' }); is(scalar($expectation->problems), 0); }; it "passes when expecting an object and given a clone" => sub { $expectation->with_deep(TestOO->new); $stub->run(TestOO->new); is(scalar($expectation->problems), 0); }; it "does a deep comparison of nested structures" => sub { $expectation->with_deep({ product => TestProduct->new }); $stub->run({ product => TestProduct->new }); is(scalar($expectation->problems), 0); }; }; }; describe "call count expectation" => sub { my $stub = stub(); my $expectation; before each => sub { $expectation = $stub->expects('run')->returns(42); $expectation->cancel; # don't verify }; describe "'exactly'" => sub { before sub { $expectation->exactly(42) }; it "passes when called exactly N times" => sub { for (1..42) { $stub->run } is(scalar($expectation->problems), 0); }; it "fails when called less than N times" => sub { $stub->run; contains_ok([$expectation->problems], qr/expected.*42.*1 time/); }; it "fails when called more than N times" => sub { for (1..43) { $stub->run } contains_ok([$expectation->problems], qr/expected.*42.*43 times/); }; }; describe "'never'" => sub { before sub { $expectation->never }; it "passes when called never" => sub { is(scalar($expectation->problems), 0); }; it "fails when called" => sub { $stub->run; ok(scalar($expectation->problems) > 0); }; }; describe "'once'" => sub { before sub { $expectation->once }; it "passes when called once" => sub { $stub->run; is(scalar($expectation->problems), 0); }; it "fails when not called" => sub { contains_ok([$expectation->problems], qr/expected.*exactly once.*0 times/); }; it "fails when called more than once" => sub { $stub->run; $stub->run; contains_ok([$expectation->problems], qr/expected.*exactly once.*2 times/); }; }; describe "'at_least'" => sub { before sub { $expectation->at_least(3) }; it "fails when called fewer than N times" => sub { $stub->run; contains_ok([$expectation->problems], qr/expected.*\bat least 3\b.*\b1 time/); }; it "passes when called N times" => sub { for (1..3) { $stub->run } is(scalar($expectation->problems), 0); }; it "passes when called more than N times" => sub { for (1..4) { $stub->run } is(scalar($expectation->problems), 0); }; }; describe "'at_least_once'" => sub { before sub { $expectation->at_least_once }; it "fails when not called at least once" => sub { contains_ok([$expectation->problems], qr/expected.*\bat least 1\b.*\b0 times/); }; it "passes when called once" => sub { $stub->run; is(scalar($expectation->problems), 0); }; it "passes when called more than once" => sub { for (1..3) { $stub->run } is(scalar($expectation->problems), 0); }; }; describe "'at_most'" => sub { before sub { $expectation->at_most(2) }; it "passes when never called" => sub { # test specifically for zero, since it's an edge case is(scalar($expectation->problems), 0); }; it "passes when called fewer than N times" => sub { $stub->run; is(scalar($expectation->problems), 0); }; it "passes when called at most N times" => sub { for (1..2) { $stub->run } is(scalar($expectation->problems), 0); }; it "fails when not called at most N times" => sub { for (1..3) { $stub->run } contains_ok([$expectation->problems], qr/expected.*\bat most 2\b.*\b3 times/); }; }; describe "'at_most_once'" => sub { before sub { $expectation->at_most_once }; it "passes when never called" => sub { # test specifically for zero, since it's an edge case is(scalar($expectation->problems), 0); }; it "passes when called exactly once" => sub { $stub->run; is(scalar($expectation->problems), 0); }; it "fails when called more than once" => sub { for (1..2) { $stub->run } contains_ok([$expectation->problems], qr/expected.*\bat most 1\b.*\b2 times/); }; }; describe "'maybe'" => sub { # TODO: add ability to share tests between contexts. these are the # same tests for at_most_once, since 'maybe' is an alias for that before sub { $expectation->maybe }; it "passes when never called" => sub { # test specifically for zero, since it's an edge case is(scalar($expectation->problems), 0); }; it "passes when called exactly once" => sub { $stub->run; is(scalar($expectation->problems), 0); }; it "fails when called more than once" => sub { for (1..2) { $stub->run } contains_ok([$expectation->problems], qr/expected.*\bat most 1\b.*\b2 times/); }; }; describe "'any_number'" => sub { before sub { $expectation->any_number }; it "passes when not called" => sub { is(scalar($expectation->problems), 0); }; it "passes when called once" => sub { $stub->run; is(scalar($expectation->problems), 0); }; it "passes when called more than once" => sub { for (1..2) { $stub->run } is(scalar($expectation->problems), 0); }; }; }; }; describe "::mock()" => sub { it 'allows anonymous mocking' => sub { my $mock = mock(); $mock->expects('expected_method')->returns("result"); #->with("p1","p2")->returns("result"); is($mock->expected_method, "result"); }; }; # }; runtests unless caller; Test-Spec-0.51/t/mocks_imports.t000755 000765 000024 00000003576 12501367077 017752 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # mocks_imports.t # # Test the way Test::Spec::Mocks exports symbols. # ######################################################################## # package Testcase::Spec::Mocks::Imports; use Test::Spec; use base qw(Test::Spec); use Package::Stash; no strict 'refs'; describe "Test::Spec::Mocks" => sub { # start each test with a clean slate before each => sub { for my $pkg (qw(UNIVERSAL A)) { my $stash = Package::Stash->new($pkg); for my $sym (qw(&stubs &stub &expects &mock)) { $stash->remove_symbol($sym); } } }; it "should not export symbols unless asked" => sub { { package A; require Test::Spec::Mocks; } ok(!defined(&{"UNIVERSAL::stubs"}) && !defined(&{"A::stubs"})); }; it "should export &stubs into UNIVERSAL" => sub { { package A; eval "use Test::Spec::Mocks"; die $@ if $@; } is( \&{"UNIVERSAL::stubs"}, \&{"Test::Spec::Mocks::stubs"} ); }; it "should export &stubs into UNIVERSAL even when listed in the import list" => sub { { package A; eval "use Test::Spec::Mocks qw(stubs)"; die $@ if $@; } ok( \&{"UNIVERSAL::stubs"} == \&{"Test::Spec::Mocks::stubs"} && !defined(&{"A::stubs"}) ); }; it "should export &stub into the current pacakge" => sub { { package A; eval "use Test::Spec::Mocks"; die $@ if $@; } is( \&{"A::stub"}, \&{"Test::Spec::Mocks::stub"} ); }; it "should export &stub into the current package even when &stubs is in the import list" => sub { { package A; eval "use Test::Spec::Mocks qw(stub stubs)"; die $@ if $@; } ok( \&{"UNIVERSAL::stubs"} == \&{"Test::Spec::Mocks::stubs"} && !defined(&{"A::stubs"}) && !defined(&{"UNIVERSAL::stub"}) && \&{"A::stub"} == \&{"Test::Spec::Mocks::stub"} ); }; }; runtests unless caller; Test-Spec-0.51/t/ordering.t000755 000765 000024 00000000767 12555500045 016662 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # ordering.pl # # Verify that describe blocks are executed in order of definition. # ######################################################################## # use Test::Spec; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; my $num_contexts = 10; my $next_expected = 1; for my $num (1..$num_contexts) { describe "Context $num" => sub { it "should run in position $num" => sub { is $next_expected++, $num; }; } }; runtests(@ARGV) unless caller; Test-Spec-0.51/t/perl_warning_spec.pl000755 000765 000024 00000000765 12501367077 020727 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # perl_warning_spec.pl # # Expected to show "Odd number of elements" warning because Test::Spec # imports warnings into test file. # ######################################################################## use Test::Spec; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; describe "Test::Spec" => sub { it "turns on perl warnings in test file" => sub { my %hash = ( "with" => "odd", "number" => "of", "elements" ); pass; }; }; runtests unless caller; Test-Spec-0.51/t/predictable_destroy.pl000644 000765 000024 00000001112 12514760574 021240 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # predictable_destroy.pl # # Objects should be destroyed in a predictable order during the RUN phase # Expected to print out "DESTROYED IN RUN PHASE" # ######################################################################## # package Testcase::Spec::PredictableDestroy; use Test::Spec; { package Foo; sub new { bless {}, $_[0] } sub DESTROY { warn("$_[0] DESTROYED IN ${^GLOBAL_PHASE}") } }; describe "Test::Spec::Mocks" => sub { my $x = Foo->new; it "destroys objects in the run phase" => sub { ok $x; }; }; runtests() unless caller; Test-Spec-0.51/t/predictable_destroy_spec.t000644 000765 000024 00000001235 12514760574 022110 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # predictable_destroy_spec.t # # Ensure we don't keep references around to objects so they # are destroyed in a predictable order # ######################################################################## # package Testcase::Spec::PredictableDestroy; use Test::Spec; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; describe "Test::Spec" => sub { my $tap = capture_tap("predictable_destroy.pl"); it "destroys objects in the run phase" => sub { unlike $tap => qr/DESTROYED IN DESTRUCT/; }; it "avoids global destruction" => sub { unlike $tap => qr/during global destruction/; }; }; runtests unless caller; Test-Spec-0.51/t/runtests_subset.t000755 000765 000024 00000003561 12501367077 020327 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # runtests_subset.t # ######################################################################## # package Testcase::Spec::RuntestsSubset; use Test::Spec; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; describe "Test::Spec" => sub { describe "when no specific examples are requested" => sub { my $tap; before all => sub { $tap = capture_tap("subset_spec.pl"); }; it "should run all the examples" => sub { like $tap, qr/^ok \d+ - Test One.*ok \d+ - Test Two/ms; }; }; describe "when specific examples are requested explicitly" => sub { my $tap; before all => sub { # case insensitivity is baked in $tap = capture_tap("subset_spec.pl", "oNe"); }; it "should run the requested examples" => sub { like $tap, qr/^ok \d+ - Test One/m; }; it "should run ONLY the requested examples" => sub { unlike $tap, qr/^ok \d+ - Test Two/; }; }; describe "when specific examples are requested via SPEC environment var" => sub { my $tap; before all => sub { # case insensitivity is baked in local $ENV{SPEC} = "oNe"; $tap = capture_tap("subset_spec.pl"); }; it "should run the requested examples" => sub { like $tap, qr/^ok \d+ - Test One/m; }; it "should run ONLY the requested examples" => sub { unlike $tap, qr/^ok \d+ - Test Two/; }; }; describe "when examples are requested via both SPEC and explicit parameter" => sub { my $tap; before all => sub { # case insensitivity is baked in local $ENV{SPEC} = "oNe"; $tap = capture_tap("subset_spec.pl","tWo"); }; it "should run the explicit example" => sub { like $tap, qr/^ok \d+ - Test Two/m; }; it "should *not* run the SPEC example" => sub { unlike $tap, qr/^ok \d+ - Test One/; }; }; }; runtests unless caller; Test-Spec-0.51/t/shared_examples.t000755 000765 000024 00000004505 12501367077 020216 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # shared_examples.t # # Test cases for Test::Spec shared example definition and inclusion. # Executes shared_examples_spec.pl and validates its TAP output. # ######################################################################## # use strict; use warnings; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; use Test::More; my @results = parse_tap("shared_examples_spec.pl"); my %passing = map { $_->description => 1 } grep { $_->is_test } @results; sub test_passed { my $desc = shift; my $testdesc = "- $desc"; ok(exists $passing{$testdesc}, $desc); } test_passed("A context importing an example group can take at least one example"); test_passed("A context importing an example group can take more than one example"); test_passed("A context importing an example group with an inner block nests properly"); test_passed("A context importing an example group can have custom behavior"); test_passed("A context importing an example group can be reopened"); test_passed("A context importing an example group executes"); test_passed("Another context importing an example group can take at least one example"); test_passed("Another context importing an example group can take more than one example"); test_passed("Another context importing an example group with an inner block nests properly"); test_passed("Another context importing an example group can have custom behavior, too"); test_passed("Another context importing an example group can be reopened"); test_passed("Another context can have behavior that doesn't interfere with example groups in sub-contexts"); test_passed("Another context importing an example group accumulates examples in the same way that describe() does"); @results = parse_tap("another_shared_examples_spec.pl"); %passing = map { $_->description => 1 } grep { $_->is_test } @results; test_passed("A context in a second spec importing an example group defined in another package can take at least one example"); test_passed("A context in a second spec importing an example group defined in another package can take more than one example"); test_passed("A context in a second spec importing an example group defined in another package with an inner block nests properly"); test_passed("A context in a second spec importing an example group defined in another package can be reopened"); done_testing(); Test-Spec-0.51/t/shared_examples_spec.pl000755 000765 000024 00000003340 12501367077 021374 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # shared_examples_spec.pl # # Test cases for Test::Spec shared example definition and inclusion. # Generates TAP to be checked by shared_examples.t # ######################################################################## # package Testcase::Spec::SharedExamplesSpec; use Test::Spec; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; shared_examples_for "example group" => sub { it "can take at least one example"; it "can take more than one example"; describe "with an inner block" => sub { it "nests properly"; }; }; describe "A context" => sub { # can define an example group. shared_examples_for "example group defined in context" => sub { it "executes"; }; }; describe "A context importing an example group" => sub { it_should_behave_like "example group"; it_should_behave_like "example group defined in context"; it "can have custom behavior"; }; describe "Another context" => sub { describe "importing an example group" => sub { it_should_behave_like "example group"; it "can have custom behavior, too"; }; it "can have behavior that doesn't interfere with example groups in sub-contexts"; }; describe "Another context" => sub { describe "importing an example group" => sub { it "accumulates examples in the same way that describe() does"; }; }; shared_examples_for "example group" => sub { it "can be reopened"; }; # A context importing an example group can take at least one example # A context importing an example group can take more than one example # A context importing an example group can be reopened # A context importing an example group with an inner block nests properly # A context importing an example group executes runtests unless caller; Test-Spec-0.51/t/show_exceptions.t000755 000765 000024 00000002103 12501367077 020263 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # show_exceptions.t # ######################################################################## # package Testcase::Spec::ShowExceptions; use Test::Spec; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; describe "Test::Spec" => sub { my $tap = capture_tap("dying_spec.pl"); it "should explain why a dying test failed" => sub { like($tap, qr/^# Failed test 'Test::Spec should trap die message' by dying:\s*$/m); }; it "should echo the exception message" => sub { like($tap, qr/^# this should be displayed\s*$/m); }; it "should report the context at which the error occurred" => sub { like($tap, qr/^# at .+? line \d+\.\s*$/m); }; it "should continue running tests after an exception is encountered" => sub { like($tap, qr/^ok \d+ - Test::Spec should continue testing/m); }; it "should report usage errors from the location of the error" => sub { my ($utap) = split /[\r\n]+/, capture_tap("uncompilable_spec.pl"); like($utap, qr/at .*uncompilable_spec.pl line \d+/); }; }; runtests unless caller; Test-Spec-0.51/t/spec_helper.t000755 000765 000024 00000002203 12501367077 017334 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # spec_helper.t # # Tests the spec_helper function, which loads helper files relative to # the current file. # ######################################################################## # package Testcase::Spec::SpecHelper; use Test::Spec; use base qw(Test::Spec); our $foo; describe "spec_helper" => sub { before each => sub { $foo = 0 }; it "should load a Perl file into the calling package" => sub { spec_helper "helper_test.pl"; is($foo, 1); }; it "should load the file even if it has already been loaded" => sub { spec_helper "helper_test.pl"; is($foo, 1); }; it "should treat paths as relative to the spec, not the currently running executable" => sub { spec_helper "../t/helper_test.pl"; is($foo, 1); }; it "should treat absolute paths as absolute" => sub { # checks the error message eval { spec_helper "/foo/bar/does/not/exist" }; like($@, qr{'/foo/bar/does/not/exist'}); }; it "should raise an error containing the filename if the load fails" => sub { eval { spec_helper "doesnotexist.pl" }; like($@, qr{'doesnotexist.pl'}); }; }; runtests unless caller; Test-Spec-0.51/t/strict_violating_spec.pl000755 000765 000024 00000000576 12501367077 021624 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # strict_violating_spec.pl # # Expected to fail to compile because Test::Spec imports strict into test file. # ######################################################################## use Test::Spec; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; $undefined_variable_violates_strict_mode_and_test_should_not_compile; runtests unless caller; Test-Spec-0.51/t/subset_spec.pl000755 000765 000024 00000000562 12501367077 017540 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # subset_spec.pl # # Helper for testing arguments to runtests(@patterns). # ######################################################################## # use Test::Spec; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; describe "Test" => sub { it "One" => sub { pass }; it "Two" => sub { pass }; }; runtests(@ARGV) unless caller; Test-Spec-0.51/t/test_helper.pl000644 000765 000024 00000004065 12501367077 017536 0ustar00andyjonesstaff000000 000000 use strict; use FindBin qw($Bin); # # Shim to make Win32 behave during the test suite. # # Using fork+exec causes an APPCRASH during show_exceptions.t. Simply # reopening STDOUT and STDERR to the same duped filehandle causes errors in # the output where STDOUT and STDERR are written on top of each other (even # when autoflush is turned on). Reopening STDERR on top of STDOUT in the child # process seems to fix this problem. open(STDERR, ">&STDOUT") || die "can't reopen STDERR on STDOUT: $!"; { package SpecStub; sub new { bless do { \my $stub }, shift() } sub AUTOLOAD { shift } } sub stub_builder_in_packages { my $code = pop; my @packages = @_ ? @_ : 'A'; push @packages, 'Test::More'; my $stub = SpecStub->new; my @locals = map { "local *${_}::builder = sub { \$stub };" } @packages; local $, = " "; eval "@locals; \$code->()"; die $@ if $@; } sub capture_tap { my ($spec_name,@args) = @_; require File::Spec; require File::Temp; my ($fh,$filename) = File::Temp::tempfile('tmpfileXXXXXX', TMPDIR => 1); close($fh); open my $oldout, ">&STDOUT" or die "can't dup stdout: $!"; open my $olderr, ">&STDERR" or die "can't dup stderr: $!"; open(STDOUT, ">", $filename) || die "can't open '$filename' for out: $!"; open(STDERR, ">&STDOUT") || die "can't reopen stderr on stdout: $!"; system($^X, (map { "-I$_" } @INC), File::Spec->catfile($Bin, $spec_name), @args); open(STDERR, ">&", $olderr) || do { print {$olderr} "can't reopen stderr: $! " . "at " . __FILE__ . " line " . __LINE__ . "\n"; exit(1); }; open(STDOUT, ">&", $oldout) || die "can't reopen stdout: $!"; open($fh, "<", $filename) || die "can't open '$filename' for read: $!"; my $tap = do { local $/; <$fh> }; unlink($filename) || warn "can't unlink '$filename': $!"; return $tap; } sub parse_tap { require TAP::Parser; my ($spec_name,@args) = @_; my $tap = capture_tap($spec_name,@args); my $parser = TAP::Parser->new({ tap => $tap }); my @results; while (my $result = $parser->next) { push @results, $result; } return @results; } 1; Test-Spec-0.51/t/uncompilable_spec.pl000755 000765 000024 00000000573 12501367077 020707 0ustar00andyjonesstaff000000 000000 #!/usr/bin/env perl # # uncompilable_spec.pl # # Expected to fail and report Test::Spec usage error from the correct stack # frame (i.e. "at uncompilable_spec.pl line 13"). # ######################################################################## # use Test::Spec; use FindBin qw($Bin); BEGIN { require "$Bin/test_helper.pl" }; describe "Test::Spec"; runtests unless caller; Test-Spec-0.51/lib/Test/000755 000765 000024 00000000000 12555501370 016073 5ustar00andyjonesstaff000000 000000 Test-Spec-0.51/lib/Test/Spec/000755 000765 000024 00000000000 12555501370 016765 5ustar00andyjonesstaff000000 000000 Test-Spec-0.51/lib/Test/Spec.pm000644 000765 000024 00000066716 12555500603 017341 0ustar00andyjonesstaff000000 000000 package Test::Spec; use strict; use warnings; use Test::Trap (); # load as early as possible to override CORE::exit our $VERSION = '0.51'; use base qw(Exporter); use Carp (); use Exporter (); use File::Spec (); use Tie::IxHash (); use constant { DEFINITION_PHASE => 0, EXECUTION_PHASE => 1 }; our $TODO; our $Debug = $ENV{TEST_SPEC_DEBUG} || 0; our @EXPORT = qw(runtests describe xdescribe context xcontext it xit they xthey before after spec_helper *TODO share shared_examples_for it_should_behave_like ); our @EXPORT_OK = ( @EXPORT, qw(DEFINITION_PHASE EXECUTION_PHASE $Debug) ); our %EXPORT_TAGS = ( all => \@EXPORT_OK, constants => [qw(DEFINITION_PHASE EXECUTION_PHASE)] ); our $_Current_Context; our %_Package_Contexts; our %_Package_Phase; our %_Package_Tests; our %_Shared_Example_Groups; # Avoid polluting the Spec namespace by loading these other modules into # what's essentially a mixin class. When you write "use Test::Spec", # you'll get everything from Spec plus everything in ExportProxy. If you # specify a list, the pool is limited to the stuff in @EXPORT_OK above. { package Test::Spec::ExportProxy; use base qw(Exporter); BEGIN { eval "use Test::Deep 0.103 ()"; # check version and load export list Test::Deep->import(grep { $_ ne 'isa' } @Test::Deep::EXPORT); } use Test::More; use Test::Trap; use Test::Spec::Mocks; our @EXPORT_OK = ( @Test::More::EXPORT, (grep { $_ ne 'isa' } @Test::Deep::EXPORT), qw(trap $trap), # Test::Trap doesn't use Exporter @Test::Spec::Mocks::EXPORT, ); our @EXPORT = @EXPORT_OK; our %EXPORT_TAGS = (all => \@EXPORT_OK); } sub import { my $class = shift; my $callpkg = caller; strict->import; warnings->import; # specific imports requested if (@_) { $class->export_to_level(1, $callpkg, @_); return; } eval qq{ package $callpkg; use base 'Test::Spec'; # allow Test::Spec usage errors to be reported via Carp our \@CARP_NOT = qw($callpkg); }; die $@ if $@; Test::Spec::ExportProxy->export_to_level(1, $callpkg); $class->export_to_level(1, $callpkg); } # PACKAGE->phase # PACKAGE->phase(NEWPHASE) sub phase { my $invocant = shift; my $class = ref($invocant) || $invocant; if (@_) { $_Package_Phase{$class} = shift; } if (exists $_Package_Phase{$class}) { return $_Package_Phase{$class}; } else { return $_Package_Phase{$class} = DEFINITION_PHASE; } } # PACKAGE->add_test(SUBNAME) sub add_test { my ($class,$test) = @_; my $list = $_Package_Tests{$class} ||= []; push @$list, $test; return; } # @subnames = PACKAGE->tests sub tests { my ($class) = @_; my $list = $_Package_Tests{$class} ||= []; return @$list; } # runtests # PACKAGE->runtests # @ARGV or $ENV{SPEC} # PACKAGE->runtests(PATTERNS) sub runtests { my $class = $_[0]; if (not defined $class) { $class = caller; } elsif (not eval { $class->isa(__PACKAGE__) }) { $class = caller; } else { shift; # valid class, remove from arg stack. } $class->_materialize_tests; $class->phase(EXECUTION_PHASE); my @which = @_ ? @_ : $ENV{SPEC} ? ($ENV{SPEC}) : (); my @tests = $class->_pick_tests(@which); return $class->_execute_tests( @tests ); } sub builder { # this is a singleton. Test::Builder->new; } sub _pick_tests { my ($class,@matchers) = @_; my @tests = $class->tests; for my $pattern (@matchers) { @tests = grep { $_->name =~ /$pattern/i } @tests; } return @tests; } sub _execute_tests { my ($class,@tests) = @_; for my $test (@tests) { $test->run(); } # Ensure we don't keep any references to user variables so they go out # of scope in a predictable fashion. %_Package_Tests = %_Package_Contexts = (); # XXX: this doesn't play nicely with Test::NoWarnings and friends $class->builder->done_testing; } # it DESC => CODE # it CODE # it DESC sub it(@) { my $package = caller; my $code; if (@_ && ref($_[-1]) eq 'CODE') { $code = pop; } my $name = shift; if (not ($code || $name)) { Carp::croak "it() requires at least one of (description,code)"; } $name ||= "behaves as expected (whatever that means)"; push @{ _autovivify_context($package)->tests }, { name => $name, code => $code, todo => $TODO, }; return; } # alias "they" to "it", for describing behavior of multiple items sub they(@); BEGIN { *they = \&it } # describe DESC => CODE # describe CODE sub describe(@) { my $package = caller; my $code = pop; if (ref($code) ne 'CODE') { Carp::croak "expected subroutine reference as last argument"; } my $name = shift || $package; my $container; if ($_Current_Context) { $container = $_Current_Context->context_lookup; } else { $container = $_Package_Contexts{$package} ||= Test::Spec::_ixhash(); } __PACKAGE__->_accumulate_examples({ container => $container, name => $name, class => $package, code => $code, label => $name, }); } # make context() an alias for describe() sub context(@); BEGIN { *context = \&describe } # used to easily disable suites/specs during development sub xit(@) { local $TODO = '(disabled)'; it(@_); } sub xthey(@) { local $TODO = '(disabled)'; they(@_); } sub xdescribe(@) { local $TODO = '(disabled)'; describe(@_); } # make xcontext() an alias for xdescribe() sub xcontext(@); BEGIN { *xcontext = \&xdescribe } # shared_examples_for DESC => CODE sub shared_examples_for($&) { my $package = caller; my ($name,$code) = @_; if (not defined($name)) { Carp::croak "expected example group name as first argument"; } if (ref($code) ne 'CODE') { Carp::croak "expected subroutine reference as last argument"; } __PACKAGE__->_accumulate_examples({ container => \%_Shared_Example_Groups, name => $name, class => undef, # shared examples are global code => $code, label => '', }); } # used by both describe() and shared_examples_for() to build example # groups in context sub _accumulate_examples { my ($klass,$args) = @_; my $container = $args->{container}; my $name = $args->{name}; my $class = $args->{class}; my $code = $args->{code}; my $label = $args->{label}; my $context; # Don't clobber contexts of the same name, aggregate them. if ($container->{$name}) { $context = $container->{$name}; } else { $container->{$name} = $context = Test::Spec::Context->new; $context->name( $label ); # A context gets either a parent or a class. This is because the # class should be inherited from the parent to support classless # shared example groups. if ($_Current_Context) { $context->parent( $_Current_Context ); } else { $context->class( $class ); } } # evaluate the context function, which will set up lexical variables and # define tests and other contexts $context->contextualize($code); } # it_should_behave_like DESC sub it_should_behave_like($) { my ($name) = @_; if (not defined($name)) { Carp::croak "expected example_group_name as first argument"; } if (!$_Current_Context) { Carp::croak "it_should_behave_like can only be used inside a describe or shared_examples_for context"; } my $context = $_Shared_Example_Groups{$name} || Carp::croak "unrecognized example group \"$name\""; # make a copy so we can assign the correct class name (via parent), # which is needed for flattening the context into actual test # functions later. my $shim = $context->clone; $shim->parent($_Current_Context); # add our shared_examples_for context as if it had been written inline # as a describe() block $_Current_Context->context_lookup->{"__shared_examples__:$name"} = $shim; } # before CODE # before all => CODE # before each => CODE sub before (@) { my $package = caller; my $code = pop; if (ref($code) ne 'CODE') { Carp::croak "expected subroutine reference as last argument"; } my $type = shift || 'each'; if ($type ne 'each' && $type ne 'all') { Carp::croak "before type should be one of 'each' or 'all'"; } my $context = _autovivify_context($package); push @{ $context->before_blocks }, { type => $type, code => $code }; } # after CODE # after all => CODE # after each => CODE sub after (@) { my $package = caller; my $code = pop; if (ref($code) ne 'CODE') { Carp::croak "expected subroutine reference as last argument"; } my $type = shift || 'each'; if ($type ne 'each' and $type ne 'all') { Carp::croak "after type should be one of 'each' or 'all'"; } my $context = _autovivify_context($package); push @{ $context->after_blocks }, { type => $type, code => $code }; } # spec_helper FILESPEC sub spec_helper ($) { my $filespec = shift; my ($callpkg,$callfile) = caller; my $load_path; if (File::Spec->file_name_is_absolute($filespec)) { $load_path = $filespec; } else { my ($callvol,$calldir,undef) = File::Spec->splitpath($callfile); my (undef,$filedir,$filename) = File::Spec->splitpath($filespec); my $newdir = File::Spec->catdir($calldir,$filedir); $load_path = File::Spec->catpath($callvol,$newdir,$filename); } my $sub = eval "package $callpkg;\n" . q[sub { my ($file,$origpath) = @_; open(my $IN, "<", $file) || die "could not open spec_helper '$origpath': $!"; defined(my $content = do { local $/; <$IN> }) || die "could not read spec_helper '$origpath': $!"; eval("# line 1 \"$origpath\"\n" . $content); die "$@\n" if $@; }]; $sub->($load_path,$filespec); } sub share(\%) { my $hashref = shift; tie %$hashref, 'Test::Spec::SharedHash'; } sub _materialize_tests { my $class = shift; my $contexts = $_Package_Contexts{$class}; if (not $contexts && %$contexts) { Carp::carp "no examples defined in spec package $class"; return; } for my $context (values %$contexts) { $context->_materialize_tests(); } } sub in_context { my ($class,$context) = @_; if (!$_Current_Context) { return ''; } elsif ($context == $_Current_Context) { return 1; } elsif ($context->ancestor_of($_Current_Context)) { return 1; } else { return ''; } } # NOT a method, just a subroutine that takes a package name. sub _autovivify_context { my ($package) = @_; if ($_Current_Context) { return $_Current_Context; } else { my $name = ''; # unnamed context return $_Package_Contexts{$package}{$name} ||= Test::Spec::Context->new({ name => $name, class => $package, parent => undef }); } } # Public interface. sub current_context { $_Current_Context } sub contexts { my ($class) = @_; my @ctx = values %{ $_Package_Contexts{$class} || {} }; return wantarray ? @ctx : \@ctx; } sub _ixhash { tie my %h, 'Tie::IxHash'; \%h; } # load context implementation require Test::Spec::Context; require Test::Spec::SharedHash; 1; =head1 NAME Test::Spec - Write tests in a declarative specification style =head1 SYNOPSIS use Test::Spec; # automatically turns on strict and warnings describe "A date" => sub { my $date; describe "in a leap year" => sub { before each => sub { $date = DateTime->new(year => 2000, month => 2, day => 28); }; it "should know that it is in a leap year" => sub { ok($date->is_leap_year); }; it "should recognize Feb. 29" => sub { is($date->add(days => 1)->day, 29); }; }; describe "not in a leap year" => sub { before each => sub { $date = DateTime->new(year => 2001, month => 2, day => 28); }; it "should know that it is NOT in a leap year" => sub { ok(!$date->is_leap_year); }; it "should NOT recognize Feb. 29" => sub { is($date->add(days => 1)->day, 1); }; }; }; runtests unless caller; # Generates the following output: # ok 1 - A date in a leap year should know that it is in a leap year # ok 2 - A date in a leap year should recognize Feb. 29 # ok 3 - A date not in a leap year should know that it is NOT in a leap year # ok 4 - A date not in a leap year should NOT recognize Feb. 29 # 1..4 =head1 DESCRIPTION This is a declarative specification-style testing system for behavior-driven development (BDD) in Perl. The tests (a.k.a. examples) are named with strings instead of subroutine names, so your fingers will suffer less fatigue from underscore-itis, with the side benefit that the test reports are more legible. This module is inspired by and borrows heavily from RSpec (http://rspec.info/documentation/), a BDD tool for the Ruby programming language. =head2 EXPORTS When given B (i.e. C), this class will export: =over 4 =item * Spec definition functions These are the functions you will use to define behaviors and run your specs: C, C, C, C, C, C, C, C, C, and C. =item * The stub/mock functions in L. =item * Everything that L normally exports This includes C, C and friends. You'll use these to assert correct behavior. =item * Everything that L normally exports More assertions including C. =item * Everything that C normally exports The C function, which let you test behaviors that call C and other hard things like that. "A block eval on steroids." =back If you specify an import list, only functions directly from C (those documented below) are available. =head2 FUNCTIONS =over 4 =item runtests =item runtests(@patterns) Runs all the examples whose descriptions match one of the (non case-sensitive) regular expressions in C<@patterns>. If C<@patterns> is not provided, runs I examples. The environment variable "SPEC" will be used as a default pattern if present. If called as a function (i.e. I a method call with "->"), C will autodetect the package from which it is called and run that package's examples. A useful idiom is: runtests unless caller; which will run the examples when the file is loaded as a script (for example, by running it from the command line), but not when it is loaded as a module (with C or C). =item describe DESCRIPTION => CODE =item describe CODE Defines a specification context under which examples and more descriptions can be defined. All examples I come inside a C block. =over 4 =item C blocks can be nested to DRY up your specs. For large specifications, C blocks can save you a lot of duplication: describe "A User object" => sub { my $user; before sub { $user = User->new; }; describe "from a web form" => sub { before sub { $user->init_from_tree({ username => "bbill", ... }); }; it "should read its attributes from the form"; describe "when saving" => sub { it "should require a unique username"; it "should require a password"; }; }; }; The setup work done in each C block cascades from one level to the next, so you don't have to make a call to some initialization function manually in each test. It's done automatically based on context. =item Using describe blocks improves legibility without requiring more typing. The name of the context will be included by default in the success/failure report generated by Test::Builder-based testing methods (e.g. Test::More's ok() function). For an example like this: describe "An unladen swallow" => sub { it "has an airspeed of 11 meters per second" => sub { is($swallow->airspeed, "11m/s"); }; }; The output generated is: ok 1 - An unladen swallow has an airspeed of 11 meters per second Contrast this to the following test case to generate the same output: sub unladen_swallow_airspeed : Test { is($swallow->airspeed, "11m/s", "An unladen swallow has an airspeed of 11 meters per second"); } =back C blocks execute in the order in which they are defined. Multiple C blocks with the same name are allowed. They do not replace each other, rather subsequent Cs extend the existing one of the same name. =item context An alias for C. =item xdescribe Specification contexts may be disabled by calling C instead of C. All examples inside an C are reported as "# TODO (disabled)", which prevents Test::Harness/prove from counting them as failures. =item xcontext An alias for C. =item it SPECIFICATION => CODE =item it CODE =item it TODO_SPECIFICATION Defines an example to be tested. Despite its awkward name, C allows a natural (in my opinion) way to describe expected behavior: describe "A captive of Buffalo Bill" => sub { it "puts the lotion on its skin" => sub { ... }; it "puts the lotion in the basket"; # TODO }; If a code reference is not passed, the specification is assumed to be unimplemented and will be reported as "TODO (unimplemented)" in the test results (see L. TODO tests report as skipped, not failed. =item they SPECIFICATION => CODE =item they CODE =item they TODO_SPECIFICATION An alias for L. This is useful for describing behavior for groups of items, so the verb agrees with the noun: describe "Captives of Buffalo Bill" => sub { they "put the lotion on their skin" => sub { ... }; they "put the lotion in the basket"; # TODO }; =item xit/xthey Examples may be disabled by calling xit()/xthey() instead of it()/they(). These examples are reported as "# TODO (disabled)", which prevents Test::Harness/prove from counting them as failures. =item before each => CODE =item before all => CODE =item before CODE Defines code to be run before tests in the current describe block are run. If "each" is specified, CODE will be re-executed for every test in the context. If "all" is specified, CODE will only be executed before the first test. The default is "each", due to this logic presented in RSpec's documentation: I<"It is very tempting to use before(:all) and after(:all) for situations in which it is not appropriate. before(:all) shares some (not all) state across multiple examples. This means that the examples become bound together, which is an absolute no-no in testing. You should really only ever use before(:all) to set up things that are global collaborators but not the things that you are describing in the examples.> I (L) There is no restriction on having multiple before blocks. They will run in sequence within their respective "each" or "all" groups. C blocks run before C blocks. =item after each => CODE =item after all => CODE =item after CODE Like C, but backwards. Runs CODE after each or all tests, respectively. The default is "each". C blocks run I C blocks. =item shared_examples_for DESCRIPTION => CODE Defines a group of examples that can later be included in C blocks or other C blocks. See L. Example group names are B, but example groups can be defined at any level (i.e. they can be defined in the global context, or inside a "describe" block). my $browser; shared_examples_for "all browsers" => sub { it "should open a URL" => sub { ok($browser->open("http://www.google.com/")) }; ... }; describe "Firefox" => sub { before all => sub { $browser = Firefox->new }; it_should_behave_like "all browsers"; it "should have firefox features"; }; describe "Safari" => sub { before all => sub { $browser = Safari->new }; it_should_behave_like "all browsers"; it "should have safari features"; }; =item it_should_behave_like DESCRIPTION Asserts that the thing currently being tested passes all the tests in the example group identified by DESCRIPTION (having previously been defined with a C block). In essence, this is like copying all the tests from the named C block into the current context. See L and L. =item share %HASH Registers C<%HASH> for sharing data between tests and example groups. This lets you share variables with code in different lexical scopes without resorting to using package (i.e. global) variables or jumping through other hoops to circumvent scope problems. Every hash that is Cd refers to the B. Sharing a hash will make its existing contents inaccessible, because afterwards it contains the same data that all other shared hashes contain. The result is that you get a hash with global semantics but with lexical scope (assuming C<%HASH> is a lexical variable). There are a few benefits of using C over using a "regular" global hash. First, you don't have to decide what package the hash will belong to, which is annoying when you have specs in several packages referencing the same shared examples. You also don't have to clutter your examples with colons for fully-qualified names. For example, at my company our specs go in the "ICA::TestCase" hierarchy, and "$ICA::TestCase::Some::Package::variable" is exhausting to both the eyes and the hands. Lastly, using C allows C to provide this functionality without deciding on the variable name for you (and thereby potentially clobbering one of your variables). share %vars; # %vars now refers to the global share share my %vars; # declare and share %vars in one step =item spec_helper FILESPEC Loads the Perl source in C into the current spec's package. If C is relative (no leading slash), it is treated as relative to the spec file (i.e. B the currently running script). This lets you keep helper scripts near the specs they are used by without exercising your File::Spec skills in your specs. # in foo/spec.t spec_helper "helper.pl"; # loads foo/helper.pl spec_helper "helpers/helper.pl"; # loads foo/helpers/helper.pl spec_helper "/path/to/helper.pl"; # loads /path/to/helper.pl =back =head2 Shared example groups This feature comes straight out of RSpec, as does this documentation: You can create shared example groups and include those groups into other groups. Suppose you have some behavior that applies to all editions of your product, both large and small. First, factor out the "shared" behavior: shared_examples_for "all editions" => sub { it "should behave like all editions" => sub { ... }; }; then when you need to define the behavior for the Large and Small editions, reference the shared behavior using the C function. describe "SmallEdition" => sub { it_should_behave_like "all editions"; }; describe "LargeEdition" => sub { it_should_behave_like "all editions"; it "should also behave like a large edition" => sub { ... }; }; C will search for an example group by its description string, in this case, "all editions". Shared example groups may be included in other shared groups: shared_examples_for "All Employees" => sub { it "should be payable" => sub { ... }; }; shared_examples_for "All Managers" => sub { it_should_behave_like "All Employees"; it "should be bonusable" => sub { ... }; }; describe Officer => sub { it_should_behave_like "All Managers"; it "should be optionable"; }; # generates: ok 1 - Officer should be optionable ok 2 - Officer should be bonusable ok 3 - Officer should be payable =head3 Refactoring into files If you want to factor specs into separate files, variable scopes can be tricky. This is especially true if you follow the recommended pattern and give each spec its own package name. C offers a couple of functions that ease this process considerably: L and L. Consider the browsers example from C. A real browser specification would be large, so putting the specs for all browsers in the same file would be a bad idea. So let's say we create C for the shared examples, and give Safari and Firefox C and C, respectively. The problem then becomes: how does the code in C access the C<$browser> variable? In L CODE>, C<$browser> is a lexical variable that is in scope for all the examples. But once those examples are split into multiple files, you would have to use either package global variables or worse, come up with some other hack. This is where C and C come in. # safari.t package Testcase::Safari; use Test::Spec; spec_helper 'all_browsers.pl'; describe "Safari" => sub { share my %vars; before all => sub { $vars{browser} = Safari->new }; it_should_behave_like "all browsers"; it "should have safari features"; }; # firefox.t package Testcase::Firefox; use Test::Spec; spec_helper 'all_browsers.pl'; describe "Firefox" => sub { share my %vars; before all => sub { $vars{browser} = Firefox->new }; it_should_behave_like "all browsers"; it "should have firefox features"; }; # in all_browsers.pl shared_examples_for "all browsers" => sub { # doesn't have to be the same name! share my %t; it "should open a URL" => sub { ok $t{browser}->open("http://www.google.com/"); }; ... }; =head2 Order of execution This example, shamelessly adapted from the RSpec website, gives an overview of the order in which examples run, with particular attention to C and C. describe Thing => sub { before all => sub { # This is run once and only once, before all of the examples # and before any before("each") blocks. }; before each => sub { # This is run before each example. }; before sub { # "each" is the default, so this is the same as before("each") }; it "should do stuff" => sub { ... }; it "should do more stuff" => sub { ... }; after each => sub { # this is run after each example }; after sub { # "each" is the default, so this is the same as after("each") }; after all => sub { # this is run once and only once after all of the examples # and after any after("each") blocks }; }; =head1 SEE ALSO RSpec (http://rspec.info), L, L, L, L. The mocking and stubbing tools are in L. =head1 AUTHOR Philip Garrett =head1 CONTRIBUTING The source code for Test::Spec lives on github: https://github.com/kingpong/perl-Test-Spec If you want to contribute a patch, fork my repository, make your change, and send me a pull request. =head1 SUPPORT If you have found a defect or have a feature request please report an issue at https://github.com/kingpong/perl-Test-Spec/issues. For help using the module, standard Perl support channels like L and L are probably your best bet. =head1 COPYRIGHT & LICENSE Copyright (c) 2010-2011 by Informatics Corporation of America. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Test-Spec-0.51/lib/Test/Spec/Context.pm000644 000765 000024 00000023740 12514760574 020765 0ustar00andyjonesstaff000000 000000 package Test::Spec::Context; use strict; use warnings; ######################################################################## # NO USER-SERVICEABLE PARTS INSIDE. ######################################################################## use Carp (); use List::Util (); use Scalar::Util (); use Test::More (); use Test::Spec qw(*TODO $Debug :constants); use Test::Spec::Example; use Test::Spec::TodoExample; our $_StackDepth = 0; sub new { my $class = shift; my $self = bless {}, $class; if (@_) { my $args = shift; if (@_ || ref($args) ne 'HASH') { Carp::croak "usage: $class->new(\\%args)"; } while (my ($name,$val) = each (%$args)) { $self->$name($val); } } my $this = $self; Scalar::Util::weaken($this); $self->on_enter(sub { $this && $this->_debug(sub { printf STDERR "%s[%s]\n", ' ' x $_StackDepth, $this->_debug_name; $_StackDepth++; }); }); $self->on_leave(sub { $this && $this->_debug(sub { $_StackDepth--; printf STDERR "%s[/%s]\n", ' ' x $_StackDepth, $this->_debug_name; }); }); return $self; } sub clone { my $orig = shift; my $clone = bless { %$orig }, ref($orig); my $orig_contexts = $clone->context_lookup; my $new_contexts = Test::Spec::_ixhash(); while (my ($name,$ctx) = each %$orig_contexts) { my $new_ctx = $ctx->clone; $new_ctx->parent($clone); $new_contexts->{$name} = $new_ctx; } $clone->{_context_lookup} = $new_contexts; return $clone; } # The reference we keep to our parent causes the garbage collector to # destroy the innermost context first, which is what we want. If that # becomes untrue at some point, it will be easy enough to descend the # hierarchy and run the after("all") tests that way. sub DESTROY { my $self = shift; # no need to tear down what was never set up if ($self->_has_run_before_all) { $self->_run_after_all_once; } } sub name { my $self = shift; $self->{_name} = shift if @_; return exists($self->{_name}) ? $self->{_name} : ($self->{_name} = ''); } sub parent { my $self = shift; if (@_) { $self->{_parent} = shift; Scalar::Util::weaken($self->{_parent}) if ref($self->{_parent}); } return $self->{_parent}; } sub class { my $self = shift; $self->{_class} = shift if @_; if ($self->{_class}) { return $self->{_class}; } elsif ($self->parent) { return $self->parent->class; } else { return undef; } } sub context_lookup { my $self = shift; return $self->{_context_lookup} ||= Test::Spec::_ixhash(); } sub before_blocks { my $self = shift; return $self->{_before_blocks} ||= []; } sub after_blocks { my $self = shift; return $self->{_after_blocks} ||= []; } sub tests { my $self = shift; return $self->{_tests} ||= []; } sub on_enter_blocks { my $self = shift; return $self->{_on_enter_blocks} ||= []; } sub on_leave_blocks { my $self = shift; return $self->{_on_leave_blocks} ||= []; } # private attributes sub _has_run_before_all { my $self = shift; $self->{__has_run_before_all} = shift if @_; return $self->{__has_run_before_all}; } sub _has_run_after_all { my $self = shift; $self->{__has_run_after_all} = shift if @_; return $self->{__has_run_after_all}; } sub _debug { my ($self,$code) = @_; return unless $self->_debugging; $code->(); } sub _debug_name { my $self = shift; $self->name || '(anonymous)'; } sub _debugging { my $self = shift; # env var can be set greater than 1 for definition phase debug. # otherwise, any true value means debug execution if ($Debug > 1) { return 1; } elsif ($Debug && $self->class->phase == EXECUTION_PHASE) { return 1; } return; } sub on_enter { my ($self,$callback) = @_; push @{ $self->on_enter_blocks }, $callback; # Handle case where an on_enter was added during a context declaration. # This allows stubs being set up to be valid both in that current Perl # context and later in spec context. if (Test::Spec->in_context($self)) { if (not $self->{_has_run_on_enter}{$callback}++) { $callback->(); } } return; } sub on_leave { my ($self,$callback) = @_; push @{ $self->on_leave_blocks }, $callback; } sub ancestors { my ($self) = @_; return $self->parent ? ($self->parent, $self->parent->ancestors) : (); } sub ancestor_of { my ($self,$other) = @_; return !!List::Util::first { $other == $_ } $self->ancestors; } sub contexts { my $self = shift; my @ctx = values %{ $self->context_lookup }; return wantarray ? @ctx : \@ctx; } # recurse into child contexts to count total tests for a package sub _count_tests { my $self = shift; my @descendant = map { $_->_count_tests } $self->contexts; return @{$self->tests} + List::Util::sum(0, @descendant); } sub _run_callback { my ($self,$type,$pool,@args) = @_; my @subs = map { $_->{code} } grep { $_->{type} eq $type } @$pool; for my $code (@subs) { $code->(@args); } } sub _run_before { my $self = shift; my $type = shift; return $self->_run_callback($type,$self->before_blocks,@_); } sub _run_before_all_once { my $self = shift; return if $self->_has_run_before_all; $self->_has_run_before_all(1); return $self->_run_before('all',@_); } sub _run_after { my $self = shift; my $type = shift; return $self->_run_callback($type,$self->after_blocks,@_); } sub _run_after_all_once { my $self = shift; return if $self->_has_run_after_all; $self->_has_run_after_all(1); return $self->_run_after('all',@_); } # join by spaces and strip leading/extra spaces sub _concat { my ($self,@pieces) = @_; my $str = join(' ', @pieces); $str =~ s{\A\s+|\s+\z}{}s; $str =~ s{\s+}{ }sg; return $str; } sub _materialize_tests { my ($self, $digits, @context_stack) = @_; # include the name of the context in test reports push @context_stack, $self; # need to know how many tests there are, so we can make a lexically # sortable test name using numeric prefix. if (not defined $digits) { my $top_level_sum = List::Util::sum( map { $_->_count_tests } $self->class->contexts ); if ($top_level_sum == 0) { warn "no examples defined in spec package " . $self->class; return; } $digits = 1 + int( log($top_level_sum) / log(10) ); } # Create a test sub like 't001_enough_mucus' my $format = "t%0${digits}d_%s"; for my $t (@{ $self->tests }) { my $description = $self->_concat((map { $_->name } @context_stack), $t->{name}); my $test_number = 1 + scalar($self->class->tests); my $sub_name = sprintf $format, $test_number, $self->_make_safe($description); # create a test subroutine in the correct package my $example; if (!$t->{code} || $t->{todo}) { $example = Test::Spec::TodoExample->new({ name => $sub_name, reason => $t->{tdoo}, description => $description, builder => $self->_builder, }); } else { $example = Test::Spec::Example->new({ name => $sub_name, description => $description, code => $t->{code}, context => $self, builder => $self->_builder, }); } $self->class->add_test($example); } # recurse to child contexts for my $ctx ($self->contexts) { $ctx->_materialize_tests($digits, @context_stack); } } sub _builder { shift->class->builder; } sub _make_safe { my ($self,$str) = @_; return '' unless (defined($str) && length($str)); $str = lc($str); $str =~ s{'}{}g; $str =~ s{\W+}{_}g; $str =~ s{_+}{_}g; return $str; } # Recurse to run the entire on_enter chain, starting from the top. # Propagate exceptions in the same way that _run_on_leave does, for the same # reasons. sub _run_on_enter { my $self = shift; my @errs; if ($self->parent) { eval { $self->parent->_run_on_enter }; push @errs, $@ if $@; } for my $on_enter (@{ $self->on_enter_blocks }) { next if $self->{_has_run_on_enter}{$on_enter}++; eval { $on_enter->() }; push @errs, $@ if $@; } die join("\n", @errs) if @errs; return; } # Recurse to run the entire on_leave chain, starting from the bottom (and in # reverse "unwinding" order). # Propagate all exceptions only after running all on_leave blocks. This allows # mocks (and whatever else) to test their expectations after the test has # completed. sub _run_on_leave { my $self = shift; my @errs; for my $on_leave (reverse @{ $self->on_leave_blocks }) { next if $self->{_has_run_on_leave}{$on_leave}++; eval { $on_leave->() }; push @errs, $@ if $@; } if ($self->parent) { eval { $self->parent->_run_on_leave }; push @errs, $@ if $@; } die join("\n", @errs) if @errs; return; } # for giving individual tests mortal, anonymous contexts that are used for # mocking/stubbing hooks. sub _in_anonymous_context { my ($self,$code) = @_; my $context = Test::Spec::Context->new; $context->name(''); $context->parent($self); $context->class($self->class); $context->contextualize($code); } # Runs $code within a context (specifically, having been wrapped with # on_enter/on_leave setup and teardown). sub contextualize { my ($self,$code) = @_; local $Test::Spec::_Current_Context = $self; local $self->{_has_run_on_enter} = {}; local $self->{_has_run_on_leave} = {}; local $TODO = $TODO; my @errs; eval { $self->_run_on_enter }; push @errs, $@ if $@; if (not @errs) { eval { $code->() }; push @errs, $@ if $@; } # always run despite errors, since on_enter might have set up stuff that # needs to be torn down, before another on_enter died eval { $self->_run_on_leave }; push @errs, $@ if $@; if (@errs) { if ($TODO) { # make it easy for tests to declare todo status, just "$TODO++" $TODO = "(unimplemented)" if $TODO =~ /^\d+$/; # expected to fail Test::More::ok(1); } else { # rethrow die join("\n", @errs); } } return; } # # Copyright (c) 2010-2011 by Informatics Corporation of America. # # This program is free software; you can redistribute it and/or modify it # under the same terms as Perl itself. # 1; Test-Spec-0.51/lib/Test/Spec/Example.pm000644 000765 000024 00000007620 12514760574 020733 0ustar00andyjonesstaff000000 000000 package Test::Spec::Example; # Purpose: represents an `it` block use strict; use warnings; ######################################################################## # NO USER-SERVICEABLE PARTS INSIDE. ######################################################################## use Carp (); use Scalar::Util (); sub new { my ($class, $args) = @_; if (!$args || ref($args) ne 'HASH') { Carp::croak "usage: $class->new(\\%args)"; } my $self = bless {}, $class; foreach my $attr ( qw/name description code builder context/ ) { $self->{$attr} = $args->{$attr} || Carp::croak "$attr missing"; } Scalar::Util::weaken($self->{context}); return $self; } sub name { shift->{name} } sub description { shift->{description} } sub code { shift->{code} } sub builder { shift->{builder} } sub context { shift->{context} } # Build a stack from the starting context # down to the current context sub stack { my ($self) = @_; my $ctx = $self->context; my @ancestors = $ctx; while ( $ctx = $ctx->parent ) { push @ancestors, $ctx; } return reverse(@ancestors); } sub run { my ($self) = @_; # clobber Test::Builder's ok() method just like Test::Class does, # but without screwing up underscores. no warnings 'redefine'; my $orig_builder_ok = \&Test::Builder::ok; local *Test::Builder::ok = sub { my ($builder,$test,$desc) = splice(@_,0,3); $desc ||= $self->description; local $Test::Builder::Level = $Test::Builder::Level+1; $orig_builder_ok->($builder, $test, $desc, @_); }; # Run the test eval { $self->_runner($self->stack) }; # And trap any errors if (my $err = $@) { my $builder = $self->builder; my $description = $self->description; # eval in case stringification overload croaks chomp($err = eval { $err . '' } || 'unknown error'); my ($file,$line); ($file,$line) = ($1,$2) if ($err =~ s/ at (.+?) line (\d+)\.\Z//); # disable ok()'s diagnostics so we can generate a custom TAP message my $old_diag = $builder->no_diag; $builder->no_diag(1); # make sure we can restore no_diag eval { $builder->ok(0, $description) }; my $secondary_err = $@; # no_diag needs a defined value, so double-negate it to get either '' or 1 $builder->no_diag(!!$old_diag); unless ($builder->no_diag) { # emulate Test::Builder::ok's diagnostics, but with more details my ($msg,$diag_fh); if ($builder->in_todo) { $msg = "Failed (TODO)"; $diag_fh = $builder->todo_output; } else { $msg = "Failed"; $diag_fh = $builder->failure_output; } print {$diag_fh} "\n" if $ENV{HARNESS_ACTIVE}; print {$builder->failure_output} qq[# $msg test '$description' by dying:\n]; print {$builder->failure_output} qq[# $err\n]; print {$builder->failure_output} qq[# at $file line $line.\n] if defined($file); } die $secondary_err if $secondary_err; } } sub _runner { my ($self, $ctx, @remainder) = @_; # This recursive closure essentially does this # $outer->contextualize { # $outer->before_each # $inner->contextualize { # $inner->before_each # $anon->contextualize { # $anon->before_each (no-op) # execute test # $anon->after_each (no-op) # } # $inner->after_each # } # $outer->after_each # } # return $ctx->contextualize(sub { $ctx->_run_before_all_once; $ctx->_run_before('each'); if ( @remainder ) { $self->_runner(@remainder); } else { $ctx->_in_anonymous_context($self->code); } $ctx->_run_after('each'); # "after 'all'" only happens during context destruction (DEMOLISH). # This is the only way I can think to make this work right # in the case that only specific test methods are run. # Otherwise, the global teardown would only happen when you # happen to run the last test of the context. }); } 1; Test-Spec-0.51/lib/Test/Spec/Mocks.pm000644 000765 000024 00000072513 12514760721 020411 0ustar00andyjonesstaff000000 000000 package Test::Spec::Mocks; use strict; use warnings; use Carp (); use Scalar::Util (); use Test::Deep::NoTest (); require Test::Spec; our @EXPORT_OK = qw(stubs stub expects mock); our @EXPORT = @EXPORT_OK; our $Debug = $ENV{TEST_SPEC_MOCKS_DEBUG}; our %To_Universal = map { $_ => 1 } qw(stubs expects); # # use Test::Spec::Mocks (); # nothing (import never called) # use Test::Spec::Mocks; # stubs,expects=>UNIVERSAL, stub,mock=>caller # use Test::Spec::Mocks qw(stubs stub); # stubs=>UNIVERSAL, stub=>caller # sub import { my $srcpkg = shift; my $callpkg = caller(0); my @syms = @_ ? @_ : @EXPORT; SYMBOL: for my $orig_sym (@syms) { no strict 'refs'; # accept but ignore leading '&', we only export subs (my $sym = $orig_sym) =~ s{\A\&}{}; if (not grep { $_ eq $sym } @EXPORT_OK) { Carp::croak("\"$orig_sym\" is not exported by the $srcpkg module"); } my $destpkg = $To_Universal{$sym} ? 'UNIVERSAL' : $callpkg; my $src = join("::", $srcpkg, $sym); my $dest = join("::", $destpkg, $sym); if (defined &$dest) { if (*{$dest}{CODE} == *{$src}{CODE}) { # already exported, ignore request next SYMBOL; } else { Carp::carp("Clobbering existing \"$orig_sym\" in package $destpkg"); } } *$dest = \&$src; } } # Foo->stubs("name") # empty return value # Foo->stubs("name" => "value") # static return value # Foo->stubs("name" => sub { "value" }) # dynamic return value sub stubs { _install('Test::Spec::Mocks::Stub', @_); } # Foo->expects("name") # empty return value sub expects { if (@_ != 2 || ref($_[1])) { Carp::croak "usage: ->expects('foo')"; } _install('Test::Spec::Mocks::Expectation', @_); } sub _install { my $stub_class = shift; my ($caller) = ((caller(1))[3] =~ /.*::(.*)/); my $target = shift; my @methods; # normalize name/value pairs to name/subroutine pairs if (@_ > 0 && @_ % 2 == 0) { # list of name/value pairs while (my ($name,$value) = splice(@_,0,2)) { push @methods, { name => $name, value => $value }; } } elsif (@_ == 1 && ref($_[0]) eq 'HASH') { # hash ref of name/value pairs my $args = shift; while (my ($name,$value) = each %$args) { push @methods, { name => $name, value => $value }; } } elsif (@_ == 1 && !ref($_[0])) { # name only push @methods, { name => shift }; } else { Carp::croak "usage: $caller('foo'), $caller(foo=>'bar') or $caller({foo=>'bar'})"; } my $context = Test::Spec->current_context || Carp::croak "Test::Spec::Mocks only works in conjunction with Test::Spec"; my $retval; # for chaining. last wins. for my $method (@methods) { my $stub = $stub_class->new({ target => $target, method => $method->{name} }); $stub->returns($method->{value}) if exists $method->{value}; $context->on_enter(sub { $stub->setup }); $context->on_leave(sub { $stub->teardown }); $retval = $stub; } return $retval; } # $stub_object = stub(); # $stub_object = stub(method => 'result'); # $stub_object = stub(method => sub { 'result' }); sub stub { my $args; if (@_ % 2 == 0) { $args = { @_ }; } elsif (@_ == 1 && ref($_[0]) eq 'HASH') { $args = shift; } else { Carp::croak "usage: stub(%HASH) or stub(\\%HASH)"; } my $blank = _make_mock(); $blank->stubs($args) if @_; return $blank; } # $mock_object = mock(); $mock_object->expects(...) sub mock { Carp::croak "usage: mock()" if @_; return _make_mock(); } { package Test::Spec::Mocks::MockObject; # this page intentionally left blank } # keep this out of the MockObject class, so it has a blank slate sub _make_mock { return bless({}, 'Test::Spec::Mocks::MockObject'); } { package Test::Spec::Mocks::Expectation; sub new { my $class = shift; my $self = bless {}, $class; # expect to be called exactly one time in the default case $self->once; if (@_) { my $args = shift; if (@_ || ref($args) ne 'HASH') { Carp::croak "usage: $class->new(\\%args)"; } while (my ($name,$val) = each (%$args)) { if ($name eq 'target') { $name = '_target'; } elsif ($name eq 'method') { $name = '_method'; } $self->$name($val); } } return $self; } sub _target { my $self = shift; $self->{__target} = shift if @_; return $self->{__target}; } sub _target_class { my $self = shift; $self->{__target_class} = shift if @_; return $self->{__target_class}; } sub _original_code { my $self = shift; $self->{__original_code} = shift if @_; return $self->{__original_code}; } sub _method { my $self = shift; $self->{__method} = shift if @_; return $self->{__method}; } sub _retval { my $self = shift; $self->{__retval} = shift if @_; return $self->{__retval} ||= sub {}; } sub _canceled { my $self = shift; $self->{__canceled} = shift if @_; if (not exists $self->{__canceled}) { $self->{__canceled} = 0; } return $self->{__canceled}; } sub cancel { my $self = shift; $self->_canceled(1); return; } sub _call_count { my $self = shift; if (not defined $self->{__call_count}) { $self->{__call_count} = 0; } return $self->{__call_count}; } sub _called { my $self = shift; my @args = @_; $self->_given_args(\@args); $self->{__call_count} = $self->_call_count + 1; } sub _check_call_count { my $self = shift; $self->{__check_call_count} = shift if @_; return $self->{__check_call_count}; } # sets _retval to a subroutine that returns the desired value, which # lets us allow users to pass their own subroutines as well as # immediate values. sub returns { my $self = shift; if (@_ == 1 && ref($_[0]) eq 'CODE') { # no boxing necessary $self->_retval(shift); } elsif (@_ == 1) { my $val = shift; $self->_retval(sub { return $val; }); } else { my @list = @_; $self->_retval(sub { return @list; }); } return $self; } # # ARGUMENT MATCHING # sub with { my $self = shift; return $self->with_eq(@_); } sub with_eq { my $self = shift; $self->_eq_args(\@_); return $self; } sub with_deep { my $self = shift; $self->_deep_args(\@_); return $self; } sub _eq_args { my $self = shift; $self->{__eq_args} = shift if @_; return $self->{__eq_args} ||= undef; } sub _deep_args { my $self = shift; $self->{__deep_args} = shift if @_; return $self->{__deep_args} ||= undef; } sub _given_args { my $self = shift; $self->{__given_args} = shift if @_; return $self->{__given_args} ||= undef; } sub _check_eq_args { my $self = shift; return unless defined $self->_eq_args; return unless $self->_call_count; if (!defined $self->_given_args || scalar(@{$self->_eq_args}) != scalar(@{$self->_given_args})) { return "Number of arguments don't match expectation"; } my @problems = (); for my $i (0..$#{$self->_eq_args}) { my $a = $self->_eq_args->[$i]; my $b = $self->_given_args->[$i]; unless ($self->_match_arguments($a, $b)) { $a = 'undef' unless defined $a; $b = 'undef' unless defined $b; push @problems, sprintf("Expected argument in position %d to be '%s', but it was '%s'", $i, $a, $b); } } return @problems; } sub _match_arguments { my $self = shift; my ($a, $b) = @_; return 1 if !defined $a && !defined $b; return unless defined $a && defined $b; return $a eq $b; } sub _check_deep_args { my $self = shift; return unless defined $self->_deep_args; return unless $self->_call_count; my @got = $self->_given_args; my @expected = $self->_deep_args; my ($same, $stack) = Test::Deep::cmp_details(\@got, \@expected); if ( !$same ) { return Test::Deep::deep_diag($stack); } return; # args are the same } # # EXCEPTIONS # sub raises { my $self = shift; my ($message) = @_; $self->_exception($message); return $self; } sub _exception { my $self = shift; $self->{__exception} = shift if @_; return $self->{__exception} ||= undef; } # # CALL COUNT CHECKS # sub _times { my ($self,$n,$msg,@params) = @_; my $times = $n == 1 ? "time" : "times"; $msg =~ s{%times}{$times}g; return @params ? sprintf($msg,@params) : $msg; } # ensures that the expected method is called exactly N times sub exactly { my $self = shift; my $n_times = shift; if (!defined($n_times) || $n_times !~ /^\A\d+\z/) { Carp::croak "Usage: ->exactly(INTEGER)"; } $self->_check_call_count(sub { if ($self->_call_count != $n_times) { return $self->_times($n_times, "exactly $n_times %times"); } }); $self; } # ensures that the expected method is never called sub never { my $self = shift; return $self->exactly(0); } # ensures that the expected method is called exactly one time sub once { my $self = shift; $self->_check_call_count(sub { if ($self->_call_count != 1) { return "exactly once"; } }); $self; } # ensures that the expected method is called at least N times sub at_least { my $self = shift; my $n_times = shift; if (!defined($n_times) || $n_times !~ /^\A\d+\z/) { Carp::croak "Usage: ->at_least(INTEGER)"; } $self->_check_call_count(sub { if ($self->_call_count < $n_times) { return $self->_times($n_times, "at least $n_times %times"); } }); $self; } sub at_least_once { my $self = shift; return $self->at_least(1); } # ensures that the expected method is called at most N times sub at_most { my $self = shift; my $n_times = shift; if (!defined($n_times) || $n_times !~ /^\A\d+\z/) { Carp::croak "Usage: ->at_most(INTEGER)"; } $self->_check_call_count(sub { if ($self->_call_count > $n_times) { return $self->_times($n_times, "at most $n_times %times"); } }); $self; } sub at_most_once { my $self = shift; return $self->at_most(1); } sub maybe { my $self = shift; return $self->at_most_once; } sub any_number { my $self = shift; $self->_check_call_count(sub {}); $self; } # dummy method for syntactic sugar sub times { my $self = shift; $self; } sub verify { my $self = shift; my @msgs = $self->problems; die join("\n", @msgs) if @msgs; return 1; } sub problems { my $self = shift; my @prob; if (my $message = $self->_check_call_count->()) { push @prob, $self->_times( $self->_call_count, "expected %s to be called %s, but it was called %d %times\n", $self->_method, $message, $self->_call_count, ); } for my $message ($self->_check_eq_args) { push @prob, $message; } for my $message ($self->_check_deep_args) { push @prob, $message; } return @prob; } sub setup { my $self = shift; if ($Debug) { print STDERR "Setting up stub for @{[ $self->_target ]}->@{[ $self->_method ]}\n"; } # both these methods set _replaced_qualified_name and # _original_code, which we'll use in teardown() if (ref $self->_target) { $self->_replace_instance_method; } else { $self->_replace_class_method; } } sub teardown { my $self = shift; if ($Debug) { print STDERR "Tearing down stub for @{[ $self->_target ]}->@{[ $self->_method ]}\n"; } no strict 'refs'; no warnings 'redefine'; if ($self->_original_code) { *{ $self->_replaced_qualified_name } = $self->_original_code; } else { # avoid nuking aliases (including our _retval) by assigning a blank sub first. # this technique stolen from ModPerl::Util::unload_package_pp *{ $self->_replaced_qualified_name } = sub {}; # Simply undefining &foo breaks in some cases by leaving some Perl # droppings that cause subsequent calls to this function to die with # "Not a CODE reference". It sounds harmless until Perl tries to # call this method in an inheritance chain. Using Package::Stash solves # that problem. It actually clones the original glob, leaving out the # part being deleted. require Package::Stash; my $stash = Package::Stash->new($self->_target_class); $stash->remove_symbol('&' . $self->_method); } $self->verify unless $self->_canceled; } sub _replaced_qualified_name { my $self = shift; return join("::", $self->_target_class, $self->_method); } sub _replace_instance_method { no strict 'refs'; no warnings qw(uninitialized); my $self = shift; my $target = $self->_target; my $class = ref($target); my $dest = join("::", $class, $self->_method); my $original_method = $class->can($self->_method); # save to be restored later $self->_target_class($class); $self->_original_code($original_method); $self->_install($dest => sub { # Use refaddr() to prevent an overridden equality operator from # making two objects appear equal when they are only equivalent. if (Scalar::Util::refaddr($_[0]) == Scalar::Util::refaddr($target)) { # do extreme late binding here, so calls to returns() after the # mock has already been installed will take effect. my @args = @_; shift @args; $self->_called(@args); die $self->_exception if $self->_exception; return $self->_retval->(@_); } elsif (!$original_method) { # method didn't exist before, mimic Perl's behavior Carp::croak sprintf("Can't locate object method \"%s\" " . "via package \"%s\"", $self->_method, $class); } else { # run the original as if we were never here. # to that end, use goto to prevent the extra stack frame goto $original_method; } }); } sub _replace_class_method { no strict 'refs'; my $self = shift; my $dest = join("::", $self->_target, $self->_method); $self->_target_class($self->_target); $self->_original_code(defined(&$dest) ? \&$dest : undef); $self->_install($dest => sub { # do extreme late binding here, so calls to returns() after the # mock has already been installed will take effect. my @args = @_; shift @args; $self->_called(@args); die $self->_exception if $self->_exception; $self->_retval->(@_); }); } sub _install { my ($self,$dest,$code) = @_; if ($self->_original_code) { # avoid "Prototype mismatch" # this code borrowed/enhanced from Moose::Exporter if (defined(my $proto = prototype $self->_original_code)) { # XXX - Perl's prototype sucks. Use & to make set_prototype # ignore the fact that we're passing "private variables" &Scalar::Util::set_prototype($code, $proto); } } no strict 'refs'; no warnings 'redefine'; *$dest = $code; } } { package Test::Spec::Mocks::Stub; use base qw(Test::Spec::Mocks::Expectation); # A stub is a special case of expectation that doesn't actually # expect anything. sub new { my $class = shift; my $self = $class->SUPER::new(@_); $self->at_least(0); return $self; } } 1; =head1 NAME Test::Spec::Mocks - Object Simulation Plugin for Test::Spec =head1 SYNOPSIS use Test::Spec; use base qw(Test::Spec); use My::RSS::Tool; # this is what we're testing use LWP::UserAgent; describe "RSS tool" => sub { it "should fetch and parse an RSS feed" => sub { my $xml = load_rss_fixture(); LWP::Simple->expects('get')->returns($xml); # calls LWP::Simple::get, but returns our $xml instead my @stories = My::RSS::Tool->run; is_deeply(\@stories, load_stories_fixture()); }; }; =head1 DESCRIPTION Test::Spec::Mocks is a plugin for Test::Spec that provides mocking and stubbing of objects, individual methods and plain subroutines on both object instances and classes. This module is inspired by and heavily borrows from Mocha, a library for the Ruby programming language. Mocha itself is inspired by JMock. Mock objects provide a way to simulate the behavior of real objects, while providing consistent, repeatable results. This is very useful when you need to test a function whose results are dependent upon an external factor that is normally uncontrollable (like the time of day). Mocks also allow you to test your code in isolation, a tenet of unit testing. There are many other reasons why mock objects might come in handy. See the L article at Wikipedia for lots more examples and more in-depth coverage of the philosophy behind object mocking. =head2 Ecosystem Test::Spec::Mocks is currently only usable from within tests built with the Test::Spec BDD framework. =head2 Terminology Familiarize yourself with these terms: =over 4 =item * Stub object A stub object is an object created specifically to return canned responses for a specific set of methods. These are created with the L function. =item * Mock object Mock objects are similar to stub objects, but are programmed with both prepared responses and expectations for how they will be called. If the expectations are not met, they raise an exception to indicate that the test failed. Mock objects are created with the L function. =item * Stubbed method Stubbed methods temporarily replace existing methods on a class or object instance. This is useful when you only want to override a subset of an object or class's behavior. For example, you might want to override the C method of a DBI handle so it doesn't make changes to your database, but still need the handle to respond as usual to the C method. You'll stub methods using the Lstubs($method_name)"> method. =item * Mocked method If you've been reading up to this point, this will be no surprise. Mocked methods are just like stubbed methods, but they come with expectations that will raise an exception if not met. For example, you can mock a C method on an object to ensure it is called by the code you are testing, while preventing the data from actually being committed to disk in your test. Use the Lexpects($method)"> method to create mock methods. =item * "stub", "mock" Depending on context, these can refer to stubbed objects and methods, or mocked objects and methods, respectively. =back =head2 Using stub objects (anonymous stubs) Sometimes the code you're testing requires that you pass it an object that conforms to a specific interface. For example, you are testing a console prompting library, but you don't want to require a real person to stand by, waiting to type answers into the console. The library requires an object that returns a string when the C method is called. You could create a class specifically for returning test console input. But why do that? You can create a stub object in one line: describe "An Asker" => sub { my $asker = Asker->new; it "returns true when a yes_or_no question is answered 'yes'" => sub { my $console_stub = stub(read_line => "yes"); # $console_stub->read_line returns "yes" ok( $asker->yes_or_no($console_stub, "Am I awesome?") ); }; it "returns false when a yes_or_no question is answered 'no'" => sub { my $console_stub = stub(read_line => "no"); ok( ! $asker->yes_or_no($console_stub, "Am I second best?") ); }; }; Stubs can also take subroutine references. This is useful when the behavior you need to mimic is a little more complex. it "keeps asking until it gets an answer" => sub { my @answers = (undef, "yes"); my $console_stub = stub(read_line => sub { shift @answers }); # when console_stub is called the first time, it returns undef # the second time returns "yes" ok( $asker->yes_or_no($console_stub, "Do I smell nice?") ); }; =head2 Using mock objects If you want to take your tests one step further, you can use mock objects instead of stub objects. Mocks ensure the methods you expect to be called actually are called. If they aren't, the mock will raise an exception which causes your test to fail. In this example, we are testing that C is called once and only once (the default for mocks). it "returns true when a yes_or_no question is answered 'yes'" => sub { my $console_mock = mock(); $console_mock->expects('read_line') ->returns("yes"); # $console_mock->read_line returns "yes" ok( $asker->yes_or_no($console_mock, "Am I awesome?") ); }; If Asker's C method doesn't call C on our mock exactly one time, the test would fail with a message like: expected read_line to be called exactly 1 time, but it was called 0 times You can specify how many times your mock should be called with "exactly": it "keeps asking until it gets an answer" => sub { my @answers = (undef, "yes"); my $console_mock = mock(); $console_mock->expects('read_line') ->returns(sub { shift @answers }) ->exactly(2); # when console_mock is called the first time, it returns undef # the second time returns "yes" ok( $asker->yes_or_no($console_mock, "Do I smell nice?") ); }; If you want something more flexible than "exactly", you can choose from "at_least", "at_most", "any_number" and others. See L. =head2 Stubbing methods Sometimes you want to override just a small subset of an object's behavior. describe "The old audit system" => sub { my $dbh; before sub { $dbh = SomeExternalClass->get_dbh }; it "executes the expected sql" => sub { my $sql; $dbh->stubs(do => sub { $sql = shift; return 1 }); # $dbh->do("foo") now sets $sql to "foo" # $dbh->quote still does what it normally would audit_event($dbh, "server crash, oh noes!!"); like( $sql, qr/insert into audit_event.*'server crash, oh noes!!!'/ ); }; }; You can also stub class methods: # 1977-05-26T14:11:55 my $event_datetime = DateTime->new(from_epoch => 0xdeafcab); it "should tag each audit event with the current time" => sub { DateTime->stubs('now' => sub { $event_datetime }); is( audit_timestamp(), '19770526.141155' ); }; =head2 Mocking methods Mocked methods are to stubbed methods as mock objects are to stub objects. it "executes the expected sql" => sub { $dbh->expects('do')->returns(sub { $sql = shift; return 1 }); # $dbh->do("foo") now sets $sql to "foo" # $dbh->quote still does what it normally would audit_event($dbh, "server crash, oh noes!!"); like( $sql, qr/insert into audit_event.*'server crash, oh noes!!!'/ ); # if audit_event doesn't call $dbh->do exactly once, KABOOM! }; =head1 CONSTRUCTORS =over 4 =item stub() =item stub($method_name => $result, ...) =item stub($method_name => sub { $result }, ...) =item stub({ $method_name => $result, ... }) Returns a new anonymous stub object. Takes a list of C<$method_name>/C<$result> pairs or a reference to a hash containing the same. Each C<$method_name> listed is stubbed to return the associated value (C<$result>); or if the value is a subroutine reference, it is stubbed in-place (the subroutine becomes the method). Examples: # A blank object with no methods. # Gives a true response to ref() and blessed(). my $blank = stub(); # Static responses to width() and height(): my $rect = stub(width => 5, height => 5); # Dynamic response to area(): my $radius = 1.0; my $circle_stub = stub(area => sub { PI * $radius * $radius }); You can also stub more methods, just like with any other object: my $rect = stub(width => 5, height => 5); $rect->stubs(area => sub { my $self = shift; $self->width * $self->height }); =item $thing->stubs($method_name) =item $thing->stubs($method_name => $result) =item $thing->stubs($method_name => sub { $result }) =item $thing->stubs({ $method_name => $result }) Stubs one or more methods on an existing class or instance, C<$thing>. If passed only one (non-hash) argument, it is interpreted as a method name. The return value of the stubbed method will be C. Otherwise, the arguments are a list of C<$method_name> and C<$result> pairs, either as a flat list or as a hash reference. Each method is installed onto C<$thing>, and returns the specified result. If the result is a subroutine reference, it will be called for every invocation of the method. =item mock() Returns a new blank, anonymous mock object, suitable for mocking methods with Lexpects($method)">. my $rect = mock(); $rect->expects('area')->returns(100); =item $thing->expects($method) Installs a mock method named C<$method> onto the class or object C<$thing> and returns an Test::Spec::Mocks::Expectation object, which you can use to set the return value with C and other expectations. By default, the method is expected to be called L. If the expectation is not met before the enclosing example completes, the mocked method will raise an exception that looks something like: expected foo to be called exactly 1 time, but it was called 0 times =back =head1 EXPECTATION ADJUSTMENT METHODS These are methods of the Test::Spec::Mocks::Expectation class, which you'll receive by calling C on a class or object instance. =over 4 =item returns( $result ) =item returns( @result ) =item returns( \&callback ) Configures the mocked method to return the specified result when called. If passed a subroutine reference, the subroutine will be executed when the method is called, and the result is the return value. $rect->expects('height')->returns(5); # $rect->height ==> 5 @points = ( [0,0], [1,0], [1,1], [1,0] ); $rect->expects('points')->returns(@points); # (@p = $rect->points) ==> ( [0,0], [1,0], [1,1], [1,0] ) # ($p = $rect->points) ==> 4 @points = ( [0,0], [1,0], [1,1], [1,0] ); $rect->expects('next_point')->returns(sub { shift @points }); # $rect->next_point ==> [0,0] # $rect->next_point ==> [1,0] # ... =item exactly($N) Configures the mocked method so that it must be called exactly $N times. =item never Configures the mocked method so that it must never be called. =item once Configures the mocked method so that it must be called exactly one time. =item at_least($N) Configures the mocked method so that it must be called at least $N times. =item at_least_once Configures the mocked method so that it must be called at least 1 time. This is just syntactic sugar for C. =item at_most($N) Configures the mocked method so that it must be called no more than $N times. =item at_most_once Configures the mocked method so that it must be called either zero or 1 times. =item maybe An alias for L. =item any_number Configures the mocked method so that it can be called zero or more times. =item times A syntactic sugar no-op: $io->expects('print')->exactly(3)->times; I =item with(@arguments) / with_eq(@arguments) Configures the mocked method so that it must be called with arguments as specified. The arguments will be compared using the "eq" operator, so it works for most scalar values with no problem. If you want to check objects here, they must be the exact same instance or you must overload the "eq" operator to provide the behavior you desire. =item with_deep(@arguments) Similar to C except the arguments are compared using L: scalars are compared by value, arrays and hashes must have the same elements and references must be blessed into the same class. $cache->expects('set') ->with_deep($customer_id, { name => $customer_name }); Use L's comparison functions for more flexibility: use Test::Deep::NoTest (); $s3->expects('put') ->with_deep('test-bucket', 'my-doc', Test::Deep::ignore()); =item raises($exception) Configures the mocked method so that it raises C<$exception> when called. =back =head1 OTHER EXPECTATION METHODS =over 4 =item verify Allows you to verify manually that the expectation was met. If the expectation has not been met, the method dies with an error message containing specifics of the failure. Returns true otherwise. =item problems If the expectation has not been met, returns a list of problem description strings. Otherwise, returns an empty list. =back =head1 KNOWN ISSUES =over 4 =item Memory leaks Because of the way the mock objects (C, C, C, and C) are integrated into the Test::Spec runtime they will leak memory. It is not recommended to use the Test::Spec mocks in any long-running program. Patches welcome. =back =head1 SEE ALSO There are other less sugary mocking systems for Perl, including L and L. This module is a plugin for L. It is inspired by L. The Wikipedia article L is very informative. =head1 AUTHOR Philip Garrett, =head1 COPYRIGHT & LICENSE Copyright (c) 2011 by Informatics Corporation of America. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut Test-Spec-0.51/lib/Test/Spec/SharedHash.pm000644 000765 000024 00000000430 12501407600 021322 0ustar00andyjonesstaff000000 000000 package Test::Spec::SharedHash; use strict; use warnings; use Tie::Hash; use base qw(Tie::StdHash); # a semaphore our $Initialized = 0; our %STASH; sub TIEHASH { my $class = shift; my $ref = \%STASH; bless $ref, $class; return $ref; } sub reset { %STASH = (); } 1; Test-Spec-0.51/lib/Test/Spec/TodoExample.pm000644 000765 000024 00000001546 12514760574 021562 0ustar00andyjonesstaff000000 000000 package Test::Spec::TodoExample; # Purpose: represents a `xit` block (ie. a pending/todo test) use strict; use warnings; use Test::Spec qw(*TODO); sub new { my ($class, $args) = @_; my $self = bless {}, $class; $self->{name} = $args->{name}; $self->{description} = $args->{description}; $self->{reason} = $args->{reason} || '(unimplemented)'; $self->{builder} = $args->{builder}; return $self; } # Attributes sub name { shift->{name} } sub description { shift->{description} } sub reason { shift->{reason} } sub builder { shift->{builder} } # Methods sub run { my ($self) = @_; local $TODO = $self->reason; my $builder = $self->builder; $builder->todo_start($TODO); $builder->ok(1, $self->description); # XXX: could fail the TOOD (or even run it?) $builder->todo_end(); } 1;