This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
[perl #77362] Assigning glob to lvalue causes stringification
authorFather Chrysostomos <sprout@cpan.org>
Sun, 26 Sep 2010 18:09:28 +0000 (11:09 -0700)
committerFather Chrysostomos <sprout@cpan.org>
Sun, 26 Sep 2010 18:09:28 +0000 (11:09 -0700)
This test from t/op/gv.t was added by change 22315/4ce457a6:

{
    # test the assignment of a GLOB to an LVALUE
    my $e = '';
    local $SIG{__DIE__} = sub { $e = $_[0] };
    my $v;
    sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
    f($v);
    is ($v, '*main::DATA');
    my $x = <$v>;
    is ($x, "perl\n");
}

That change was the one that made glob-to-lvalue assignment work to
begin with. But this test passes in perl version *prior* to that
change.

This patch fixes the test and adds tests to make sure what is assigned
is actually a glob, and not just a string.

It also happens to fix the stringification bug. In doing so, it essen-
tially ‘enables’ globs-as-PVLVs.

It turns out that many different parts of the perl source don’t fully
take this into account, so this patch also fixes the following to work
with them (I tried to make these into separate patches, but they are
so intertwined it just got too complicated):

• GvIO(gv) to make readline and other I/O ops work.

• Autovivification of glob slots.

• tie *$pvlv

• *$pvlv = undef, *$pvlv = $number, *$pvlv = $ref

• Duplicating a filehandle accessed through a PVLV glob when the
  stringified form of the glob cannot be used to access the file
  handle (!)

• Using a PVLV glob as a subroutine reference

• Coderef assignment when the glob is no longer in the symbol table

• open with a PVLV glob for the filehandle

• -t and -T

• Unopened file handle warnings

gv.c
gv.h
pp_hot.c
pp_sys.c
sv.c
t/op/gv.t
util.c

diff --git a/gv.c b/gv.c
index 65c2971..11f82a2 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -45,7 +45,13 @@ Perl_gv_add_by_type(pTHX_ GV *gv, svtype type)
 {
     SV **where;
 
-    if (!gv || SvTYPE((const SV *)gv) != SVt_PVGV) {
+    if (
+        !gv
+     || (
+            SvTYPE((const SV *)gv) != SVt_PVGV
+         && SvTYPE((const SV *)gv) != SVt_PVLV
+        )
+    ) {
        const char *what;
        if (type == SVt_PVIO) {
            /*
diff --git a/gv.h b/gv.h
index 54722b7..c61f2e6 100644 (file)
--- a/gv.h
+++ b/gv.h
@@ -88,7 +88,17 @@ Return the SV from the GV.
 #endif
 
 #define GvREFCNT(gv)   (GvGP(gv)->gp_refcnt)
-#define GvIO(gv)       ((gv) && SvTYPE((const SV*)gv) == SVt_PVGV && GvGP(gv) ? GvIOp(gv) : NULL)
+#define GvIO(gv)                         \
+ (                                        \
+     (gv)                                  \
+  && (                                      \
+         SvTYPE((const SV*)(gv)) == SVt_PVGV \
+      || SvTYPE((const SV*)(gv)) == SVt_PVLV  \
+     )                                         \
+  && GvGP(gv)                                   \
+   ? GvIOp(gv)                                   \
+   : NULL                                         \
+ )
 #define GvIOp(gv)      (GvGP(gv)->gp_io)
 #define GvIOn(gv)      (GvIO(gv) ? GvIOp(gv) : GvIOp(gv_IOadd(gv)))
 
index 4f043fb..4db0e23 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -123,7 +123,7 @@ PP(pp_sassign)
     if (PL_op->op_private & OPpASSIGN_CV_TO_GV) {
        SV * const cv = SvRV(left);
        const U32 cv_type = SvTYPE(cv);
-       const U32 gv_type = SvTYPE(right);
+       const bool is_gv = isGV_with_GP(right);
        const bool got_coderef = cv_type == SVt_PVCV || cv_type == SVt_PVFM;
 
        if (!got_coderef) {
@@ -133,7 +133,7 @@ PP(pp_sassign)
        /* Can do the optimisation if right (LVALUE) is not a typeglob,
           left (RVALUE) is a reference to something, and we're in void
           context. */
-       if (!got_coderef && gv_type != SVt_PVGV && GIMME_V == G_VOID) {
+       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);
            if (SvTYPE(gv) != SVt_PVGV && !SvOK(gv)) {
@@ -151,7 +151,7 @@ PP(pp_sassign)
        }
 
        /* Need to fix things up.  */
-       if (gv_type != SVt_PVGV) {
+       if (!is_gv) {
            /* Need to fix GV.  */
            right = MUTABLE_SV(gv_fetchsv(right, GV_ADD, SVt_PVGV));
        }
@@ -201,7 +201,7 @@ PP(pp_sassign)
     /* Allow glob assignments like *$x = ..., which, when the glob has a
        SVf_FAKE flag, cannot be distinguished from $x = ... without looking
        at the op tree. */
-    if( SvTYPE(right) == SVt_PVGV && cBINOP->op_last->op_type == OP_RV2GV
+    if( isGV_with_GP(right) && cBINOP->op_last->op_type == OP_RV2GV
      && (wasfake = SvFLAGS(right) & SVf_FAKE) )
        SvFLAGS(right) &= ~SVf_FAKE;
     SvSetMagicSV(right, left);
@@ -2749,6 +2749,7 @@ PP(pp_entersub)
     case SVt_PVGV:
        if (!isGV_with_GP(sv))
            DIE(aTHX_ "Not a CODE reference");
+      we_have_a_glob:
        if (!(cv = GvCVu((const GV *)sv))) {
            HV *stash;
            cv = sv_2cv(sv, &stash, &gv, 0);
@@ -2759,6 +2760,9 @@ PP(pp_entersub)
            goto try_autoload;
        }
        break;
+    case SVt_PVLV:
+       if(isGV_with_GP(sv)) goto we_have_a_glob;
+       /*FALLTHROUGH*/
     default:
        if (sv == &PL_sv_yes) {         /* unfound import, ignore */
            if (hasargs)
index 1bc072d..ed4ec13 100644 (file)
--- a/pp_sys.c
+++ b/pp_sys.c
@@ -505,7 +505,7 @@ PP(pp_open)
 
     GV * const gv = MUTABLE_GV(*++MARK);
 
-    if (!isGV(gv))
+    if (!isGV(gv) && !(SvTYPE(gv) == SVt_PVLV && isGV_with_GP(gv)))
        DIE(aTHX_ PL_no_usym, "filehandle");
 
     if ((io = GvIOp(gv))) {
@@ -825,6 +825,7 @@ PP(pp_tie)
            methname = "TIEARRAY";
            break;
        case SVt_PVGV:
+       case SVt_PVLV:
            if (isGV_with_GP(varsv)) {
                methname = "TIEHANDLE";
                how = PERL_MAGIC_tiedscalar;
@@ -3336,7 +3337,7 @@ PP(pp_fttty)
 
     if (PL_op->op_flags & OPf_REF)
        gv = cGVOP_gv;
-    else if (isGV(TOPs))
+    else if (isGV_with_GP(TOPs))
        gv = MUTABLE_GV(POPs);
     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
        gv = MUTABLE_GV(SvRV(POPs));
@@ -3389,7 +3390,7 @@ PP(pp_fttext)
 
     if (PL_op->op_flags & OPf_REF)
        gv = cGVOP_gv;
-    else if (isGV(TOPs))
+    else if (isGV_with_GP(TOPs))
        gv = MUTABLE_GV(POPs);
     else if (SvROK(TOPs) && isGV(SvRV(TOPs)))
        gv = MUTABLE_GV(SvRV(POPs));
diff --git a/sv.c b/sv.c
index ad292d1..3edd796 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -3806,7 +3806,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
     switch (stype) {
     case SVt_NULL:
       undef_sstr:
-       if (dtype != SVt_PVGV) {
+       if (dtype != SVt_PVGV && dtype != SVt_PVLV) {
            (void)SvOK_off(dstr);
            return;
        }
@@ -3822,6 +3822,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
                sv_upgrade(dstr, SVt_PVIV);
                break;
            case SVt_PVGV:
+           case SVt_PVLV:
                goto end_of_first_switch;
            }
            (void)SvIOK_only(dstr);
@@ -3853,6 +3854,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
                sv_upgrade(dstr, SVt_PVNV);
                break;
            case SVt_PVGV:
+           case SVt_PVLV:
                goto end_of_first_switch;
            }
            SvNV_set(dstr, SvNVX(sstr));
@@ -3905,7 +3907,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
        /* case SVt_BIND: */
     case SVt_PVLV:
     case SVt_PVGV:
-       if (isGV_with_GP(sstr) && dtype <= SVt_PVGV) {
+       if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
            glob_assign_glob(dstr, sstr, dtype);
            return;
        }
@@ -3915,12 +3917,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
     case SVt_PVMG:
        if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) {
            mg_get(sstr);
-           if (SvTYPE(sstr) != stype) {
+           if (SvTYPE(sstr) != stype)
                stype = SvTYPE(sstr);
-               if (isGV_with_GP(sstr) && stype == SVt_PVGV && dtype <= SVt_PVGV) {
+           if (isGV_with_GP(sstr) && dtype <= SVt_PVLV) {
                    glob_assign_glob(dstr, sstr, dtype);
                    return;
-               }
            }
        }
        if (stype == SVt_PVLV)
@@ -3955,7 +3956,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
        else
            Perl_croak(aTHX_ "Cannot copy to %s", type);
     } else if (sflags & SVf_ROK) {
-       if (isGV_with_GP(dstr) && dtype == SVt_PVGV
+       if (isGV_with_GP(dstr)
            && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) {
            sstr = SvRV(sstr);
            if (sstr == dstr) {
@@ -3972,7 +3973,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
        }
 
        if (dtype >= SVt_PV) {
-           if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
+           if (isGV_with_GP(dstr)) {
                glob_assign_ref(dstr, sstr);
                return;
            }
@@ -3990,7 +3991,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags)
        assert(!(sflags & SVf_NOK));
        assert(!(sflags & SVf_IOK));
     }
-    else if (dtype == SVt_PVGV && isGV_with_GP(dstr)) {
+    else if (isGV_with_GP(dstr)) {
        if (!(sflags & SVf_OK)) {
            Perl_ck_warner(aTHX_ packWARN(WARN_MISC),
                           "Undefined value assigned to typeglob");
@@ -4591,7 +4592,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags)
 #endif
     if (SvROK(sv))
        sv_unref_flags(sv, flags);
-    else if (SvFAKE(sv) && SvTYPE(sv) == SVt_PVGV)
+    else if (SvFAKE(sv) && isGV_with_GP(sv))
        sv_unglob(sv);
     else if (SvFAKE(sv) && SvTYPE(sv) == SVt_REGEXP) {
        /* Need to downgrade the REGEXP to a simple(r) scalar. This is analagous
@@ -8444,6 +8445,7 @@ Perl_sv_2io(pTHX_ SV *const sv)
        io = MUTABLE_IO(sv);
        break;
     case SVt_PVGV:
+    case SVt_PVLV:
        if (isGV_with_GP(sv)) {
            gv = MUTABLE_GV(sv);
            io = GvIO(gv);
@@ -9047,7 +9049,8 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash)
     return sv;
 }
 
-/* Downgrades a PVGV to a PVMG.
+/* Downgrades a PVGV to a PVMG. If it’s actually a PVLV, we leave the type
+ * as it is after unglobbing it.
  */
 
 STATIC void
@@ -9060,7 +9063,7 @@ S_sv_unglob(pTHX_ SV *const sv)
 
     PERL_ARGS_ASSERT_SV_UNGLOB;
 
-    assert(SvTYPE(sv) == SVt_PVGV);
+    assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV);
     SvFAKE_off(sv);
     gv_efullname3(temp, MUTABLE_GV(sv), "*");
 
@@ -9080,14 +9083,16 @@ S_sv_unglob(pTHX_ SV *const sv)
     }
     isGV_with_GP_off(sv);
 
-    /* need to keep SvANY(sv) in the right arena */
-    xpvmg = new_XPVMG();
-    StructCopy(SvANY(sv), xpvmg, XPVMG);
-    del_XPVGV(SvANY(sv));
-    SvANY(sv) = xpvmg;
+    if(SvTYPE(sv) == SVt_PVGV) {
+       /* need to keep SvANY(sv) in the right arena */
+       xpvmg = new_XPVMG();
+       StructCopy(SvANY(sv), xpvmg, XPVMG);
+       del_XPVGV(SvANY(sv));
+       SvANY(sv) = xpvmg;
 
-    SvFLAGS(sv) &= ~SVTYPEMASK;
-    SvFLAGS(sv) |= SVt_PVMG;
+       SvFLAGS(sv) &= ~SVTYPEMASK;
+       SvFLAGS(sv) |= SVt_PVMG;
+    }
 
     /* Intentionally not calling any local SET magic, as this isn't so much a
        set operation as merely an internal storage change.  */
index 3044bd8..21f0d52 100644 (file)
--- a/t/op/gv.t
+++ b/t/op/gv.t
@@ -7,12 +7,12 @@
 BEGIN {
     chdir 't' if -d 't';
     @INC = '../lib';
+    require './test.pl';
 }
 
 use warnings;
 
-require './test.pl';
-plan( tests => 194 );
+plan( tests => 219 );
 
 # type coersion on assignment
 $foo = 'foo';
@@ -253,11 +253,12 @@ is($j[0], 1);
     # test the assignment of a GLOB to an LVALUE
     my $e = '';
     local $SIG{__DIE__} = sub { $e = $_[0] };
-    my $v;
+    my %v;
     sub f { $_[0] = 0; $_[0] = "a"; $_[0] = *DATA }
-    f($v);
-    is ($v, '*main::DATA');
-    my $x = <$v>;
+    f($v{v});
+    is ($v{v}, '*main::DATA');
+    is (ref\$v{v}, 'GLOB', 'lvalue assignment preserves globs');
+    my $x = readline $v{v};
     is ($x, "perl\n");
 }
 
@@ -272,6 +273,10 @@ is($j[0], 1);
     tie my @ary => "T";
     $ary[0] = *DATA;
     is ($ary[0], '*main::DATA');
+    is (
+      ref\tied(@ary)->[0], 'GLOB',
+     'tied elem assignment preserves globs'
+    );
     is ($e, '');
     my $x = readline $ary[0];
     is($x, "rocks\n");
@@ -652,6 +657,125 @@ EOF
     ok(!@warnings, "#76540 - no 'Attempt to free unreferenced scalar'");
 }
 
+# [perl #77362] various bugs related to globs as PVLVs
+{
+ no warnings qw 'once void';
+ my %h; # We pass a key of this hash to the subroutine to get a PVLV.
+ sub { for(shift) {
+  # Set up our glob-as-PVLV
+  $_ = *hon;
+
+  # Bad symbol for array
+  ok eval{ @$_; 1 }, 'PVLV glob slots can be autovivified' or diag $@;
+
+  # This should call TIEHANDLE, not TIESCALAR
+  *thext::TIEHANDLE = sub{};
+  ok eval{ tie *$_, 'thext'; 1 }, 'PVLV globs can be tied as handles'
+   or diag $@;
+
+  # Assigning undef to the glob should not overwrite it...
+  {
+   my $w;
+   local $SIG{__WARN__} = sub { $w = shift };
+   *$_ = undef;
+   is $_, "*main::hon", 'PVLV: assigning undef to the glob does nothing';
+   like $w, qr\Undefined value assigned to typeglob\,
+    'PVLV: assigning undef to the glob warns';
+  }
+
+  # Neither should number assignment...
+  *$_ = 1;
+  is $_, "*main::1", "PVLV: integer-to-glob assignment assigns a glob";
+  *$_ = 2.0;
+  is $_, "*main::2", "PVLV: float-to-glob assignment assigns a glob";
+
+  # Nor reference assignment.
+  *$_ = \*thit;
+  is $_, "*main::thit", "PVLV: globref-to-glob assignment assigns a glob";
+  *$_ = [];
+  is $_, "*main::thit", "PVLV: arrayref assignment assigns to the AV slot";
+
+  # Concatenation should still work.
+  ok eval { $_ .= 'thlew' }, 'PVLV concatenation does not die' or diag $@;
+  is $_, '*main::thitthlew', 'PVLV concatenation works';
+
+  # And we should be able to overwrite it with a string, number, or refer-
+  # ence, too, if we omit the *.
+  $_ = *hon; $_ = 'tzor';
+  is $_, 'tzor', 'PVLV: assigning a string over a glob';
+  $_ = *hon; $_ = 23;
+  is $_, 23, 'PVLV: assigning an integer over a glob';
+  $_ = *hon; $_ = 23.23;
+  is $_, 23.23, 'PVLV: assigning a float over a glob';
+  $_ = *hon; $_ = \my $sthat;
+  is $_, \$sthat, 'PVLV: assigning a reference over a glob';
+
+  # This bug was found by code inspection. Could this ever happen in
+  # real life? :-)
+  # This duplicates a file handle, accessing it through a PVLV glob, the
+  # glob having been removed from the symbol table, so a stringified form
+  # of it does not work. This checks that sv_2io does not stringify a PVLV.
+  $_ = *quin;
+  open *quin, "test.pl"; # test.pl is as good a file as any
+  delete $::{quin};
+  ok eval { open my $zow, "<&", $_ }, 'PVLV: sv_2io stringifieth not'
+   or diag $@;
+
+  # Similar tests to make sure sv_2cv etc. do not stringify.
+  *$_ = sub { 1 };
+  ok eval { &$_ }, "PVLV glob can be called as a sub" or diag $@;
+  *flelp = sub { 2 };
+  $_ = 'flelp';
+  is eval { &$_ }, 2, 'PVLV holding a string can be called as a sub'
+   or diag $@;
+
+  # Coderef-to-glob assignment when the glob is no longer accessible
+  # under its name: These tests are to make sure the OPpASSIGN_CV_TO_GV
+  # optimisation takes PVLVs into account, which is why the RHSs have to be
+  # named subs.
+  use constant gheen => 'quare';
+  $_ = *ming;
+  delete $::{ming};
+  *$_ = \&gheen;
+  is eval { &$_ }, 'quare',
+   'PVLV: constant assignment when the glob is detached from the symtab'
+    or diag $@;
+  $_ = *bength;
+  delete $::{bength};
+  *gheck = sub { 'lon' };
+  *$_ = \&gheck;
+  is eval { &$_ }, 'lon',
+   'PVLV: coderef assignment when the glob is detached from the symtab'
+    or diag $@;
+
+  # open should accept a PVLV as its first argument
+  $_ = *hon;
+  ok eval { open $_,'<', \my $thlext }, 'PVLV can be the first arg to open'
+   or diag $@;
+
+  # -t should not stringify
+  $_ = *thlit; delete $::{thlit};
+  *$_ = *STDOUT{IO};
+  ok defined -t $_, 'PVLV: -t does not stringify';
+
+  # neither should -T
+  open my $quile, "<", 'test.pl';
+  $_ = *$quile;
+  ok -T $_, "PVLV: -T does not stringify";
+  
+  # Unopened file handle
+  {
+   my $w;
+   local $SIG{__WARN__} = sub { $w .= shift };
+   $_ = *vor;
+   close $_;
+   like $w, qr\unopened filehandle vor\,
+    'PVLV globs get their names reported in unopened error messages';
+  }
+
+ }}->($h{k});
+}
+
 __END__
 Perl
 Rules
diff --git a/util.c b/util.c
index 2ab14d7..8bd57fc 100644 (file)
--- a/util.c
+++ b/util.c
@@ -3826,7 +3826,8 @@ Perl_my_fflush_all(pTHX)
 void
 Perl_report_evil_fh(pTHX_ const GV *gv, const IO *io, I32 op)
 {
-    const char * const name = gv && isGV(gv) ? GvENAME(gv) : NULL;
+    const char * const name
+     = gv && (isGV(gv) || isGV_with_GP(gv)) ? GvENAME(gv) : NULL;
 
     if (op == OP_phoney_OUTPUT_ONLY || op == OP_phoney_INPUT_ONLY) {
        if (ckWARN(WARN_IO)) {