[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.

diff --git a/ext/B/t/optree_constants.t b/ext/B/t/optree_constants.t
index c0b6f99..7c109f0 100644 (file)
--- 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 7f217e7..44f3e18 100644 (file)
--- 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 709e92c..5f242a0 100644 (file)
--- 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 353bcc6..23f6d28 100644 (file)
--- 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 321eb1e..00ee7fb 100644 (file)
--- 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 b8c8bce..de1079e 100644 (file)
--- 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<