view release on metacpan or  search on metacpan

local/lib/perl5/Test/Future.pm  view on Meta::CPAN

test, but with the trailing F<.t> suffix replaced with F<-TEST.pmat> where
C<TEST> is the number of the test that failed (in case there was more than
one). A list of addresses of C<Future> instances that are still pending is
also printed to assist in debugging the issue.

It is not an error if the code does not construct any C<Future> instances at
all. The block of code may contain other testing assertions; they will be run
before the assertion by C<no_pending_futures> itself.

=cut

sub no_pending_futures(&@)
{
   my ( $code, $name ) = @_;

   my @futures;

   no warnings 'redefine';

   my $new = Future->can( "new" );
   local *Future::new = sub {
      my $f = $new->(@_);
      push @futures, $f;
      $f->on_ready( sub {
         my $f = shift;
         for ( 0 .. $#futures ) {
            refaddr( $futures[$_] ) == refaddr( $f ) or next;

            splice @futures, $_, 1, ();
            return;
         }
      });
      return $f;
   };

   my $done = Future->can( "done" );
   local *Future::done = sub {
      my $f = $done->(@_);
      pop @futures if !ref $_[0]; # class method
      return $f;
   };

   my $fail = Future->can( "fail" );
   local *Future::fail = sub {
      my $f = $fail->(@_);
      pop @futures if !ref $_[0]; # class method
      return $f;
   };

   my $tb = __PACKAGE__->builder;

   $code->();

   my @pending = grep { !$_->is_ready } @futures;

   return $tb->ok( 1, $name ) if !@pending;

   my $ok = $tb->ok( 0, $name );

   $tb->diag( "The following Futures are still pending:" );
   $tb->diag( join ", ", map { sprintf "0x%x", refaddr $_ } @pending );

   if( HAVE_DEVEL_MAT_DUMPER ) {
      my $file = $0;
      my $num = $tb->current_test;

      # Trim the .t off first then append -$num.pmat, in case $0 wasn't a .t file
      $file =~ s/\.(?:t|pm|pl)$//;
      $file .= "-$num.pmat";

      $tb->diag( "Writing heap dump to $file" );
      Devel::MAT::Dumper::dump( $file );
   }

   return $ok;
}

=head1 AUTHOR

Paul Evans <leonerd@leonerd.org.uk>

=cut

0x55AA;