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
}
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) {
{
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 */
Perl_bind_match(pTHX_ I32 type, OP *left, OP *right)
{
OP *o;
+ bool ismatchop = 0;
if (ckWARN(WARN_MISC) &&
(left->op_type == OP_RV2AV ||
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 &&
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
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);
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)
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;
}
#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. */
((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
};
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 */
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
=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
=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
=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
=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
=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
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);
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)
/* 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);
}
if (PL_op->op_flags & OPf_STACKED)
TARG = POPs;
+ else if (PL_op->op_private & OPpTARGET_MY)
+ GETTARGET;
else {
TARG = DEFSV;
EXTEND(SP,1);
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);
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);
}
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;
}
--- /dev/null
+#!./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 $_;
+}
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);
projects / p5sagit/p5-mst-13.2.git / commitdiff