| Subject: | [PATCH] Calling 'lnoreturn' with 'use threads' causes error |
The attached script (bug.pl) produces the following error: Can't undef
active subroutine during global destruction.
This results from the need to decrement the 'subroutine depth' in
'lnoreturn'. The attached patch fixes this bug, and includes tests that
verify the fix.
| Subject: | want.patch |
diff -urN Want-0.10/Changes Want-0.11/Changes
--- Want-0.10/Changes 2006-03-26 15:08:08.000000000 -0500
+++ Want-0.11/Changes 2006-08-25 14:14:16.000000000 -0400
@@ -66,3 +66,6 @@
- Fix bug whereby want('LVALUE') sometimes gave false positives
(see test 58 in t/all.t)
- Fix bug whereby want_boolean often gave false positives
+
+0.11
+ - Fix bug whereby 'lnoreturn' + 'use threads' resulted in error
diff -urN Want-0.10/MANIFEST Want-0.11/MANIFEST
--- Want-0.10/MANIFEST 2006-08-25 14:15:14.000000000 -0400
+++ Want-0.11/MANIFEST 2006-08-25 14:14:56.000000000 -0400
@@ -11,3 +11,5 @@
t/damian.t
t/err.t
t/object.t
+t/threads.t
+t/threads.p
diff -urN Want-0.10/README Want-0.11/README
--- Want-0.10/README 2006-03-29 08:49:30.000000000 -0500
+++ Want-0.11/README 2006-08-25 14:14:22.000000000 -0400
@@ -1,5 +1,5 @@
-----------------------------------------------------------------------------
-| Want v0.10 - Robin Houston, 2006-03-25
+| Want v0.11 - Robin Houston, 2006-03-25
-----------------------------------------------------------------------------
For full documentation, see the POD included with the module.
diff -urN Want-0.10/Want.pm Want-0.11/Want.pm
--- Want-0.10/Want.pm 2006-03-26 14:52:22.000000000 -0500
+++ Want-0.11/Want.pm 2006-08-25 14:14:30.000000000 -0400
@@ -12,7 +12,7 @@
our @EXPORT = qw(want rreturn lnoreturn);
our @EXPORT_OK = qw(howmany wantref);
-our $VERSION = '0.10';
+our $VERSION = '0.11';
bootstrap Want $VERSION;
diff -urN Want-0.10/Want.xs Want-0.11/Want.xs
--- Want-0.10/Want.xs 2006-03-26 09:08:56.000000000 -0500
+++ Want-0.11/Want.xs 2006-08-25 14:13:00.000000000 -0400
@@ -651,6 +651,7 @@
Perl_croak(aTHX_ "Can't return outside a subroutine");
ourcx->cx_type = CXt_NULL;
+ CvDEPTH(ourcx->blk_sub.cv)--;
#if HAS_RETSTACK
if (PL_retstack_ix > 0)
--PL_retstack_ix;
diff -urN Want-0.10/t/threads.p Want-0.11/t/threads.p
--- Want-0.10/t/threads.p 1969-12-31 19:00:00.000000000 -0500
+++ Want-0.11/t/threads.p 2006-08-25 14:11:40.000000000 -0400
@@ -0,0 +1,26 @@
+use strict;
+use warnings;
+
+{
+ package Foo;
+ use Want;
+
+ sub new { return (bless({}, shift)); }
+
+ my $foo;
+
+ sub foo :lvalue
+ {
+ my (@args) = Want::want('ASSIGN');
+ $foo = $args[0];
+ Want::lnoreturn;
+ return;
+ }
+
+}
+
+use threads;
+my $obj = Foo->new();
+$obj->foo() = 'bar';
+
+# EOF
diff -urN Want-0.10/t/threads.t Want-0.11/t/threads.t
--- Want-0.10/t/threads.t 1969-12-31 19:00:00.000000000 -0500
+++ Want-0.11/t/threads.t 2006-08-25 14:12:50.000000000 -0400
@@ -0,0 +1,10 @@
+use strict;
+use warnings;
+
+use Test::More 'tests' => 1;
+
+my $out = `perl -Mblib t/threads.p 2>&1`;
+
+is($out, '' => 'No destruct error');
+
+# EOF
| Subject: | bug.pl |
#!/usr/bin/perl
use strict;
use warnings;
{
package Foo;
use Want;
sub new { return (bless({}, shift)); }
my $foo;
sub foo :lvalue
{
my (@args) = Want::want('ASSIGN');
$foo = $args[0];
Want::lnoreturn;
return;
}
}
use threads;
my $obj = Foo->new();
$obj->foo() = 'bar';