Make warn handle magic vars (fixes [perl #97480])

pp_warn was checking flags before calling get-magic, resulting in sev-
eral bugs that I fixed all at once::
• warn now calls get-magic exactly once on its argument, when there
  is just one argument (it always worked correctly for multiple)
  [perl #97480].
• warn calls get-magic exactly once on $@ when falling back to it,
  instead of zero times.
• A tied variable returning an object that stringifies as an empty
  string is no longer ignored if the tied variable was not ROK
  before FETCH.
• A tied $@ containing a string, or $@ aliased to $1, is no
  longer ignored.
• A tied $@ that last returned a reference but will return a string on
  the next FETCH now gets "\t...caught" appended.

3 files changed, 68 insertions, 9 deletions

diff --git a/pp_sys.c b/pp_sys.c
index 3ddf5e2d70..994bd6ce9c 100644
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -438,20 +438,29 @@ PP(pp_warn)
     }
     else {
 	exsv = TOPs;
+	if (SvGMAGICAL(exsv)) exsv = sv_mortalcopy(exsv);
     }
 
     if (SvROK(exsv) || (SvPV_const(exsv, len), len)) {
 	/* well-formed exception supplied */
     }
-    else if (SvROK(ERRSV)) {
-	exsv = ERRSV;
-    }
-    else if (SvPOK(ERRSV) && SvCUR(ERRSV)) {
-	exsv = sv_mortalcopy(ERRSV);
-	sv_catpvs(exsv, "\t...caught");
-    }
     else {
+      SvGETMAGIC(ERRSV);
+      if (SvROK(ERRSV)) {
+	if (SvGMAGICAL(ERRSV)) {
+	    exsv = sv_newmortal();
+	    sv_setsv_nomg(exsv, ERRSV);
+	}
+	else exsv = ERRSV;
+      }
+      else if (SvPOKp(ERRSV) && SvCUR(ERRSV)) {
+	exsv = sv_newmortal();
+	sv_setsv_nomg(exsv, ERRSV);
+	sv_catpvs(exsv, "\t...caught");
+      }
+      else {
 	exsv = newSVpvs_flags("Warning: something's wrong", SVs_TEMP);
+      }
     }
     if (SvROK(exsv) && !PL_warnhook)
 	 Perl_warn(aTHX_ "%"SVf, SVfARG(exsv));
diff --git a/t/op/tie_fetch_count.t b/t/op/tie_fetch_count.t
index 8eae578042..26666f2a17 100644
--- a/t/op/tie_fetch_count.t
+++ b/t/op/tie_fetch_count.t
@@ -7,7 +7,7 @@ BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
     require './test.pl';
-    plan (tests => 299);
+    plan (tests => 303);
 }
 
 use strict;
@@ -248,6 +248,18 @@ for ([chdir=>''],[chmod=>'0,'],[chown=>'0,0,'],[utime=>'0,0,'],
                             ; check_count 'select $tied_undef, ...';
 }
 
+{
+    local $SIG{__WARN__} = sub {};
+    $dummy  =  warn $var    ; check_count 'warn $tied';
+    tie $@, => 'main', 1;
+    $dummy  =  warn         ; check_count 'warn() with $@ tied (num)';
+    tie $@, => 'main', \1;
+    $dummy  =  warn         ; check_count 'warn() with $@ tied (ref)';
+    tie $@, => 'main', "foo\n";
+    $dummy  =  warn         ; check_count 'warn() with $@ tied (str)';
+    untie $@;
+}
+
 ###############################################
 #        Tests for  $foo binop $foo           #
 ###############################################
diff --git a/t/op/warn.t b/t/op/warn.t
index 4a927e2311..a0a072e247 100644
--- a/t/op/warn.t
+++ b/t/op/warn.t
@@ -7,7 +7,7 @@ BEGIN {
     require './test.pl';
 }
 
-plan 22;
+plan 28;
 
 my @warnings;
 my $wa = []; my $ea = [];
@@ -148,4 +148,42 @@ fresh_perl_like(
  'warn stringifies in the absence of $SIG{__WARN__}'
 );
 
+use Tie::Scalar;
+tie $@, "Tie::StdScalar";
+
+$@ = "foo\n";
+@warnings = ();
+warn;
+is @warnings, 1;
+like $warnings[0], qr/^foo\n\t\.\.\.caught at warn\.t /,
+    '...caught is appended to tied $@';
+
+$@ = \$_;
+@warnings = ();
+{
+  local *{ref(tied $@) . "::STORE"} = sub {};
+  undef $@;
+}
+warn;
+is @warnings, 1;
+is $warnings[0], \$_, '!SvOK tied $@ that returns ref is used';
+
+untie $@;
+
+@warnings = ();
+{
+  package o;
+  use overload '""' => sub { "" };
+}
+tie $t, Tie::StdScalar;
+$t = bless [], o;
+{
+  local *{ref(tied $t) . "::STORE"} = sub {};
+  undef $t;
+}
+warn $t;
+is @warnings, 1;
+object_ok $warnings[0], 'o',
+  'warn $tie_returning_object_that_stringifes_emptily';
+
 1;