This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
Implement "my $_".
authorRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Tue, 3 Feb 2004 19:41:11 +0000 (19:41 +0000)
committerRafael Garcia-Suarez <rgarciasuarez@gmail.com>
Tue, 3 Feb 2004 19:41:11 +0000 (19:41 +0000)
p4raw-id: //depot/perl@22263

15 files changed:
MANIFEST
gv.c
op.c
op.h
opcode.h
opcode.pl
pod/perl591delta.pod
pod/perlapi.pod
pod/perlvar.pod
pp.c
pp_ctl.c
pp_hot.c
regexec.c
t/op/mydef.t [new file with mode: 0644]
toke.c

index c9780fc..c17da1d 100644 (file)
--- a/MANIFEST
+++ b/MANIFEST
@@ -2815,6 +2815,7 @@ t/op/method.t                     See if method calls work
 t/op/mkdir.t                   See if mkdir works
 t/op/my_stash.t                        See if my Package works
 t/op/my.t                      See if lexical scoping works
+t/op/mydef.t                   See if "my $_" works
 t/op/numconvert.t              See if accessing fields does not change numeric values
 t/op/oct.t                     See if oct and hex work
 t/op/ord.t                     See if ord works
diff --git a/gv.c b/gv.c
index b297cb6..aa2befc 100644 (file)
--- a/gv.c
+++ b/gv.c
@@ -693,6 +693,10 @@ Perl_gv_fetchpv(pTHX_ const char *nambeg, I32 add, I32 sv_type)
     }
     len = namend - name;
 
+    /* $_ should always be in main:: even when our'ed */
+    if (*name == '_' && !name[1])
+       stash = PL_defstash;
+
     /* No stash in name, so see how we can default */
 
     if (!stash) {
diff --git a/op.c b/op.c
index 5fd21bf..62d9b03 100644 (file)
--- a/op.c
+++ b/op.c
@@ -155,11 +155,11 @@ Perl_allocmy(pTHX_ char *name)
 {
     PADOFFSET off;
 
-    /* complain about "my $_" etc etc */
+    /* complain about "my $<special_var>" etc etc */
     if (!(PL_in_my == KEY_our ||
          isALPHA(name[1]) ||
          (USE_UTF8_IN_NAMES && UTF8_IS_START(name[1])) ||
-         (name[1] == '_' && (int)strlen(name) > 2)))
+         (name[1] == '_' && (*name == '$' || (int)strlen(name) > 2))))
     {
        if (!isPRINT(name[1]) || strchr("\t\n\r\f", name[1])) {
            /* 1999-02-27 mjd@plover.com */
@@ -1673,6 +1673,7 @@ OP *
 Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
 {
     OP *o;
+    bool ismatchop = 0;
 
     if (ckWARN(WARN_MISC) &&
       (left->op_type == OP_RV2AV ||
@@ -1697,10 +1698,14 @@ Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
        no_bareword_allowed(right);
     }
 
-    if (!(right->op_flags & OPf_STACKED) &&
-       (right->op_type == OP_MATCH ||
-       right->op_type == OP_SUBST ||
-       right->op_type == OP_TRANS)) {
+    ismatchop = right->op_type == OP_MATCH ||
+               right->op_type == OP_SUBST ||
+               right->op_type == OP_TRANS;
+    if (ismatchop && right->op_private & OPpTARGET_MY) {
+       right->op_targ = 0;
+       right->op_private &= ~OPpTARGET_MY;
+    }
+    if (!(right->op_flags & OPf_STACKED) && ismatchop) {
        right->op_flags |= OPf_STACKED;
        if (right->op_type != OP_MATCH &&
             ! (right->op_type == OP_TRANS &&
@@ -1801,7 +1806,15 @@ Perl_block_end(pTHX_ I32 floor, OP *seq)
 STATIC OP *
 S_newDEFSVOP(pTHX)
 {
-    return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
+    I32 offset = pad_findmy("$_");
+    if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
+       return newSVREF(newGVOP(OP_GV, 0, PL_defgv));
+    }
+    else {
+       OP *o = newOP(OP_PADSV, 0);
+       o->op_targ = offset;
+       return o;
+    }
 }
 
 void
@@ -5362,6 +5375,7 @@ Perl_ck_grep(pTHX_ OP *o)
     LOGOP *gwop;
     OP *kid;
     OPCODE type = o->op_type == OP_GREPSTART ? OP_GREPWHILE : OP_MAPWHILE;
+    I32 offset;
 
     o->op_ppaddr = PL_ppaddr[OP_GREPSTART];
     NewOp(1101, gwop, 1, LOGOP);
@@ -5393,10 +5407,17 @@ Perl_ck_grep(pTHX_ OP *o)
     gwop->op_ppaddr = PL_ppaddr[type];
     gwop->op_first = listkids(o);
     gwop->op_flags |= OPf_KIDS;
-    gwop->op_private = 1;
     gwop->op_other = LINKLIST(kid);
-    gwop->op_targ = pad_alloc(type, SVs_PADTMP);
     kid->op_next = (OP*)gwop;
+    offset = pad_findmy("$_");
+    if (offset == NOT_IN_PAD || PAD_COMPNAME_FLAGS(offset) & SVpad_OUR) {
+       o->op_private = gwop->op_private = 0;
+       gwop->op_targ = pad_alloc(type, SVs_PADTMP);
+    }
+    else {
+       o->op_private = gwop->op_private = OPpGREP_LEX;
+       gwop->op_targ = o->op_targ = offset;
+    }
 
     kid = cLISTOPo->op_first->op_sibling;
     if (!kid || !kid->op_sibling)
@@ -5542,7 +5563,15 @@ Perl_ck_sassign(pTHX_ OP *o)
 OP *
 Perl_ck_match(pTHX_ OP *o)
 {
-    o->op_private |= OPpRUNTIME;
+    if (o->op_type != OP_QR) {
+       I32 offset = pad_findmy("$_");
+       if (offset != NOT_IN_PAD && !(PAD_COMPNAME_FLAGS(offset) & SVpad_OUR)) {
+           o->op_targ = offset;
+           o->op_private |= OPpTARGET_MY;
+       }
+    }
+    if (o->op_type == OP_MATCH || o->op_type == OP_QR)
+       o->op_private |= OPpRUNTIME;
     return o;
 }
 
diff --git a/op.h b/op.h
index 539393d..aeaae1c 100644 (file)
--- a/op.h
+++ b/op.h
@@ -135,9 +135,11 @@ Deprecated.  Use C<GIMME_V> instead.
 #define OPpTRANS_TO_UTF                2
 #define OPpTRANS_IDENTICAL     4       /* right side is same as left */
 #define OPpTRANS_SQUASH                8
-#define OPpTRANS_DELETE                16
+    /* 16 is used for OPpTARGET_MY */
 #define OPpTRANS_COMPLEMENT    32
 #define OPpTRANS_GROWS         64
+#define OPpTRANS_DELETE                128
+#define OPpTRANS_ALL   (OPpTRANS_FROM_UTF|OPpTRANS_TO_UTF|OPpTRANS_IDENTICAL|OPpTRANS_SQUASH|OPpTRANS_COMPLEMENT|OPpTRANS_GROWS|OPpTRANS_DELETE)
 
 /* Private for OP_REPEAT */
 #define OPpREPEAT_DOLIST       64      /* List replication. */
@@ -215,6 +217,9 @@ Deprecated.  Use C<GIMME_V> instead.
         ((op)->op_type) == OP_FTEWRITE ||      \
         ((op)->op_type) == OP_FTEEXEC)
 
+/* Private for OP_(MAP|GREP)(WHILE|START) */
+#define OPpGREP_LEX            2       /* iterate over lexical $_ */
+    
 struct op {
     BASEOP
 };
index 5125598..81ab818 100644 (file)
--- a/opcode.h
+++ b/opcode.h
@@ -1150,9 +1150,9 @@ EXT OP * (CPERLscope(*PL_check)[]) (pTHX_ OP *op) = {
        MEMBER_TO_FPTR(Perl_ck_null),   /* regcomp */
        MEMBER_TO_FPTR(Perl_ck_match),  /* match */
        MEMBER_TO_FPTR(Perl_ck_match),  /* qr */
-       MEMBER_TO_FPTR(Perl_ck_null),   /* subst */
+       MEMBER_TO_FPTR(Perl_ck_match),  /* subst */
        MEMBER_TO_FPTR(Perl_ck_null),   /* substcont */
-       MEMBER_TO_FPTR(Perl_ck_null),   /* trans */
+       MEMBER_TO_FPTR(Perl_ck_match),  /* trans */
        MEMBER_TO_FPTR(Perl_ck_sassign),        /* sassign */
        MEMBER_TO_FPTR(Perl_ck_null),   /* aassign */
        MEMBER_TO_FPTR(Perl_ck_spair),  /* chop */
index dc5b66e..1fe1f3c 100755 (executable)
--- a/opcode.pl
+++ b/opcode.pl
@@ -493,9 +493,9 @@ regcreset   regexp internal reset   ck_fun          s1      S
 regcomp                regexp compilation      ck_null         s|      S
 match          pattern match (m//)     ck_match        d/
 qr             pattern quote (qr//)    ck_match        s/
-subst          substitution (s///)     ck_null         dis/    S
+subst          substitution (s///)     ck_match        dis/    S
 substcont      substitution iterator   ck_null         dis|    
-trans          transliteration (tr///) ck_null         is"     S
+trans          transliteration (tr///) ck_match        is"     S
 
 # Lvalue operators.
 # sassign is special-cased for op class
index 52b54fd..bf26c2b 100644 (file)
@@ -11,6 +11,23 @@ the 5.9.1 release.
 
 =head1 Core Enhancements
 
+=head2 Lexical C<$_>
+
+The default variable C<$_> can now be lexicalized, by declaring it like
+any other lexical variable, with a simple
+
+    my $_;
+
+The operations that default on C<$_> will use the lexically-scoped
+version of C<$_> when it exists, instead of the global C<$_>.
+
+In a C<map> or a C<grep> block, if C<$_> was previously my'ed, then the
+C<$_> inside the block is lexical as well (and scoped to the block).
+
+In a scope where C<$_> has been lexicalized, you can still have access to
+the global version of C<$_> by using C<$::_>, or, more simply, by
+overriding the lexical declaration with C<our $_>.
+
 =head2 Tied hashes in scalar context
 
 As of perl 5.8.2, tied hashes did not return anything useful in scalar
index 61e52a1..5c0bee4 100644 (file)
@@ -3027,22 +3027,22 @@ which guarantees to evaluate sv only once.
 =for hackers
 Found in file sv.h
 
-=item SvNVx
+=item SvNVX
 
-Coerces the given SV to a double and returns it. Guarantees to evaluate
-sv only once. Use the more efficient C<SvNV> otherwise.
+Returns the raw value in the SV's NV slot, without checks or conversions.
+Only use when you are sure SvNOK is true. See also C<SvNV()>.
 
-       NV      SvNVx(SV* sv)
+       NV      SvNVX(SV* sv)
 
 =for hackers
 Found in file sv.h
 
-=item SvNVX
+=item SvNVx
 
-Returns the raw value in the SV's NV slot, without checks or conversions.
-Only use when you are sure SvNOK is true. See also C<SvNV()>.
+Coerces the given SV to a double and returns it. Guarantees to evaluate
+sv only once. Use the more efficient C<SvNV> otherwise.
 
-       NV      SvNVX(SV* sv)
+       NV      SvNVx(SV* sv)
 
 =for hackers
 Found in file sv.h
@@ -3236,21 +3236,21 @@ Like C<SvPV_nolen>, but converts sv to utf8 first if necessary.
 =for hackers
 Found in file sv.h
 
-=item SvPVX
+=item SvPVx
 
-Returns a pointer to the physical string in the SV.  The SV must contain a
-string.
+A version of C<SvPV> which guarantees to evaluate sv only once.
 
-       char*   SvPVX(SV* sv)
+       char*   SvPVx(SV* sv, STRLEN len)
 
 =for hackers
 Found in file sv.h
 
-=item SvPVx
+=item SvPVX
 
-A version of C<SvPV> which guarantees to evaluate sv only once.
+Returns a pointer to the physical string in the SV.  The SV must contain a
+string.
 
-       char*   SvPVx(SV* sv, STRLEN len)
+       char*   SvPVX(SV* sv)
 
 =for hackers
 Found in file sv.h
@@ -3498,22 +3498,22 @@ for a version which guarantees to evaluate sv only once.
 =for hackers
 Found in file sv.h
 
-=item SvUVx
+=item SvUVX
 
-Coerces the given SV to an unsigned integer and returns it. Guarantees to
-evaluate sv only once. Use the more efficient C<SvUV> otherwise.
+Returns the raw value in the SV's UV slot, without checks or conversions.
+Only use when you are sure SvIOK is true. See also C<SvUV()>.
 
-       UV      SvUVx(SV* sv)
+       UV      SvUVX(SV* sv)
 
 =for hackers
 Found in file sv.h
 
-=item SvUVX
+=item SvUVx
 
-Returns the raw value in the SV's UV slot, without checks or conversions.
-Only use when you are sure SvIOK is true. See also C<SvUV()>.
+Coerces the given SV to an unsigned integer and returns it. Guarantees to
+evaluate sv only once. Use the more efficient C<SvUV> otherwise.
 
-       UV      SvUVX(SV* sv)
+       UV      SvUVx(SV* sv)
 
 =for hackers
 Found in file sv.h
index 50d30d4..8fc7441 100644 (file)
@@ -177,6 +177,11 @@ test.  Outside a C<while> test, this will not happen.
 
 =back
 
+As C<$_> is a global variable, this may lead in some cases to unwanted
+side-effects.  As of perl 5.9.1, you can now use a lexical version of
+C<$_> by declaring it in a file or in a block with C<my>.  Moreover,
+declaring C<our $> restores the global C<$_> in the current scope.
+
 (Mnemonic: underline is understood in certain operations.)
 
 =back
diff --git a/pp.c b/pp.c
index 6f3703d..f06e71f 100644 (file)
--- a/pp.c
+++ b/pp.c
@@ -680,6 +680,8 @@ PP(pp_trans)
 
     if (PL_op->op_flags & OPf_STACKED)
        sv = POPs;
+    else if (PL_op->op_private & OPpTARGET_MY)
+       sv = GETTARGET;
     else {
        sv = DEFSV;
        EXTEND(SP,1);
index 9b2ca63..42d63c6 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -863,14 +863,19 @@ PP(pp_grepstart)
     ENTER;                                     /* enter outer scope */
 
     SAVETMPS;
-    /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
-    SAVESPTR(DEFSV);
+    if (PL_op->op_private & OPpGREP_LEX)
+       SAVESPTR(PAD_SVl(PL_op->op_targ));
+    else
+       SAVE_DEFSV;
     ENTER;                                     /* enter inner scope */
     SAVEVPTR(PL_curpm);
 
     src = PL_stack_base[*PL_markstack_ptr];
     SvTEMP_off(src);
-    DEFSV = src;
+    if (PL_op->op_private & OPpGREP_LEX)
+       PAD_SVl(PL_op->op_targ) = src;
+    else
+       DEFSV = src;
 
     PUTBACK;
     if (PL_op->op_type == OP_MAPSTART)
@@ -965,7 +970,10 @@ PP(pp_mapwhile)
        /* set $_ to the new source item */
        src = PL_stack_base[PL_markstack_ptr[-1]];
        SvTEMP_off(src);
-       DEFSV = src;
+       if (PL_op->op_private & OPpGREP_LEX)
+           PAD_SVl(PL_op->op_targ) = src;
+       else
+           DEFSV = src;
 
        RETURNOP(cLOGOP->op_other);
     }
index 1dffe94..e884e2d 100644 (file)
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1195,6 +1195,8 @@ PP(pp_match)
 
     if (PL_op->op_flags & OPf_STACKED)
        TARG = POPs;
+    else if (PL_op->op_private & OPpTARGET_MY)
+       GETTARGET;
     else {
        TARG = DEFSV;
        EXTEND(SP,1);
@@ -1958,6 +1960,8 @@ PP(pp_subst)
     dstr = (pm->op_pmflags & PMf_CONST) ? POPs : Nullsv;
     if (PL_op->op_flags & OPf_STACKED)
        TARG = POPs;
+    else if (PL_op->op_private & OPpTARGET_MY)
+       GETTARGET;
     else {
        TARG = DEFSV;
        EXTEND(SP,1);
@@ -2305,7 +2309,10 @@ PP(pp_grepwhile)
 
        src = PL_stack_base[*PL_markstack_ptr];
        SvTEMP_off(src);
-       DEFSV = src;
+       if (PL_op->op_private & OPpGREP_LEX)
+           PAD_SVl(PL_op->op_targ) = src;
+       else
+           DEFSV = src;
 
        RETURNOP(cLOGOP->op_other);
     }
index 464ceaf..fae7004 100644 (file)
--- a/regexec.c
+++ b/regexec.c
@@ -2104,8 +2104,7 @@ S_regtry(pTHX_ regexp *prog, char *startpos)
        if (PL_reg_sv) {
            /* Make $_ available to executed code. */
            if (PL_reg_sv != DEFSV) {
-               /* SAVE_DEFSV does *not* suffice here for USE_5005THREADS */
-               SAVESPTR(DEFSV);
+               SAVE_DEFSV;
                DEFSV = PL_reg_sv;
            }
        
diff --git a/t/op/mydef.t b/t/op/mydef.t
new file mode 100644 (file)
index 0000000..9469ae1
--- /dev/null
@@ -0,0 +1,142 @@
+#!./perl -w
+
+BEGIN {
+    chdir 't' if -d 't';
+    @INC = '../lib';
+}
+
+print "1..48\n";
+
+my $test = 0;
+sub ok ($$) {
+    my ($ok, $name) = @_;
+    ++$test;
+    print $ok ? "ok $test - $name\n" : "not ok $test - $name\n";
+}
+
+$_ = 'global';
+ok( $_ eq 'global', '$_ initial value' );
+s/oba/abo/;
+ok( $_ eq 'glabol', 's/// on global $_' );
+
+{
+    my $_ = 'local';
+    ok( $_ eq 'local', 'my $_ initial value' );
+    s/oca/aco/;
+    ok( $_ eq 'lacol', 's/// on my $_' );
+    /(..)/;
+    ok( $1 eq 'la', '// on my $_' );
+    ok( tr/c/d/ == 1, 'tr/// on my $_ counts correctly' );
+    ok( $_ eq 'ladol', 'tr/// on my $_' );
+    {
+       my $_ = 'nested';
+       ok( $_ eq 'nested', 'my $_ nested' );
+       chop;
+       ok( $_ eq 'neste', 'chop on my $_' );
+    }
+    {
+       our $_;
+       ok( $_ eq 'glabol', 'gains access to our global $_' );
+    }
+    ok( $_ eq 'ladol', 'my $_ restored' );
+}
+ok( $_ eq 'glabol', 'global $_ restored' );
+s/abo/oba/;
+ok( $_ eq 'global', 's/// on global $_ again' );
+{
+    my $_ = 11;
+    our $_ = 22;
+    ok( $_ eq 22, 'our $_ is seen explicitly' );
+    chop;
+    ok( $_ eq 2, '...default chop chops our $_' );
+    /(.)/;
+    ok( $1 eq 2, '...default match sees our $_' );
+}
+
+$_ = "global";
+{
+    for my $_ ("foo") {
+       ok( $_ eq "foo", 'for my $_' );
+       /(.)/;
+       ok( $1 eq "f", '...m// in for my $_' );
+       ok( our $_ eq 'global', '...our $_ inside for my $_' );
+    }
+    ok( $_ eq 'global', '...$_ restored outside for my $_' );
+}
+{
+    for our $_ ("bar") {
+       ok( $_ eq "bar", 'for our $_' );
+       /(.)/;
+       ok( $1 eq "b", '...m// in for our $_' );
+    }
+    ok( $_ eq 'global', '...our $_ restored outside for our $_' );
+}
+
+{
+    my $buf = '';
+    sub tmap1 { /(.)/; $buf .= $1 } # uses our $_
+    my $_ = 'x';
+    sub tmap2 { /(.)/; $buf .= $1 } # uses my $_
+    map {
+       tmap1();
+       tmap2();
+       ok( /^[67]\z/, 'local lexical $_ is seen in map' );
+       { ok( our $_ eq 'global', 'our $_ still visible' ); }
+       ok( $_ == 6 || $_ == 7, 'local lexical $_ is still seen in map' );
+    } 6, 7;
+    ok( $buf eq 'gxgx', q/...map doesn't modify outer lexical $_/ );
+    ok( $_ eq 'x', '...my $_ restored outside map' );
+    ok( our $_ eq 'global', '...our $_ restored outside map' );
+}
+{
+    my $buf = '';
+    sub tgrep1 { /(.)/; $buf .= $1 }
+    my $_ = 'y';
+    sub tgrep2 { /(.)/; $buf .= $1 }
+    grep {
+       tgrep1();
+       tgrep2();
+       ok( /^[89]\z/, 'local lexical $_ is seen in grep' );
+       { ok( our $_ eq 'global', 'our $_ still visible' ); }
+       ok( $_ == 8 || $_ == 9, 'local lexical $_ is still seen in grep' );
+    } 8, 9;
+    ok( $buf eq 'gygy', q/...grep doesn't modify outer lexical $_/ );
+    ok( $_ eq 'y', '...my $_ restored outside grep' );
+    ok( our $_ eq 'global', '...our $_ restored outside grep' );
+}
+{
+    my $s = "toto";
+    my $_ = "titi";
+    $s =~ /to(?{ ok( $_ eq 'toto', 'my $_ in code-match # TODO' ) })to/
+       or ok( 0, "\$s=$s should match!" );
+    ok( our $_ eq 'global', '...our $_ restored outside code-match' );
+}
+
+{
+    my $_ = "abc";
+    my $x = reverse;
+    ok( $x eq "cba", 'reverse without arguments picks up $_ # TODO' );
+}
+
+{
+    package notmain;
+    our $_ = 'notmain';
+    ::ok( $::_ eq 'notmain', 'our $_ forced into main::' );
+    /(.*)/;
+    ::ok( $1 eq 'notmain', '...m// defaults to our $_ in main::' );
+}
+
+my $file = 'dolbar1.tmp';
+END { unlink $file; }
+{
+    open my $_, '>', $file or die "Can't open $file: $!";
+    print $_ "hello\n";
+    close $_;
+    ok( -s $file, 'writing to filehandle $_ works' );
+}
+{
+    open my $_, $file or die "Can't open $file: $!";
+    my $x = <$_>;
+    ok( $x eq "hello\n", 'reading from <$_> works' );
+    close $_;
+}
diff --git a/toke.c b/toke.c
index bc4194b..1ca076e 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -6522,7 +6522,8 @@ S_scan_trans(pTHX_ char *start)
 
     New(803, tbl, complement&&!del?258:256, short);
     o = newPVOP(OP_TRANS, 0, (char*)tbl);
-    o->op_private = del|squash|complement|
+    o->op_private &= ~OPpTRANS_ALL;
+    o->op_private |= del|squash|complement|
       (DO_UTF8(PL_lex_stuff)? OPpTRANS_FROM_UTF : 0)|
       (DO_UTF8(PL_lex_repl) ? OPpTRANS_TO_UTF   : 0);