Implement "my $_".

p4raw-id: //depot/perl@22263

15 files changed, 266 insertions, 46 deletions

diff --git a/MANIFEST b/MANIFEST
index c9780fca6f..c17da1d7c4 100644
--- 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 b297cb6c66..aa2befc54a 100644
--- 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 5fd21bf975..62d9b0307b 100644
--- 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 539393dd1f..aeaae1c858 100644
--- 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
 };
diff --git a/opcode.h b/opcode.h
index 51255989ec..81ab818f98 100644
--- 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 */
diff --git a/opcode.pl b/opcode.pl
index dc5b66eea9..1fe1f3ca89 100755
--- 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
diff --git a/pod/perl591delta.pod b/pod/perl591delta.pod
index 52b54fd751..bf26c2bc75 100644
--- a/pod/perl591delta.pod
+++ b/pod/perl591delta.pod
@@ -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
diff --git a/pod/perlapi.pod b/pod/perlapi.pod
index 61e52a1874..5c0bee4ff4 100644
--- a/pod/perlapi.pod
+++ b/pod/perlapi.pod
@@ -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
diff --git a/pod/perlvar.pod b/pod/perlvar.pod
index 50d30d4a27..8fc74417d7 100644
--- a/pod/perlvar.pod
+++ b/pod/perlvar.pod
@@ -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 6f3703dd12..f06e71f10c 100644
--- 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);
diff --git a/pp_ctl.c b/pp_ctl.c
index 9b2ca63b82..42d63c6d55 100644
--- 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);
     }
diff --git a/pp_hot.c b/pp_hot.c
index 1dffe945c5..e884e2dbe1 100644
--- 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);
     }
diff --git a/regexec.c b/regexec.c
index 464ceaf9e3..fae700435c 100644
--- 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
index 0000000000..9469ae1fc2
--- /dev/null
+++ b/t/op/mydef.t
@@ -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 bc4194b3a8..1ca076eef7 100644
--- 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);