diff options
| -rw-r--r-- | MANIFEST | 1 | ||||
| -rw-r--r-- | gv.c | 4 | ||||
| -rw-r--r-- | op.c | 49 | ||||
| -rw-r--r-- | op.h | 7 | ||||
| -rw-r--r-- | opcode.h | 4 | ||||
| -rwxr-xr-x | opcode.pl | 4 | ||||
| -rw-r--r-- | pod/perl591delta.pod | 17 | ||||
| -rw-r--r-- | pod/perlapi.pod | 46 | ||||
| -rw-r--r-- | pod/perlvar.pod | 5 | ||||
| -rw-r--r-- | pp.c | 2 | ||||
| -rw-r--r-- | pp_ctl.c | 16 | ||||
| -rw-r--r-- | pp_hot.c | 9 | ||||
| -rw-r--r-- | regexec.c | 3 | ||||
| -rw-r--r-- | t/op/mydef.t | 142 | ||||
| -rw-r--r-- | toke.c | 3 |
15 files changed, 266 insertions, 46 deletions
@@ -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 @@ -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) { @@ -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; } @@ -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 }; @@ -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 */ @@ -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 @@ -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); @@ -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); } @@ -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); } @@ -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 $_; +} @@ -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); |