[perl #103492] Give lvalue cx to (s)printf args

Or potential lvalue context, like function calls.

The %n format code’s existence renders these two very much like func-
tion calls, as they can modify their arguments.

This allows sprintf("...%n", substr ...) to work.

6 files changed, 27 insertions, 15 deletions

diff --git a/ext/B/t/optree_constants.t b/ext/B/t/optree_constants.t
index c0b6f99553..7c109f0d85 100644
--- a/ext/B/t/optree_constants.t
+++ b/ext/B/t/optree_constants.t
@@ -211,25 +211,28 @@ my ($expect, $expect_nt) = (<<'EOT_EOT', <<'EONT_EONT');
 # -     <@> lineseq KP ->9
 # 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
 # 8        <@> prtf sK ->9
-# 2           <0> pushmark s ->3
-# 3           <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] s ->4
-# 4           <$> const[IV 42] s* ->5
-# 5           <$> const[PV "hithere"] s* ->6
-# 6           <$> const[NV 1.414213] s* ->7
-# 7           <$> const[NV 3.14159] s* ->8
+# 2           <0> pushmark sM ->3
+# 3           <$> const[PV "myint %d mystr %s myfl %f pi %f\n"] sM ->4
+# 4           <$> const[IV 42] sM* ->5
+# 5           <$> const[PV "hithere"] sM* ->6
+# 6           <$> const[NV 1.414213] sM* ->7
+# 7           <$> const[NV 3.14159] sM* ->8
 EOT_EOT
 # 9  <1> leavesub[1 ref] K/REFC,1 ->(end)
 # -     <@> lineseq KP ->9
 # 1        <;> nextstate(main 635 optree_constants.t:163) v:>,<,% ->2
 # 8        <@> prtf sK ->9
-# 2           <0> pushmark s ->3
-# 3           <$> const(PV "myint %d mystr %s myfl %f pi %f\n") s ->4
-# 4           <$> const(IV 42) s* ->5
-# 5           <$> const(PV "hithere") s* ->6
-# 6           <$> const(NV 1.414213) s* ->7
-# 7           <$> const(NV 3.14159) s* ->8
+# 2           <0> pushmark sM ->3
+# 3           <$> const(PV "myint %d mystr %s myfl %f pi %f\n") sM ->4
+# 4           <$> const(IV 42) sM* ->5
+# 5           <$> const(PV "hithere") sM* ->6
+# 6           <$> const(NV 1.414213) sM* ->7
+# 7           <$> const(NV 3.14159) sM* ->8
 EONT_EONT
 
+if($] < 5.015) {
+    s/M(?=\*? ->)//g for $expect, $expect_nt;
+}
 if($] < 5.009) {
     # 5.8.x's use constant has larger types
     foreach ($expect, $expect_nt) {
diff --git a/op.c b/op.c
index 7f217e70f4..44f3e186b0 100644
--- a/op.c
+++ b/op.c
@@ -1731,6 +1731,8 @@ Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags)
 
     assert( (o->op_flags & OPf_WANT) != OPf_WANT_VOID );
 
+    if (type == OP_PRTF || type == OP_SPRINTF) type = OP_ENTERSUB;
+
     switch (o->op_type) {
     case OP_UNDEF:
 	localize = 0;
@@ -8295,6 +8297,7 @@ Perl_ck_listiob(pTHX_ OP *o)
     if (!kid)
 	op_append_elem(o->op_type, o, newDEFSVOP());
 
+    if (o->op_type == OP_PRTF) return modkids(listkids(o), OP_PRTF);
     return listkids(o);
 }
 
diff --git a/opcode.h b/opcode.h
index 709e92c431..5f242a01a3 100644
--- a/opcode.h
+++ b/opcode.h
@@ -1430,7 +1430,7 @@ EXT Perl_check_t PL_check[] /* or perlvars.h */
 	Perl_ck_fun,		/* vec */
 	Perl_ck_index,		/* index */
 	Perl_ck_index,		/* rindex */
-	Perl_ck_fun,		/* sprintf */
+	Perl_ck_lfun,		/* sprintf */
 	Perl_ck_fun,		/* formline */
 	Perl_ck_fun,		/* ord */
 	Perl_ck_fun,		/* chr */
diff --git a/regen/opcodes b/regen/opcodes
index 353bcc68d8..23f6d2852a 100644
--- a/regen/opcodes
+++ b/regen/opcodes
@@ -199,7 +199,7 @@ vec		vec			ck_fun		ist@	S S S
 index		index			ck_index	isT@	S S S?
 rindex		rindex			ck_index	isT@	S S S?
 
-sprintf		sprintf			ck_fun		fmst@	S L
+sprintf		sprintf			ck_lfun		fmst@	S L
 formline	formline		ck_fun		ms@	S L
 ord		ord			ck_fun		ifsTu%	S?
 chr		chr			ck_fun		fsTu%	S?
diff --git a/t/io/print.t b/t/io/print.t
index 321eb1e85b..00ee7fb591 100644
--- a/t/io/print.t
+++ b/t/io/print.t
@@ -10,7 +10,7 @@ BEGIN {
 
 use strict 'vars';
 
-print "1..21\n";
+print "1..23\n";
 
 my $foo = 'STDOUT';
 print $foo "ok 1\n";
@@ -66,3 +66,8 @@ if (!exists &Errno::EBADF) {
     map print(+()), ('')x68;
     print "ok 21\n";
 }
+
+# printf with %n
+my $n = "abc";
+printf "ok 22%n - not really a test; just printing\n", substr $n,1,1;
+print "not " x ($n ne "a5c") . "ok 23 - printf with %n (got $n)\n";
diff --git a/t/op/sprintf.t b/t/op/sprintf.t
index b8c8bced4c..de1079e2d7 100644
--- a/t/op/sprintf.t
+++ b/t/op/sprintf.t
@@ -436,6 +436,7 @@ __END__
 >%l<        >''<          >%l INVALID<
 >%m<        >''<          >%m INVALID<
 >%s< >sprintf('%%n%n %d', $n, $n)< >%n 2< >Slight sneakiness to test %n<
+>%s< >$n="abc"; sprintf(' %n%s', substr($n,1,1), $n)< > a1c< >%n w/magic<
 >%o<        >2**32-1<     >37777777777<
 >%+o<       >2**32-1<     >37777777777<
 >%#o<       >2**32-1<     >037777777777<