Re: attributes are broken
authorSpider Boardman <spider@orb.nashua.nh.us>
Sun, 9 Dec 2001 00:09:23 +0000 (19:09 -0500)
committerJarkko Hietaniemi <jhi@iki.fi>
Sun, 9 Dec 2001 15:00:50 +0000 (15:00 +0000)
Message-Id: <200112090509.AAA02053@Orb.Nashua.NH.US>

p4raw-id: //depot/perl@13543

dump.c
embed.h
embed.pl
lib/attributes.pm
op.c
op.h
pod/perldelta.pod
pod/perltoc.pod
proto.h
t/op/attrs.t
xsutils.c

diff --git a/dump.c b/dump.c
index 863b006..321fecc 100644 (file)
--- a/dump.c
+++ b/dump.c
@@ -503,6 +503,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
                    sv_catpv(tmpsv, ",NOPAREN");
                if (o->op_private & OPpENTERSUB_INARGS)
                    sv_catpv(tmpsv, ",INARGS");
+               if (o->op_private & OPpENTERSUB_NOMOD)
+                   sv_catpv(tmpsv, ",NOMOD");
            }
            else {
                switch (o->op_private & OPpDEREF) {
@@ -549,7 +551,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o)
        else if (o->op_type == OP_FLOP) {
            if (o->op_private & OPpFLIP_LINENUM)
                sv_catpv(tmpsv, ",LINENUM");
-       } else if (o->op_type == OP_RV2CV) {
+       }
+       else if (o->op_type == OP_RV2CV) {
            if (o->op_private & OPpLVAL_INTRO)
                sv_catpv(tmpsv, ",INTRO");
        }
@@ -1381,7 +1384,7 @@ Perl_runops_debug(pTHX)
                              "WARNING: %"UVxf" changed from %"UVxf" to %"UVxf"\n",
                              PTR2UV(PL_watchaddr), PTR2UV(PL_watchok),
                              PTR2UV(*PL_watchaddr));
-           if (DEBUG_p_TEST_) debstack();
+           if (DEBUG_s_TEST_) debstack();
            if (DEBUG_t_TEST_) debop(PL_op);
            if (DEBUG_P_TEST_) debprof(PL_op);
        }
diff --git a/embed.h b/embed.h
index 3a82bc7..9523ef5 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define my_kid                 S_my_kid
 #define dup_attrlist           S_dup_attrlist
 #define apply_attrs            S_apply_attrs
+#define apply_attrs_my         S_apply_attrs_my
 #  if defined(PL_OP_SLAB_ALLOC)
 #define Slab_Alloc             S_Slab_Alloc
 #  endif
 #  endif
 #define cv_clone2(a,b)         S_cv_clone2(aTHX_ a,b)
 #define scalar_mod_type(a,b)   S_scalar_mod_type(aTHX_ a,b)
-#define my_kid(a,b)            S_my_kid(aTHX_ a,b)
+#define my_kid(a,b,c)          S_my_kid(aTHX_ a,b,c)
 #define dup_attrlist(a)                S_dup_attrlist(aTHX_ a)
-#define apply_attrs(a,b,c)     S_apply_attrs(aTHX_ a,b,c)
+#define apply_attrs(a,b,c,d)   S_apply_attrs(aTHX_ a,b,c,d)
+#define apply_attrs_my(a,b,c,d)        S_apply_attrs_my(aTHX_ a,b,c,d)
 #  if defined(PL_OP_SLAB_ALLOC)
 #define Slab_Alloc(a,b)                S_Slab_Alloc(aTHX_ a,b)
 #  endif
index 629772a..383c305 100755 (executable)
--- a/embed.pl
+++ b/embed.pl
@@ -1123,7 +1123,7 @@ Ap        |CV*    |gv_handler     |HV* stash|I32 id
 p      |OP*    |append_elem    |I32 optype|OP* head|OP* tail
 p      |OP*    |append_list    |I32 optype|LISTOP* first|LISTOP* last
 p      |I32    |apply          |I32 type|SV** mark|SV** sp
-Ap     |void   |apply_attrs_string|char *stashpv|CV *cv|char *attrstr|STRLEN len
+ApM    |void   |apply_attrs_string|char *stashpv|CV *cv|char *attrstr|STRLEN len
 Ap     |SV*    |avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash
 Ap     |bool   |avhv_exists_ent|AV *ar|SV* keysv|U32 hash
 Ap     |SV**   |avhv_fetch_ent |AV *ar|SV* keysv|I32 lval|U32 hash
@@ -2045,9 +2045,10 @@ s        |void   |cv_dump        |CV *cv
 #  endif
 s      |CV*    |cv_clone2      |CV *proto|CV *outside
 s      |bool   |scalar_mod_type|OP *o|I32 type
-s      |OP *   |my_kid         |OP *o|OP *attrs
+s      |OP *   |my_kid         |OP *o|OP *attrs|OP **imopsp
 s      |OP *   |dup_attrlist   |OP *o
-s      |void   |apply_attrs    |HV *stash|SV *target|OP *attrs
+s      |void   |apply_attrs    |HV *stash|SV *target|OP *attrs|bool for_my
+s      |void   |apply_attrs_my |HV *stash|OP *target|OP *attrs|OP **imopsp
 #  if defined(PL_OP_SLAB_ALLOC)
 s      |void*  |Slab_Alloc     |int m|size_t sz
 #  endif
index 3a6b3d5..4f6eef0 100644 (file)
@@ -1,6 +1,6 @@
 package attributes;
 
-our $VERSION = 0.04;
+our $VERSION = '0.04_01';
 
 @EXPORT_OK = qw(get reftype);
 @EXPORT = ();
@@ -98,7 +98,7 @@ attributes - get/set subroutine or variable attributes
 =head1 SYNOPSIS
 
   sub foo : method ;
-  my ($x,@y,%z) : Bent ;
+  my ($x,@y,%z) : Bent = 1;
   my $s = sub : method { ... };
 
   use attributes ();   # optional, to get subroutine declarations
@@ -120,25 +120,38 @@ the following:
 
 The second example in the synopsis does something equivalent to this:
 
-    use attributes __PACKAGE__, \$x, 'Bent';
-    use attributes __PACKAGE__, \@y, 'Bent';
-    use attributes __PACKAGE__, \%z, 'Bent';
+    use attributes ();
+    my ($x,@y,%z);
+    attributes::->import(__PACKAGE__, \$x, 'Bent');
+    attributes::->import(__PACKAGE__, \@y, 'Bent');
+    attributes::->import(__PACKAGE__, \%z, 'Bent');
+    ($x,@y,%z) = 1;
 
-Yes, that's three invocations.
+Yes, that's a lot of expansion.
 
 B<WARNING>: attribute declarations for variables are an I<experimental>
 feature.  The semantics of such declarations could change or be removed
 in future versions.  They are present for purposes of experimentation
 with what the semantics ought to be.  Do not rely on the current
-implementation of this feature. Variable attributes are currently
-not usable for tieing.
+implementation of this feature.
 
 There are only a few attributes currently handled by Perl itself (or
 directly by this module, depending on how you look at it.)  However,
 package-specific attributes are allowed by an extension mechanism.
 (See L<"Package-specific Attribute Handling"> below.)
 
-The setting of attributes happens at compile time.  An attempt to set
+The setting of subroutine attributes happens at compile time.
+Variable attributes in C<our> declarations are also applied at compile time.
+However, C<my> variables get their attributes applied at run-time.
+This means that you have to I<reach> the run-time component of the C<my>
+before those attributes will get applied.  For example:
+
+    my $x : Bent = 42 if 0;
+
+will neither assign 42 to $x I<nor> will it apply the C<Bent> attribute
+to the variable.
+
+An attempt to set
 an unrecognized attribute is a fatal error.  (The error is trappable, but
 it still stops the compilation within that C<eval>.)  Setting an attribute
 with a name that's all lowercase letters that's not a built-in attribute
@@ -180,6 +193,9 @@ as a scalar variable, as described in L<perlsub>.
 
 There are no built-in attributes for anything other than subroutines.
 
+=for hackers
+What about C<unique>?
+
 =head2 Available Subroutines
 
 The following subroutines are available for general use once this module
@@ -330,7 +346,8 @@ Code:
 
 Effect:
 
-    use attributes Canine => \$spot, "Watchful";
+    use attributes ();
+    attributes::->import(Canine => \$spot, "Watchful");
 
 =item 2.
 
@@ -341,7 +358,8 @@ Code:
 
 Effect:
 
-    use attributes Felis => \$cat, "Nervous";
+    use attributes ();
+    attributes::->import(Felis => \$cat, "Nervous");
 
 =item 3.
 
diff --git a/op.c b/op.c
index d3253d7..cb891c4 100644 (file)
--- a/op.c
+++ b/op.c
@@ -1416,6 +1416,8 @@ Perl_mod(pTHX_ OP *o, I32 type)
            op_null(((LISTOP*)cUNOPo->op_first)->op_first);/* disable pushmark */
            break;
        }
+       else if (o->op_private & OPpENTERSUB_NOMOD)
+           return o;
        else {                          /* lvalue subroutine call */
            o->op_private |= OPpLVAL_INTRO;
            PL_modcount = RETURN_UNLIMITED_NUMBER;
@@ -1886,7 +1888,7 @@ S_dup_attrlist(pTHX_ OP *o)
 }
 
 STATIC void
-S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
+S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my)
 {
     SV *stashsv;
 
@@ -1899,19 +1901,99 @@ S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs)
        stashsv = &PL_sv_no;
 
 #define ATTRSMODULE "attributes"
+#define ATTRSMODULE_PM "attributes.pm"
 
-    Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
-                    newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
-                    Nullsv,
-                    prepend_elem(OP_LIST,
-                                 newSVOP(OP_CONST, 0, stashsv),
-                                 prepend_elem(OP_LIST,
-                                              newSVOP(OP_CONST, 0,
-                                                      newRV(target)),
-                                              dup_attrlist(attrs))));
+    if (for_my) {
+       SV **svp;
+       /* Don't force the C<use> if we don't need it. */
+       svp = hv_fetch(GvHVn(PL_incgv), ATTRSMODULE_PM,
+                      sizeof(ATTRSMODULE_PM)-1, 0);
+       if (svp && *svp != &PL_sv_undef)
+           ;           /* already in %INC */
+       else
+           Perl_load_module(aTHX_ PERL_LOADMOD_NOIMPORT,
+                            newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+                            Nullsv);
+    }
+    else {
+       Perl_load_module(aTHX_ PERL_LOADMOD_IMPORT_OPS,
+                        newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1),
+                        Nullsv,
+                        prepend_elem(OP_LIST,
+                                     newSVOP(OP_CONST, 0, stashsv),
+                                     prepend_elem(OP_LIST,
+                                                  newSVOP(OP_CONST, 0,
+                                                          newRV(target)),
+                                                  dup_attrlist(attrs))));
+    }
     LEAVE;
 }
 
+STATIC void
+S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp)
+{
+    OP *pack, *imop, *arg;
+    SV *meth, *stashsv;
+
+    if (!attrs)
+       return;
+
+    assert(target->op_type == OP_PADSV ||
+          target->op_type == OP_PADHV ||
+          target->op_type == OP_PADAV);
+
+    /* Ensure that attributes.pm is loaded. */
+    apply_attrs(stash, pad_sv(target->op_targ), attrs, TRUE);
+
+    /* Need package name for method call. */
+    pack = newSVOP(OP_CONST, 0, newSVpvn(ATTRSMODULE, sizeof(ATTRSMODULE)-1));
+
+    /* Build up the real arg-list. */
+    if (stash)
+       stashsv = newSVpv(HvNAME(stash), 0);
+    else
+       stashsv = &PL_sv_no;
+    arg = newOP(OP_PADSV, 0);
+    arg->op_targ = target->op_targ;
+    arg = prepend_elem(OP_LIST,
+                      newSVOP(OP_CONST, 0, stashsv),
+                      prepend_elem(OP_LIST,
+                                   newUNOP(OP_REFGEN, 0,
+                                           mod(arg, OP_REFGEN)),
+                                   dup_attrlist(attrs)));
+
+    /* Fake up a method call to import */
+    meth = newSVpvn("import", 6);
+    (void)SvUPGRADE(meth, SVt_PVIV);
+    (void)SvIOK_on(meth);
+    PERL_HASH(SvUVX(meth), SvPVX(meth), SvCUR(meth));
+    imop = convert(OP_ENTERSUB, OPf_STACKED|OPf_SPECIAL|OPf_WANT_VOID,
+                  append_elem(OP_LIST,
+                              prepend_elem(OP_LIST, pack, list(arg)),
+                              newSVOP(OP_METHOD_NAMED, 0, meth)));
+    imop->op_private |= OPpENTERSUB_NOMOD;
+
+    /* Combine the ops. */
+    *imopsp = append_elem(OP_LIST, *imopsp, imop);
+}
+
+/*
+=notfor apidoc apply_attrs_string
+
+Attempts to apply a list of attributes specified by the C<attrstr> and
+C<len> arguments to the subroutine identified by the C<cv> argument which
+is expected to be associated with the package identified by the C<stashpv>
+argument (see L<attributes>).  It gets this wrong, though, in that it
+does not correctly identify the boundaries of the individual attribute
+specifications within C<attrstr>.  This is not really intended for the
+public API, but has to be listed here for systems such as AIX which
+need an explicit export list for symbols.  (It's called from XS code
+in support of the C<ATTRS:> keyword from F<xsubpp>.)  Patches to fix it
+to respect attribute syntax properly would be welcome.
+
+=cut
+*/
+
 void
 Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
                         char *attrstr, STRLEN len)
@@ -1944,7 +2026,7 @@ Perl_apply_attrs_string(pTHX_ char *stashpv, CV *cv,
 }
 
 STATIC OP *
-S_my_kid(pTHX_ OP *o, OP *attrs)
+S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp)
 {
     OP *kid;
     I32 type;
@@ -1955,7 +2037,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs)
     type = o->op_type;
     if (type == OP_LIST) {
        for (kid = cLISTOPo->op_first; kid; kid = kid->op_sibling)
-           my_kid(kid, attrs);
+           my_kid(kid, attrs, imopsp);
     } else if (type == OP_UNDEF) {
        return o;
     } else if (type == OP_RV2SV ||     /* "our" declaration */
@@ -1969,11 +2051,12 @@ S_my_kid(pTHX_ OP *o, OP *attrs)
                         (type == OP_RV2SV ? GvSV(gv) :
                          type == OP_RV2AV ? (SV*)GvAV(gv) :
                          type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)gv),
-                        attrs);
+                        attrs, FALSE);
         }
        o->op_private |= OPpOUR_INTRO;
        return o;
-    } else if (type != OP_PADSV &&
+    }
+    else if (type != OP_PADSV &&
             type != OP_PADAV &&
             type != OP_PADHV &&
             type != OP_PUSHMARK)
@@ -1985,7 +2068,6 @@ S_my_kid(pTHX_ OP *o, OP *attrs)
     }
     else if (attrs && type != OP_PUSHMARK) {
        HV *stash;
-       SV *padsv;
        SV **namesvp;
 
        PL_in_my = FALSE;
@@ -1997,8 +2079,7 @@ S_my_kid(pTHX_ OP *o, OP *attrs)
            stash = SvSTASH(*namesvp);
        else
            stash = PL_curstash;
-       padsv = PAD_SV(o->op_targ);
-       apply_attrs(stash, padsv, attrs);
+       apply_attrs_my(stash, o, attrs, imopsp);
     }
     o->op_flags |= OPf_MOD;
     o->op_private |= OPpLVAL_INTRO;
@@ -2008,11 +2089,24 @@ S_my_kid(pTHX_ OP *o, OP *attrs)
 OP *
 Perl_my_attrs(pTHX_ OP *o, OP *attrs)
 {
+    OP *rops = Nullop;
+    int maybe_scalar = 0;
+
     if (o->op_flags & OPf_PARENS)
        list(o);
+    else
+       maybe_scalar = 1;
     if (attrs)
        SAVEFREEOP(attrs);
-    o = my_kid(o, attrs);
+    o = my_kid(o, attrs, &rops);
+    if (rops) {
+       if (maybe_scalar && o->op_type == OP_PADSV) {
+           o = scalar(append_list(OP_LIST, (LISTOP*)rops, (LISTOP*)o));
+           o->op_private |= OPpLVAL_INTRO;
+       }
+       else
+           o = append_list(OP_LIST, (LISTOP*)o, (LISTOP*)rops);
+    }
     PL_in_my = FALSE;
     PL_in_my_stash = Nullhv;
     return o;
@@ -2021,7 +2115,7 @@ Perl_my_attrs(pTHX_ OP *o, OP *attrs)
 OP *
 Perl_my(pTHX_ OP *o)
 {
-    return my_kid(o, Nullop);
+    return my_attrs(o, Nullop);
 }
 
 OP *
@@ -3474,6 +3568,11 @@ S_list_assignment(pTHX_ register OP *o)
        return FALSE;
     }
 
+    if (o->op_type == OP_LIST &&
+       (o->op_flags & OPf_WANT) == OPf_WANT_SCALAR &&
+       o->op_private & OPpLVAL_INTRO)
+       return FALSE;
+
     if (o->op_type == OP_LIST || o->op_flags & OPf_PARENS ||
        o->op_type == OP_RV2AV || o->op_type == OP_RV2HV ||
        o->op_type == OP_ASLICE || o->op_type == OP_HSLICE)
@@ -4766,7 +4865,7 @@ Perl_newATTRSUB(pTHX_ I32 floor, OP *o, OP *proto, OP *attrs, OP *block)
            else
                stash = PL_curstash;
        }
-       apply_attrs(stash, rcv, attrs);
+       apply_attrs(stash, rcv, attrs, FALSE);
     }
     if (cv) {                          /* must reuse cv if autoloaded */
        if (!block) {
diff --git a/op.h b/op.h
index 415514d..3348435 100644 (file)
--- a/op.h
+++ b/op.h
@@ -153,6 +153,7 @@ Deprecated.  Use C<GIMME_V> instead.
   /* OP_ENTERSUB only */
 #define OPpENTERSUB_DB         16      /* Debug subroutine. */
 #define OPpENTERSUB_HASTARG    32      /* Called from OP tree. */
+#define OPpENTERSUB_NOMOD      64      /* Immune to mod() for :attrlist. */
   /* OP_RV2CV only */
 #define OPpENTERSUB_AMPER      8       /* Used & form to call. */
 #define OPpENTERSUB_NOPAREN    128     /* bare sub call (without parens) */
index 31e9b30..7c1ddd9 100644 (file)
@@ -65,6 +65,14 @@ change will probably break backward compatibility with compiled
 modules.  The change was made to make Perl more compliant with other
 applications like modperl which are using the AIX native interface.
 
+=head2 Attributes for C<my> variables now handled at run-time.
+
+The C<my EXPR : ATTRS> syntax now applies variable attributes at
+run-time.  (Subroutine and C<our> variables still get attributes applied
+at compile-time.)  See L<attributes> for additional details.  In particular,
+however, this allows variable attributes to be useful for C<tie> interfaces,
+which was a deficiency of earlier releaes.
+
 =head2 Socket Extension Dynamic in VMS
 
 The Socket extension is now dynamically loaded instead of being
@@ -681,7 +689,7 @@ to Quoted-Printable.  See L<PerlIO::Via>.
 =item *
 
 C<Pod::ParseLink>, by Russ Allbery, has been added,
-to parse L&lt;&gt; links in pods as described in the new
+to parse LZ<><> links in pods as described in the new
 perlpodspec.
 
 =item *
@@ -2221,7 +2229,8 @@ Made possible to propagate customised exceptions via croak()ing.
 
 =item *
 
-Now xsubs can have attributes just like subs.
+Now xsubs can have attributes just like subs.  (Well, at least the
+built-in attributes.)
 
 =item *
 
@@ -2509,15 +2518,6 @@ hard-to-fix ways.  As a stop-gap measure to avoid people from getting
 frustrated at the mysterious results (core dumps, most often) it is
 for now forbidden (you will get a fatal error even from an attempt).
 
-=head2 Variable Attributes are not Currently Usable for Tieing
-
-This limitation will hopefully be fixed in future.  (Subroutine
-attributes work fine for tieing, see L<Attribute::Handlers>).
-
-One way to run into this limitation is to have a loop variable with
-attributes within a loop: the tie is called only once, not for each
-iteration of the loop.
-
 =head2 Building Extensions Can Fail Because Of Largefiles
 
 Some extensions like mod_perl are known to have issues with
index 9467051..81e202c 100644 (file)
@@ -4991,6 +4991,8 @@ I<The Road goes ever on and on, down from the door where it began.>
 
 =item AIX Dynaloading
 
+=item Attributes for C<my> variables now handled at run-time.
+
 =item Socket Extension Dynamic in VMS
 
 =item IEEE-format Floating Point Default on OpenVMS Alpha
@@ -5101,8 +5103,6 @@ I<The Road goes ever on and on, down from the door where it began.>
 
 =item Self-tying of Arrays and Hashes Is Forbidden
 
-=item Variable Attributes are not Currently Usable for Tieing
-
 =item Building Extensions Can Fail Because Of Largefiles
 
 =item Unicode Support on EBCDIC Still Spotty
diff --git a/proto.h b/proto.h
index ebd00fd..5c9a514 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1033,9 +1033,10 @@ STATIC void      S_cv_dump(pTHX_ CV *cv);
 #  endif
 STATIC CV*     S_cv_clone2(pTHX_ CV *proto, CV *outside);
 STATIC bool    S_scalar_mod_type(pTHX_ OP *o, I32 type);
-STATIC OP *    S_my_kid(pTHX_ OP *o, OP *attrs);
+STATIC OP *    S_my_kid(pTHX_ OP *o, OP *attrs, OP **imopsp);
 STATIC OP *    S_dup_attrlist(pTHX_ OP *o);
-STATIC void    S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs);
+STATIC void    S_apply_attrs(pTHX_ HV *stash, SV *target, OP *attrs, bool for_my);
+STATIC void    S_apply_attrs_my(pTHX_ HV *stash, OP *target, OP *attrs, OP **imopsp);
 #  if defined(PL_OP_SLAB_ALLOC)
 STATIC void*   S_Slab_Alloc(pTHX_ int m, size_t sz);
 #  endif
index e8e11b3..611fb66 100644 (file)
@@ -19,6 +19,7 @@ print "1..".NTESTS."\n";
 $SIG{__WARN__} = sub { die @_ };
 
 sub mytest {
+    my $bad = '';
     if (!$@ ne !$_[0] || $_[0] && $@ !~ $_[0]) {
        if ($@) {
            my $x = $@;
@@ -35,15 +36,15 @@ sub mytest {
            print "# Expected success\n";
        }
        $failed = 1;
-       print "not ";
+       $bad = 'not ';
     }
     elsif (@_ == 3 && $_[1] ne $_[2]) {
        print "# Got: $_[1]\n";
        print "# Expected: $_[2]\n";
        $failed = 1;
-       print "not ";
+       $bad = 'not ';
     }
-    print "ok ",++$test,"\n";
+    print $bad."ok ".++$test."\n";
 }
 
 eval 'sub t1 ($) : locked { $_[0]++ }';
@@ -173,6 +174,31 @@ BEGIN {++$ntests}
 mytest '', "@attrs", "locked method Z";
 BEGIN {++$ntests}
 
+# Begin testing attributes that tie
+
+{
+    package Ttie;
+    sub DESTROY {}
+    sub TIESCALAR { my $x = $_[1]; bless \$x, $_[0]; }
+    sub FETCH { ${$_[0]} }
+    sub STORE {
+       #print "# In Ttie::STORE\n";
+       ::mytest '';
+       ${$_[0]} = $_[1]*2;
+    }
+    package Tloop;
+    sub MODIFY_SCALAR_ATTRIBUTES { tie ${$_[1]}, 'Ttie', -1; (); }
+}
+
+eval '
+    package Tloop;
+    for my $i (0..2) {
+       my $x : TieLoop = $i;
+       $x != $i*2 and ::mytest "", $x, $i*2;
+    }
+';
+mytest;
+BEGIN {$ntests += 4}
 
 # Other tests should be added above this line
 
index 81bb2fc..8b7db4c 100644 (file)
--- a/xsutils.c
+++ b/xsutils.c
@@ -84,8 +84,8 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
                        continue;
                    }
                    break;
-               case 's':
-      if (strEQ(name, "unique")) {
+               case 'u':
+                   if (strEQ(name, "unique")) {
                        if (negated)
                            GvUNIQUE_off(CvGV((CV*)sv));
                        else
@@ -99,11 +99,17 @@ modify_SV_attributes(pTHX_ SV *sv, SV **retlist, SV **attrlist, int numattrs)
            break;
        default:
            switch ((int)len) {
-              case 6:
+           case 6:
                switch (*name) {
-                  case 's':
-      if (strEQ(name, "unique")) {
-                        /* toke.c has already marked as GVf_UNIQUE */
+               case 'u':
+                   if (strEQ(name, "unique")) {
+                       if (SvTYPE(sv) == SVt_PVGV) {
+                           if (negated)
+                               GvUNIQUE_off(sv);
+                           else
+                               GvUNIQUE_on(sv);
+                       }
+                       /* Hope this came from toke.c if not a GV. */
                         continue;
                     }
                 }
@@ -190,7 +196,11 @@ usage:
        if (cvflags & CVf_METHOD)
            XPUSHs(sv_2mortal(newSVpvn("method", 6)));
         if (GvUNIQUE(CvGV((CV*)sv)))
-     XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
+           XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
+       break;
+    case SVt_PVGV:
+       if (GvUNIQUE(sv))
+           XPUSHs(sv_2mortal(newSVpvn("unique", 6)));
        break;
     default:
        break;