diff options
| -rw-r--r-- | pod/perldelta.pod | 4 | ||||
| -rw-r--r-- | pp_hot.c | 10 | ||||
| -rw-r--r-- | t/op/tie_fetch_count.t | 11 |
3 files changed, 22 insertions, 3 deletions
diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 41c5d57ce2..82c2460210 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -512,6 +512,10 @@ C<setpgrp($foo)> used to be equivalent to C<($foo, setpgrp)>, because C<setpgrp> was ignoring its argument if there was just one. Now it is equivalent to C<setpgrp($foo,0)>. +=item * + +An assignment like C<*$tied = \&{"..."}> now calls FETCH only once. + =back =head1 Known Problems @@ -125,6 +125,8 @@ PP(pp_sassign) const U32 cv_type = SvTYPE(cv); const bool is_gv = isGV_with_GP(right); const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM; + STRLEN len = 0; + const char *nambeg = is_gv ? NULL : SvPV_nomg_const(right, len); if (!got_coderef) { assert(SvROK(cv)); @@ -135,7 +137,9 @@ PP(pp_sassign) context. */ if (!got_coderef && !is_gv && GIMME_V == G_VOID) { /* Is the target symbol table currently empty? */ - GV * const gv = gv_fetchsv(right, GV_NOINIT, SVt_PVGV); + GV * const gv = gv_fetchpvn_flags( + nambeg, len, SvUTF8(right)|GV_NOINIT, SVt_PVGV + ); if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) { /* Good. Create a new proxy constant subroutine in the target. The gv becomes a(nother) reference to the constant. */ @@ -153,7 +157,9 @@ PP(pp_sassign) /* Need to fix things up. */ if (!is_gv) { /* Need to fix GV. */ - right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV)); + right = MUTABLE_SV(gv_fetchpvn_flags( + nambeg, len, SvUTF8(right)|GV_ADD, SVt_PVGV + )); } if (!got_coderef) { diff --git a/t/op/tie_fetch_count.t b/t/op/tie_fetch_count.t index f4527a1a04..adb02f3718 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 => 218); + plan (tests => 219); } use strict; @@ -205,6 +205,15 @@ $dummy = &$var5 ; check_count '&{}'; tie my $var8 => 'main', 'main'; sub bolgy {} $var8->bolgy ; check_count '->method'; +{ + () = *swibble; + # This must be the name of an existing glob to trigger the maximum + # number of fetches in 5.14: + tie my $var9 => 'main', 'swibble'; + no strict 'refs'; + use constant glumscrin => 'shreggleboughet'; + *$var9 = \&{"glumscrin"}; check_count '*$tied = \&{"name of const"}'; +} ############################################### # Tests for $foo binop $foo # |