A relatively easy fix.
Patch attached.
--
Paul Evans
=== modified file 'lib/Future/Mutex.pm'
--- old/lib/Future/Mutex.pm 2020-04-22 14:03:48 +0000
+++ new/lib/Future/Mutex.pm 2020-10-19 16:14:50 +0000
@@ -13,6 +13,8 @@
use Future;
+use Scalar::Util qw( weaken );
+
=head1 NAME
C<Future::Mutex> - mutual exclusion lock around code that returns L<Future>s
@@ -91,6 +93,7 @@
return bless {
avail => $params{count} // 1,
+ waitf => undef,
queue => [],
}, $class;
}
@@ -125,7 +128,8 @@
$down_f = Future->done;
}
else {
- push @{ $self->{queue} }, $down_f = Future->new;
+ die "ARGH Need to clone an existing future\n" unless defined $self->{waitf};
+ push @{ $self->{queue} }, $down_f = $self->{waitf}->new;
}
my $up = sub {
@@ -134,10 +138,13 @@
}
else {
$self->{avail}++;
+ undef $self->{waitf};
}
};
- $down_f->then( $code )->on_ready( $up );
+ my $retf = $down_f->then( $code )->on_ready( $up );
+ $self->{waitf} or weaken( $self->{waitf} = $retf );
+ return $retf;
}
=head2 available
=== modified file 't/40mutex.t'
--- old/t/40mutex.t 2020-03-25 00:08:20 +0000
+++ new/t/40mutex.t 2020-10-19 16:14:50 +0000
@@ -4,6 +4,7 @@
use warnings;
use Test::More;
+use Test::Refcount;
use Future;
use Future::Mutex;
@@ -15,11 +16,13 @@
ok( $mutex->available, 'Mutex is available' );
my $f;
- my $lf = $mutex->enter( sub { $f = Future->new } );
+ my $lf = $mutex->enter( sub { $f = t::Future::Subclass->new } );
ok( defined $lf, '->enter returns Future' );
ok( defined $f, '->enter on new Mutex runs code' );
+ isa_ok( $lf, "t::Future::Subclass", '$lf' );
+
ok( !$mutex->available, 'Mutex is unavailable' );
ok( !$lf->is_ready, 'locked future not yet ready' );
@@ -27,6 +30,9 @@
$f->done;
ok( $lf->is_ready, 'locked future ready after $f->done' );
ok( $mutex->available, 'Mutex is available again' );
+
+ undef $f;
+ is_oneref( $lf, '$lf has one ref at EOT' );
}
# done chaining
@@ -34,10 +40,15 @@
my $mutex = Future::Mutex->new;
my $f1;
- my $lf1 = $mutex->enter( sub { $f1 = Future->new } );
+ my $lf1 = $mutex->enter( sub { $f1 = t::Future::Subclass->new } );
my $f2;
- my $lf2 = $mutex->enter( sub { $f2 = Future->new } );
+ my $lf2 = $mutex->enter( sub { $f2 = t::Future::Subclass->new } );
+
+ isa_ok( $lf1, "t::Future::Subclass", '$lf1' );
+ isa_ok( $lf2, "t::Future::Subclass", '$lf2' );
+
+ is_oneref( $lf2, '$lf2 has one ref' );
ok( !defined $f2, 'second enter not invoked while locked' );
@@ -47,6 +58,12 @@
$f2->done;
ok( $lf2->is_ready, 'second locked future ready after $f2->done' );
ok( $mutex->available, 'Mutex is available again' );
+
+ undef $f1;
+ undef $f2;
+
+ is_oneref( $lf1, '$lf1 has one ref at EOT' );
+ is_oneref( $lf2, '$lf2 has one ref at EOT' );
}
# fail chaining
@@ -119,11 +136,13 @@
my ( $f1, $f2, $f3 );
my $f = Future->needs_all(
- $mutex->enter( sub { $f1 = Future->new } ),
- $mutex->enter( sub { $f2 = Future->new } ),
- $mutex->enter( sub { $f3 = Future->new } ),
+ $mutex->enter( sub { $f1 = t::Future::Subclass->new } ),
+ $mutex->enter( sub { $f2 = t::Future::Subclass->new } ),
+ $mutex->enter( sub { $f3 = t::Future::Subclass->new } ),
);
+ isa_ok( $f, "t::Future::Subclass", '$f' );
+
ok( defined $f1, '$f1 defined' );
$f1->done;
@@ -163,3 +182,6 @@
}
done_testing;
+
+package t::Future::Subclass;
+use base qw( Future );
