Fix crash when tying @DB::args

I was looking at diag.t to see what messages I could document.
‘av_reify called on tied array’ looked interesting, so I decided to
see whether I could trigger it.  I got something else:

./perl -Ilib -lwe '
  sub TIEARRAY{bless[]}
  sub CLEAR{}
  sub EXTEND{}
  tie @DB::args, "";
  package DB; sub {() = caller 0;}->(1,2,3);
'
Name "DB::args" used only once: possible typo at -e line 5.
Bus error

How exciting!

What’s happening is that Perl_init_dbargs turns off AvREAL after
clearing a real array.  Then pp_caller does av_extend and merrily
tries to copy into AvARRAY(PL_dbargs).  But AvARRAY has not been allo-
cated, because av_extend called EXTEND instead.

I fixed this by untying the array before turning off AvREAL.  I don’t
know whether that is the best fix.  Alternatives would be to croak
or to do the assignment in pp_caller differently for tied arrays (in
which case tying @DB::args would cause objects to leak unexpectedly,
until the next caller() call in the DB package).

diff --git a/perl.c b/perl.c
index 6c389ca..b064da6 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -3890,6 +3890,8 @@ Perl_init_dbargs(pTHX)
           "leak" until global destruction.  */
        av_clear(args);
     }
+    if (SvTIED_mg((const SV *)args, PERL_MAGIC_tied))
+       sv_unmagic((const SV *)args, PERL_MAGIC_tied);
     AvREIFY_only(PL_dbargs);
 }
 

diff --git a/t/op/caller.t b/t/op/caller.t
index 4fcc851..a694aa6 100644 (file)
--- a/t/op/caller.t
+++ b/t/op/caller.t
@@ -5,7 +5,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan( tests => 83 );
+    plan( tests => 84 );
 }
 
 my @c;
@@ -234,6 +234,20 @@ sub {
 }->();
 pass 'No crash when @DB::args is freed between caller calls';
 
+# This also crashed:
+package glelp;
+sub TIEARRAY { bless [] }
+sub EXTEND   {         }
+sub CLEAR    {        }
+sub FETCH    { $_[0][$_[1]] }
+sub STORE    { $_[0][$_[1]] = $_[2] }
+package DB;
+tie @args, 'glelp';
+sub { () = caller 0; } ->(1..3);
+::is "@args", "1 2 3", 'tied @DB::args';
+untie @args;
+package main;
+
 $::testing_caller = 1;
 
 do './op/caller.pl' or die $@;