1package Test::Spec::Mocks; 2use strict; 3use warnings; 4use Carp (); 5use Scalar::Util (); 6use Test::Deep::NoTest (); 7 8require Test::Spec; 9 10our @EXPORT_OK = qw(stubs stub expects mock); 11our @EXPORT = @EXPORT_OK; 12 13our $Debug = $ENV{TEST_SPEC_MOCKS_DEBUG}; 14 15our %To_Universal = map { $_ => 1 } qw(stubs expects); 16 17# 18# use Test::Spec::Mocks (); # nothing (import never called) 19# use Test::Spec::Mocks; # stubs,expects=>UNIVERSAL, stub,mock=>caller 20# use Test::Spec::Mocks qw(stubs stub); # stubs=>UNIVERSAL, stub=>caller 21# 22sub import { 23 my $srcpkg = shift; 24 my $callpkg = caller(0); 25 my @syms = @_ ? @_ : @EXPORT; 26 SYMBOL: for my $orig_sym (@syms) { 27 no strict 'refs'; 28 # accept but ignore leading '&', we only export subs 29 (my $sym = $orig_sym) =~ s{\A\&}{}; 30 if (not grep { $_ eq $sym } @EXPORT_OK) { 31 Carp::croak("\"$orig_sym\" is not exported by the $srcpkg module"); 32 } 33 my $destpkg = $To_Universal{$sym} ? 'UNIVERSAL' : $callpkg; 34 my $src = join("::", $srcpkg, $sym); 35 my $dest = join("::", $destpkg, $sym); 36 if (defined &$dest) { 37 if (*{$dest}{CODE} == *{$src}{CODE}) { 38 # already exported, ignore request 39 next SYMBOL; 40 } 41 else { 42 Carp::carp("Clobbering existing \"$orig_sym\" in package $destpkg"); 43 } 44 } 45 *$dest = \&$src; 46 } 47} 48 49# Foo->stubs("name") # empty return value 50# Foo->stubs("name" => "value") # static return value 51# Foo->stubs("name" => sub { "value" }) # dynamic return value 52 53sub stubs { 54 _install('Test::Spec::Mocks::Stub', @_); 55} 56 57# Foo->expects("name") # empty return value 58sub expects { 59 if (@_ != 2 || ref($_[1])) { 60 Carp::croak "usage: ->expects('foo')"; 61 } 62 _install('Test::Spec::Mocks::Expectation', @_); 63} 64 65sub _install { 66 my $stub_class = shift; 67 my ($caller) = ((caller(1))[3] =~ /.*::(.*)/); 68 69 my $target = shift; 70 my @methods; 71 72 # normalize name/value pairs to name/subroutine pairs 73 if (@_ > 0 && @_ % 2 == 0) { 74 # list of name/value pairs 75 while (my ($name,$value) = splice(@_,0,2)) { 76 push @methods, { name => $name, value => $value }; 77 } 78 } 79 elsif (@_ == 1 && ref($_[0]) eq 'HASH') { 80 # hash ref of name/value pairs 81 my $args = shift; 82 while (my ($name,$value) = each %$args) { 83 push @methods, { name => $name, value => $value }; 84 } 85 } 86 elsif (@_ == 1 && !ref($_[0])) { 87 # name only 88 push @methods, { name => shift }; 89 } 90 else { 91 Carp::croak "usage: $caller('foo'), $caller(foo=>'bar') or $caller({foo=>'bar'})"; 92 } 93 94 my $context = Test::Spec->current_context 95 || Carp::croak "Test::Spec::Mocks only works in conjunction with Test::Spec"; 96 my $retval; # for chaining. last wins. 97 98 for my $method (@methods) { 99 my $stub = $stub_class->new({ target => $target, method => $method->{name} }); 100 $stub->returns($method->{value}) if exists $method->{value}; 101 $context->on_enter(sub { $stub->setup }); 102 $context->on_leave(sub { $stub->teardown }); 103 $retval = $stub; 104 } 105 106 return $retval; 107} 108 109# $stub_object = stub(); 110# $stub_object = stub(method => 'result'); 111# $stub_object = stub(method => sub { 'result' }); 112sub stub { 113 my $args; 114 if (@_ % 2 == 0) { 115 $args = { @_ }; 116 } 117 elsif (@_ == 1 && ref($_[0]) eq 'HASH') { 118 $args = shift; 119 } 120 else { 121 Carp::croak "usage: stub(%HASH) or stub(\\%HASH)"; 122 } 123 my $blank = _make_mock(); 124 $blank->stubs($args) if @_; 125 return $blank; 126} 127 128# $mock_object = mock(); $mock_object->expects(...) 129sub mock { 130 Carp::croak "usage: mock()" if @_; 131 return _make_mock(); 132} 133 134{ 135 package Test::Spec::Mocks::MockObject; 136 # this page intentionally left blank 137} 138 139# keep this out of the MockObject class, so it has a blank slate 140sub _make_mock { 141 return bless({}, 'Test::Spec::Mocks::MockObject'); 142} 143 144{ 145 package Test::Spec::Mocks::Expectation; 146 147 sub new { 148 my $class = shift; 149 my $self = bless {}, $class; 150 151 # expect to be called exactly one time in the default case 152 $self->once; 153 154 if (@_) { 155 my $args = shift; 156 if (@_ || ref($args) ne 'HASH') { 157 Carp::croak "usage: $class->new(\\%args)"; 158 } 159 while (my ($name,$val) = each (%$args)) { 160 if ($name eq 'target') { 161 $name = '_target'; 162 } 163 elsif ($name eq 'method') { 164 $name = '_method'; 165 } 166 $self->$name($val); 167 } 168 } 169 170 return $self; 171 } 172 173 sub _target { 174 my $self = shift; 175 $self->{__target} = shift if @_; 176 return $self->{__target}; 177 } 178 179 sub _target_class { 180 my $self = shift; 181 $self->{__target_class} = shift if @_; 182 return $self->{__target_class}; 183 } 184 185 sub _original_code { 186 my $self = shift; 187 $self->{__original_code} = shift if @_; 188 return $self->{__original_code}; 189 } 190 191 sub _method { 192 my $self = shift; 193 $self->{__method} = shift if @_; 194 return $self->{__method}; 195 } 196 197 sub _retval { 198 my $self = shift; 199 $self->{__retval} = shift if @_; 200 return $self->{__retval} ||= sub {}; 201 } 202 203 sub _canceled { 204 my $self = shift; 205 $self->{__canceled} = shift if @_; 206 if (not exists $self->{__canceled}) { 207 $self->{__canceled} = 0; 208 } 209 return $self->{__canceled}; 210 } 211 212 sub cancel { 213 my $self = shift; 214 $self->_canceled(1); 215 return; 216 } 217 218 sub _call_count { 219 my $self = shift; 220 if (not defined $self->{__call_count}) { 221 $self->{__call_count} = 0; 222 } 223 return $self->{__call_count}; 224 } 225 226 sub _called { 227 my $self = shift; 228 my @args = @_; 229 $self->_given_args(\@args); 230 $self->{__call_count} = $self->_call_count + 1; 231 } 232 233 sub _check_call_count { 234 my $self = shift; 235 $self->{__check_call_count} = shift if @_; 236 return $self->{__check_call_count}; 237 } 238 239 # sets _retval to a subroutine that returns the desired value, which 240 # lets us allow users to pass their own subroutines as well as 241 # immediate values. 242 sub returns { 243 my $self = shift; 244 if (@_ == 1 && ref($_[0]) eq 'CODE') { 245 # no boxing necessary 246 $self->_retval(shift); 247 } 248 elsif (@_ == 1) { 249 my $val = shift; 250 $self->_retval(sub { 251 return $val; 252 }); 253 } 254 else { 255 my @list = @_; 256 $self->_retval(sub { 257 return @list; 258 }); 259 } 260 return $self; 261 } 262 263 # 264 # ARGUMENT MATCHING 265 # 266 267 sub with { 268 my $self = shift; 269 return $self->with_eq(@_); 270 } 271 272 sub with_eq { 273 my $self = shift; 274 $self->_eq_args(\@_); 275 return $self; 276 } 277 278 sub with_deep { 279 my $self = shift; 280 $self->_deep_args(\@_); 281 return $self; 282 } 283 284 sub _eq_args { 285 my $self = shift; 286 $self->{__eq_args} = shift if @_; 287 return $self->{__eq_args} ||= undef; 288 } 289 290 sub _deep_args { 291 my $self = shift; 292 $self->{__deep_args} = shift if @_; 293 return $self->{__deep_args} ||= undef; 294 } 295 296 sub _given_args { 297 my $self = shift; 298 $self->{__given_args} = shift if @_; 299 return $self->{__given_args} ||= undef; 300 } 301 302 sub _check_eq_args { 303 my $self = shift; 304 return unless defined $self->_eq_args; 305 return unless $self->_call_count; 306 307 if (!defined $self->_given_args || scalar(@{$self->_eq_args}) != scalar(@{$self->_given_args})) { 308 return "Number of arguments don't match expectation"; 309 } 310 my @problems = (); 311 for my $i (0..$#{$self->_eq_args}) { 312 my $a = $self->_eq_args->[$i]; 313 my $b = $self->_given_args->[$i]; 314 unless ($self->_match_arguments($a, $b)) { 315 $a = 'undef' unless defined $a; 316 $b = 'undef' unless defined $b; 317 push @problems, sprintf("Expected argument in position %d to be '%s', but it was '%s'", $i, $a, $b); 318 } 319 } 320 return @problems; 321 } 322 323 sub _match_arguments { 324 my $self = shift; 325 my ($a, $b) = @_; 326 return 1 if !defined $a && !defined $b; 327 return unless defined $a && defined $b; 328 return $a eq $b; 329 } 330 331 sub _check_deep_args { 332 my $self = shift; 333 return unless defined $self->_deep_args; 334 return unless $self->_call_count; 335 336 my @got = $self->_given_args; 337 my @expected = $self->_deep_args; 338 my ($same, $stack) = Test::Deep::cmp_details(\@got, \@expected); 339 if ( !$same ) { 340 return Test::Deep::deep_diag($stack); 341 } 342 return; # args are the same 343 } 344 345 # 346 # EXCEPTIONS 347 # 348 349 sub raises { 350 my $self = shift; 351 my ($message) = @_; 352 $self->_exception($message); 353 return $self; 354 } 355 356 sub _exception { 357 my $self = shift; 358 $self->{__exception} = shift if @_; 359 return $self->{__exception} ||= undef; 360 } 361 362 363 364 # 365 # CALL COUNT CHECKS 366 # 367 368 sub _times { 369 my ($self,$n,$msg,@params) = @_; 370 my $times = $n == 1 ? "time" : "times"; 371 $msg =~ s{%times}{$times}g; 372 return @params ? sprintf($msg,@params) : $msg; 373 } 374 375 # ensures that the expected method is called exactly N times 376 sub exactly { 377 my $self = shift; 378 my $n_times = shift; 379 if (!defined($n_times) || $n_times !~ /^\A\d+\z/) { 380 Carp::croak "Usage: ->exactly(INTEGER)"; 381 } 382 $self->_check_call_count(sub { 383 if ($self->_call_count != $n_times) { 384 return $self->_times($n_times, "exactly $n_times %times"); 385 } 386 }); 387 $self; 388 } 389 390 # ensures that the expected method is never called 391 sub never { 392 my $self = shift; 393 return $self->exactly(0); 394 } 395 396 # ensures that the expected method is called exactly one time 397 sub once { 398 my $self = shift; 399 $self->_check_call_count(sub { 400 if ($self->_call_count != 1) { 401 return "exactly once"; 402 } 403 }); 404 $self; 405 } 406 407 # ensures that the expected method is called at least N times 408 sub at_least { 409 my $self = shift; 410 my $n_times = shift; 411 if (!defined($n_times) || $n_times !~ /^\A\d+\z/) { 412 Carp::croak "Usage: ->at_least(INTEGER)"; 413 } 414 $self->_check_call_count(sub { 415 if ($self->_call_count < $n_times) { 416 return $self->_times($n_times, "at least $n_times %times"); 417 } 418 }); 419 $self; 420 } 421 422 sub at_least_once { 423 my $self = shift; 424 return $self->at_least(1); 425 } 426 427 # ensures that the expected method is called at most N times 428 sub at_most { 429 my $self = shift; 430 my $n_times = shift; 431 if (!defined($n_times) || $n_times !~ /^\A\d+\z/) { 432 Carp::croak "Usage: ->at_most(INTEGER)"; 433 } 434 $self->_check_call_count(sub { 435 if ($self->_call_count > $n_times) { 436 return $self->_times($n_times, "at most $n_times %times"); 437 } 438 }); 439 $self; 440 } 441 442 sub at_most_once { 443 my $self = shift; 444 return $self->at_most(1); 445 } 446 447 sub maybe { 448 my $self = shift; 449 return $self->at_most_once; 450 } 451 452 sub any_number { 453 my $self = shift; 454 $self->_check_call_count(sub {}); 455 $self; 456 } 457 458 # dummy method for syntactic sugar 459 sub times { 460 my $self = shift; 461 $self; 462 } 463 464 sub verify { 465 my $self = shift; 466 my @msgs = $self->problems; 467 die join("\n", @msgs) if @msgs; 468 return 1; 469 } 470 471 sub problems { 472 my $self = shift; 473 my @prob; 474 if (my $message = $self->_check_call_count->()) { 475 push @prob, $self->_times( 476 $self->_call_count, 477 "expected %s to be called %s, but it was called %d %times\n", 478 $self->_method, $message, $self->_call_count, 479 ); 480 } 481 for my $message ($self->_check_eq_args) { 482 push @prob, $message; 483 } 484 for my $message ($self->_check_deep_args) { 485 push @prob, $message; 486 } 487 return @prob; 488 } 489 490 sub setup { 491 my $self = shift; 492 if ($Debug) { 493 print STDERR "Setting up stub for @{[ $self->_target ]}->@{[ $self->_method ]}\n"; 494 } 495 496 # both these methods set _replaced_qualified_name and 497 # _original_code, which we'll use in teardown() 498 if (ref $self->_target) { 499 $self->_replace_instance_method; 500 } 501 else { 502 $self->_replace_class_method; 503 } 504 } 505 506 sub teardown { 507 my $self = shift; 508 509 if ($Debug) { 510 print STDERR "Tearing down stub for @{[ $self->_target ]}->@{[ $self->_method ]}\n"; 511 } 512 513 no strict 'refs'; 514 no warnings 'redefine'; 515 516 if ($self->_original_code) { 517 *{ $self->_replaced_qualified_name } = $self->_original_code; 518 } 519 else { 520 # avoid nuking aliases (including our _retval) by assigning a blank sub first. 521 # this technique stolen from ModPerl::Util::unload_package_pp 522 *{ $self->_replaced_qualified_name } = sub {}; 523 524 # Simply undefining &foo breaks in some cases by leaving some Perl 525 # droppings that cause subsequent calls to this function to die with 526 # "Not a CODE reference". It sounds harmless until Perl tries to 527 # call this method in an inheritance chain. Using Package::Stash solves 528 # that problem. It actually clones the original glob, leaving out the 529 # part being deleted. 530 require Package::Stash; 531 my $stash = Package::Stash->new($self->_target_class); 532 $stash->remove_symbol('&' . $self->_method); 533 } 534 535 $self->verify unless $self->_canceled; 536 } 537 538 sub _replaced_qualified_name { 539 my $self = shift; 540 return join("::", $self->_target_class, $self->_method); 541 } 542 543 sub _replace_instance_method { 544 no strict 'refs'; 545 no warnings qw(uninitialized); 546 547 my $self = shift; 548 my $target = $self->_target; 549 my $class = ref($target); 550 my $dest = join("::", $class, $self->_method); 551 my $original_method = $class->can($self->_method); 552 553 # save to be restored later 554 $self->_target_class($class); 555 $self->_original_code($original_method); 556 557 $self->_install($dest => sub { 558 # Use refaddr() to prevent an overridden equality operator from 559 # making two objects appear equal when they are only equivalent. 560 if (Scalar::Util::refaddr($_[0]) == Scalar::Util::refaddr($target)) { 561 # do extreme late binding here, so calls to returns() after the 562 # mock has already been installed will take effect. 563 my @args = @_; 564 shift @args; 565 $self->_called(@args); 566 die $self->_exception if $self->_exception; 567 return $self->_retval->(@_); 568 } 569 elsif (!$original_method) { 570 # method didn't exist before, mimic Perl's behavior 571 Carp::croak sprintf("Can't locate object method \"%s\" " . 572 "via package \"%s\"", $self->_method, $class); 573 } 574 else { 575 # run the original as if we were never here. 576 # to that end, use goto to prevent the extra stack frame 577 goto $original_method; 578 } 579 }); 580 } 581 582 sub _replace_class_method { 583 no strict 'refs'; 584 585 my $self = shift; 586 my $dest = join("::", $self->_target, $self->_method); 587 588 $self->_target_class($self->_target); 589 $self->_original_code(defined(&$dest) ? \&$dest : undef); 590 591 $self->_install($dest => sub { 592 # do extreme late binding here, so calls to returns() after the 593 # mock has already been installed will take effect. 594 my @args = @_; 595 shift @args; 596 $self->_called(@args); 597 die $self->_exception if $self->_exception; 598 $self->_retval->(@_); 599 }); 600 } 601 602 sub _install { 603 my ($self,$dest,$code) = @_; 604 if ($self->_original_code) { 605 # avoid "Prototype mismatch" 606 # this code borrowed/enhanced from Moose::Exporter 607 if (defined(my $proto = prototype $self->_original_code)) { 608 # XXX - Perl's prototype sucks. Use & to make set_prototype 609 # ignore the fact that we're passing "private variables" 610 &Scalar::Util::set_prototype($code, $proto); 611 } 612 } 613 no strict 'refs'; 614 no warnings 'redefine'; 615 *$dest = $code; 616 } 617 618} 619 620{ 621 package Test::Spec::Mocks::Stub; 622 use base qw(Test::Spec::Mocks::Expectation); 623 624 # A stub is a special case of expectation that doesn't actually 625 # expect anything. 626 627 sub new { 628 my $class = shift; 629 my $self = $class->SUPER::new(@_); 630 $self->at_least(0); 631 return $self; 632 } 633 634} 635 6361; 637 638=head1 NAME 639 640Test::Spec::Mocks - Object Simulation Plugin for Test::Spec 641 642=head1 SYNOPSIS 643 644 use Test::Spec; 645 use base qw(Test::Spec); 646 647 use My::RSS::Tool; # this is what we're testing 648 use LWP::UserAgent; 649 650 describe "RSS tool" => sub { 651 it "should fetch and parse an RSS feed" => sub { 652 my $xml = load_rss_fixture(); 653 LWP::Simple->expects('get')->returns($xml); 654 655 # calls LWP::Simple::get, but returns our $xml instead 656 my @stories = My::RSS::Tool->run; 657 658 is_deeply(\@stories, load_stories_fixture()); 659 }; 660 }; 661 662=head1 DESCRIPTION 663 664Test::Spec::Mocks is a plugin for Test::Spec that provides mocking and 665stubbing of objects, individual methods and plain subroutines on both 666object instances and classes. This module is inspired by and heavily 667borrows from Mocha, a library for the Ruby programming language. Mocha 668itself is inspired by JMock. 669 670Mock objects provide a way to simulate the behavior of real objects, while 671providing consistent, repeatable results. This is very useful when you need 672to test a function whose results are dependent upon an external factor that 673is normally uncontrollable (like the time of day). Mocks also allow you to 674test your code in isolation, a tenet of unit testing. 675 676There are many other reasons why mock objects might come in handy. See the 677L<Mock objects|http://en.wikipedia.org/wiki/Mock_object> article at Wikipedia 678for lots more examples and more in-depth coverage of the philosophy behind 679object mocking. 680 681=head2 Ecosystem 682 683Test::Spec::Mocks is currently only usable from within tests built with 684the Test::Spec BDD framework. 685 686=head2 Terminology 687 688Familiarize yourself with these terms: 689 690=over 4 691 692=item * Stub object 693 694A stub object is an object created specifically to return canned responses for 695a specific set of methods. These are created with the L<stub|/stub()> function. 696 697=item * Mock object 698 699Mock objects are similar to stub objects, but are programmed with both 700prepared responses and expectations for how they will be called. If the 701expectations are not met, they raise an exception to indicate that the test 702failed. Mock objects are created with the L<mock|/mock()> function. 703 704=item * Stubbed method 705 706Stubbed methods temporarily replace existing methods on a class or object 707instance. This is useful when you only want to override a subset of an object 708or class's behavior. For example, you might want to override the C<do> method 709of a DBI handle so it doesn't make changes to your database, but still need 710the handle to respond as usual to the C<quote> method. You'll stub 711methods using the L<stubs|/"$thing-E<gt>stubs($method_name)"> method. 712 713=item * Mocked method 714 715If you've been reading up to this point, this will be no surprise. Mocked 716methods are just like stubbed methods, but they come with expectations that 717will raise an exception if not met. For example, you can mock a C<save> method 718on an object to ensure it is called by the code you are testing, while 719preventing the data from actually being committed to disk in your test. Use 720the L<expects|/"$thing-E<gt>expects($method)"> method to create mock methods. 721 722=item * "stub", "mock" 723 724Depending on context, these can refer to stubbed objects and methods, or 725mocked objects and methods, respectively. 726 727=back 728 729=head2 Using stub objects (anonymous stubs) 730 731Sometimes the code you're testing requires that you pass it an object that 732conforms to a specific interface. For example, you are testing a console 733prompting library, but you don't want to require a real person to stand by, 734waiting to type answers into the console. The library requires an object 735that returns a string when the C<read_line> method is called. 736 737You could create a class specifically for returning test console input. But 738why do that? You can create a stub object in one line: 739 740 describe "An Asker" => sub { 741 my $asker = Asker->new; 742 743 it "returns true when a yes_or_no question is answered 'yes'" => sub { 744 my $console_stub = stub(read_line => "yes"); 745 # $console_stub->read_line returns "yes" 746 ok( $asker->yes_or_no($console_stub, "Am I awesome?") ); 747 }; 748 749 it "returns false when a yes_or_no question is answered 'no'" => sub { 750 my $console_stub = stub(read_line => "no"); 751 ok( ! $asker->yes_or_no($console_stub, "Am I second best?") ); 752 }; 753 }; 754 755Stubs can also take subroutine references. This is useful when the behavior 756you need to mimic is a little more complex. 757 758 it "keeps asking until it gets an answer" => sub { 759 my @answers = (undef, "yes"); 760 my $console_stub = stub(read_line => sub { shift @answers }); 761 # when console_stub is called the first time, it returns undef 762 # the second time returns "yes" 763 ok( $asker->yes_or_no($console_stub, "Do I smell nice?") ); 764 }; 765 766=head2 Using mock objects 767 768If you want to take your tests one step further, you can use mock objects 769instead of stub objects. Mocks ensure the methods you expect to be called 770actually are called. If they aren't, the mock will raise an exception which 771causes your test to fail. 772 773In this example, we are testing that C<read_line> is called once and only 774once (the default for mocks). 775 776 it "returns true when a yes_or_no question is answered 'yes'" => sub { 777 my $console_mock = mock(); 778 $console_mock->expects('read_line') 779 ->returns("yes"); 780 # $console_mock->read_line returns "yes" 781 ok( $asker->yes_or_no($console_mock, "Am I awesome?") ); 782 }; 783 784If Asker's C<yes_or_no> method doesn't call C<read_line> on our mock exactly 785one time, the test would fail with a message like: 786 787 expected read_line to be called exactly 1 time, but it was called 0 times 788 789You can specify how many times your mock should be called with "exactly": 790 791 it "keeps asking until it gets an answer" => sub { 792 my @answers = (undef, "yes"); 793 my $console_mock = mock(); 794 $console_mock->expects('read_line') 795 ->returns(sub { shift @answers }) 796 ->exactly(2); 797 # when console_mock is called the first time, it returns undef 798 # the second time returns "yes" 799 ok( $asker->yes_or_no($console_mock, "Do I smell nice?") ); 800 }; 801 802If you want something more flexible than "exactly", you can choose from 803"at_least", "at_most", "any_number" and others. See L</EXPECTATION ADJUSTMENT METHODS>. 804 805 806=head2 Stubbing methods 807 808Sometimes you want to override just a small subset of an object's behavior. 809 810 describe "The old audit system" => sub { 811 my $dbh; 812 before sub { $dbh = SomeExternalClass->get_dbh }; 813 814 it "executes the expected sql" => sub { 815 my $sql; 816 $dbh->stubs(do => sub { $sql = shift; return 1 }); 817 818 # $dbh->do("foo") now sets $sql to "foo" 819 # $dbh->quote still does what it normally would 820 821 audit_event($dbh, "server crash, oh noes!!"); 822 823 like( $sql, qr/insert into audit_event.*'server crash, oh noes!!!'/ ); 824 }; 825 }; 826 827You can also stub class methods: 828 829 # 1977-05-26T14:11:55 830 my $event_datetime = DateTime->new(from_epoch => 0xdeafcab); 831 832 it "should tag each audit event with the current time" => sub { 833 DateTime->stubs('now' => sub { $event_datetime }); 834 is( audit_timestamp(), '19770526.141155' ); 835 }; 836 837=head2 Mocking methods 838 839Mocked methods are to stubbed methods as mock objects are to stub objects. 840 841 it "executes the expected sql" => sub { 842 $dbh->expects('do')->returns(sub { $sql = shift; return 1 }); 843 844 # $dbh->do("foo") now sets $sql to "foo" 845 # $dbh->quote still does what it normally would 846 847 audit_event($dbh, "server crash, oh noes!!"); 848 like( $sql, qr/insert into audit_event.*'server crash, oh noes!!!'/ ); 849 850 # if audit_event doesn't call $dbh->do exactly once, KABOOM! 851 }; 852 853=head1 CONSTRUCTORS 854 855=over 4 856 857=item stub() 858 859=item stub($method_name => $result, ...) 860 861=item stub($method_name => sub { $result }, ...) 862 863=item stub({ $method_name => $result, ... }) 864 865Returns a new anonymous stub object. Takes a list of 866C<$method_name>/C<$result> pairs or a reference to a hash containing the same. 867Each C<$method_name> listed is stubbed to return the associated value 868(C<$result>); or if the value is a subroutine reference, it is stubbed 869in-place (the subroutine becomes the method). 870 871Examples: 872 873 # A blank object with no methods. 874 # Gives a true response to ref() and blessed(). 875 my $blank = stub(); 876 877 # Static responses to width() and height(): 878 my $rect = stub(width => 5, height => 5); 879 880 # Dynamic response to area(): 881 my $radius = 1.0; 882 my $circle_stub = stub(area => sub { PI * $radius * $radius }); 883 884You can also stub more methods, just like with any other object: 885 886 my $rect = stub(width => 5, height => 5); 887 $rect->stubs(area => sub { my $self = shift; $self->width * $self->height }); 888 889 890=item $thing->stubs($method_name) 891 892=item $thing->stubs($method_name => $result) 893 894=item $thing->stubs($method_name => sub { $result }) 895 896=item $thing->stubs({ $method_name => $result }) 897 898Stubs one or more methods on an existing class or instance, C<$thing>. 899 900If passed only one (non-hash) argument, it is interpreted as a method name. 901The return value of the stubbed method will be C<undef>. 902 903Otherwise, the arguments are a list of C<$method_name> and C<$result> 904pairs, either as a flat list or as a hash reference. Each method is 905installed onto C<$thing>, and returns the specified result. If the result is a 906subroutine reference, it will be called for every invocation of the method. 907 908 909=item mock() 910 911Returns a new blank, anonymous mock object, suitable for mocking methods with 912L<expects()|/"$thing-E<gt>expects($method)">. 913 914 my $rect = mock(); 915 $rect->expects('area')->returns(100); 916 917 918=item $thing->expects($method) 919 920Installs a mock method named C<$method> onto the class or object C<$thing> and 921returns an Test::Spec::Mocks::Expectation object, which you can use to set the 922return value with C<returns()> and other expectations. By default, the method 923is expected to be called L<at_least_once>. 924 925If the expectation is not met before the enclosing example completes, the 926mocked method will raise an exception that looks something like: 927 928 expected foo to be called exactly 1 time, but it was called 0 times 929 930=back 931 932=head1 EXPECTATION ADJUSTMENT METHODS 933 934These are methods of the Test::Spec::Mocks::Expectation class, which you'll 935receive by calling C<expects()> on a class or object instance. 936 937=over 4 938 939=item returns( $result ) 940 941=item returns( @result ) 942 943=item returns( \&callback ) 944 945Configures the mocked method to return the specified result when called. If 946passed a subroutine reference, the subroutine will be executed when the method 947is called, and the result is the return value. 948 949 $rect->expects('height')->returns(5); 950 # $rect->height ==> 5 951 952 @points = ( [0,0], [1,0], [1,1], [1,0] ); 953 $rect->expects('points')->returns(@points); 954 # (@p = $rect->points) ==> ( [0,0], [1,0], [1,1], [1,0] ) 955 # ($p = $rect->points) ==> 4 956 957 @points = ( [0,0], [1,0], [1,1], [1,0] ); 958 $rect->expects('next_point')->returns(sub { shift @points }); 959 # $rect->next_point ==> [0,0] 960 # $rect->next_point ==> [1,0] 961 # ... 962 963=item exactly($N) 964 965Configures the mocked method so that it must be called exactly $N times. 966 967=item never 968 969Configures the mocked method so that it must never be called. 970 971=item once 972 973Configures the mocked method so that it must be called exactly one time. 974 975=item at_least($N) 976 977Configures the mocked method so that it must be called at least $N times. 978 979=item at_least_once 980 981Configures the mocked method so that it must be called at least 1 time. 982This is just syntactic sugar for C<at_least(1)>. 983 984=item at_most($N) 985 986Configures the mocked method so that it must be called no more than $N times. 987 988=item at_most_once 989 990Configures the mocked method so that it must be called either zero or 1 991times. 992 993=item maybe 994 995An alias for L</at_most_once>. 996 997=item any_number 998 999Configures the mocked method so that it can be called zero or more times. 1000 1001=item times 1002 1003A syntactic sugar no-op: 1004 1005 $io->expects('print')->exactly(3)->times; 1006 1007I<This method is alpha and will probably change in a future release.> 1008 1009=item with(@arguments) / with_eq(@arguments) 1010 1011Configures the mocked method so that it must be called with arguments as 1012specified. The arguments will be compared using the "eq" operator, so it works 1013for most scalar values with no problem. If you want to check objects here, 1014they must be the exact same instance or you must overload the "eq" operator to 1015provide the behavior you desire. 1016 1017=item with_deep(@arguments) 1018 1019Similar to C<with_eq> except the arguments are compared using L<Test::Deep>: scalars are 1020compared by value, arrays and hashes must have the same elements and references 1021must be blessed into the same class. 1022 1023 $cache->expects('set') 1024 ->with_deep($customer_id, { name => $customer_name }); 1025 1026Use L<Test::Deep>'s comparison functions for more flexibility: 1027 1028 use Test::Deep::NoTest (); 1029 $s3->expects('put') 1030 ->with_deep('test-bucket', 'my-doc', Test::Deep::ignore()); 1031 1032=item raises($exception) 1033 1034Configures the mocked method so that it raises C<$exception> when called. 1035 1036=back 1037 1038=head1 OTHER EXPECTATION METHODS 1039 1040=over 4 1041 1042=item verify 1043 1044Allows you to verify manually that the expectation was met. If the expectation 1045has not been met, the method dies with an error message containing specifics 1046of the failure. Returns true otherwise. 1047 1048=item problems 1049 1050If the expectation has not been met, returns a list of problem description 1051strings. Otherwise, returns an empty list. 1052 1053=back 1054 1055=head1 KNOWN ISSUES 1056 1057=over 4 1058 1059=item Memory leaks 1060 1061Because of the way the mock objects (C<stubs>, C<stub>, C<expects>, and C<mock>) 1062are integrated into the Test::Spec runtime they will leak memory. It is 1063not recommended to use the Test::Spec mocks in any long-running program. 1064 1065Patches welcome. 1066 1067=back 1068 1069=head1 SEE ALSO 1070 1071There are other less sugary mocking systems for Perl, including 1072L<Test::MockObject> and L<Test::MockObject::Extends>. 1073 1074This module is a plugin for L<Test::Spec>. It is inspired by 1075L<Mocha|http://mocha.rubyforge.org/>. 1076 1077The Wikipedia article L<Mock object|http://en.wikipedia.org/wiki/Mock_object> 1078is very informative. 1079 1080=head1 AUTHOR 1081 1082Philip Garrett, <philip.garrett@icainformatics.com> 1083 1084=head1 COPYRIGHT & LICENSE 1085 1086Copyright (c) 2011 by Informatics Corporation of America. 1087 1088This program is free software; you can redistribute it and/or modify it 1089under the same terms as Perl itself. 1090 1091=cut 1092