File Coverage

blib/lib/Test/Future.pm
Criterion Covered Total %
statement 58 61 95.0
branch 5 8 62.5
condition n/a
subroutine 10 11 90.9
pod 1 1 100.0
total 74 81 91.3


line stmt bran cond sub pod time code
1             # You may distribute under the terms of either the GNU General Public License
2             # or the Artistic License (the same terms as Perl itself)
3             #
4             # (C) Paul Evans, 2014-2015 -- leonerd@leonerd.org.uk
5              
6             package Test::Future;
7              
8 1     1   359 use v5.10;
  1         3  
9 1     1   4 use strict;
  1         1  
  1         16  
10 1     1   3 use warnings;
  1         2  
  1         19  
11 1     1   4 use base qw( Test::Builder::Module );
  1         2  
  1         99  
12              
13             our $VERSION = '0.48_003';
14              
15             our @EXPORT = qw(
16             no_pending_futures
17             );
18              
19 1     1   5 use Scalar::Util qw( refaddr );
  1         2  
  1         62  
20              
21 1     1   5 use constant HAVE_DEVEL_MAT_DUMPER => defined eval { require Devel::MAT::Dumper };
  1         1  
  1         8  
  1         81  
22              
23             =head1 NAME
24              
25             C - unit test assertions for L instances
26              
27             =head1 SYNOPSIS
28              
29             use Test::More tests => 2;
30             use Test::Future;
31              
32             no_pending_futures {
33             my $f = some_function();
34              
35             is( $f->get, "result", 'Result of the some_function()' );
36             } 'some_function() leaves no pending Futures';
37              
38             =head1 DESCRIPTION
39              
40             This module provides unit testing assertions that may be useful when testing
41             code based on, or using L instances or subclasses.
42              
43             =cut
44              
45             =head1 FUNCTIONS
46              
47             =cut
48              
49             =head2 no_pending_futures
50              
51             no_pending_futures( \&code, $name )
52              
53             I
54              
55             Runs the given block of code, while keeping track of every C instance
56             constructed while doing so. After the code has returned, each of these
57             instances are inspected to check that they are not still pending. If they are
58             all either ready (by success or failure) or cancelled, the test will pass. If
59             any are still pending then the test fails.
60              
61             If L is installed, it will be used to write a memory state dump
62             after a failure. It will create a F<.pmat> file named the same as the unit
63             test, but with the trailing F<.t> suffix replaced with F<-TEST.pmat> where
64             C is the number of the test that failed (in case there was more than
65             one). A list of addresses of C instances that are still pending is
66             also printed to assist in debugging the issue.
67              
68             It is not an error if the code does not construct any C instances at
69             all. The block of code may contain other testing assertions; they will be run
70             before the assertion by C itself.
71              
72             =cut
73              
74             sub no_pending_futures(&@)
75             {
76 4     4 1 7163 my ( $code, $name ) = @_;
77              
78 4         5 my @futures;
79              
80 1     1   5 no warnings 'redefine';
  1         2  
  1         444  
81              
82 4         24 my $new = Future->can( "new" );
83             local *Future::new = sub {
84 4     4   14 my $f = $new->(@_);
85 4         7 push @futures, $f;
86             $f->on_ready( sub {
87 2         3 my $f = shift;
88 2         6 for ( 0 .. $#futures ) {
89 2 50       11 refaddr( $futures[$_] ) == refaddr( $f ) or next;
90              
91 2         3 splice @futures, $_, 1, ();
92 2         16 return;
93             }
94 4         20 });
95 4         7 return $f;
96 4         17 };
97              
98 4         11 my $done = Future->can( "done" );
99             local *Future::done = sub {
100 3     3   15 my $f = $done->(@_);
101 3 100       7 pop @futures if !ref $_[0]; # class method
102 3         12 return $f;
103 4         12 };
104              
105 4         13 my $fail = Future->can( "fail" );
106             local *Future::fail = sub {
107 0     0   0 my $f = $fail->(@_);
108 0 0       0 pop @futures if !ref $_[0]; # class method
109 0         0 return $f;
110 4         11 };
111              
112 4         16 my $tb = __PACKAGE__->builder;
113              
114 4         36 $code->();
115              
116 4         923 my @pending = grep { !$_->is_ready } @futures;
  1         4  
117              
118 4 100       13 return $tb->ok( 1, $name ) if !@pending;
119              
120 1         6 my $ok = $tb->ok( 0, $name );
121              
122 1         846 $tb->diag( "The following Futures are still pending:" );
123 1         201 $tb->diag( join ", ", map { sprintf "0x%x", refaddr $_ } @pending );
  1         20  
124              
125 1         198 if( HAVE_DEVEL_MAT_DUMPER ) {
126 1         2 my $file = $0;
127 1         3 my $num = $tb->current_test;
128              
129             # Trim the .t off first then append -$num.pmat, in case $0 wasn't a .t file
130 1         89 $file =~ s/\.(?:t|pm|pl)$//;
131 1         3 $file .= "-$num.pmat";
132              
133 1         3 $tb->diag( "Writing heap dump to $file" );
134 1         50032 Devel::MAT::Dumper::dump( $file );
135             }
136              
137 1         28 return $ok;
138             }
139              
140             =head1 AUTHOR
141              
142             Paul Evans
143              
144             =cut
145              
146             0x55AA;