In perl.git, the branch blead has been updated <http://perl5.git.perl.org/perl.git/commitdiff/6d1c68e64c4dbbb1c7e8a28de678cd3247649bad?hp=b2790d5ec79a17545322ac3cb11f11a0cb7390a7>
- Log ----------------------------------------------------------------- commit 6d1c68e64c4dbbb1c7e8a28de678cd3247649bad Author: Father Chrysostomos <[email protected]> Date: Fri Jun 24 08:17:28 2011 -0700 [perl #93454] Free deleted iterator when freeing hash Commit 7d6175e, which did a fix-up after commit e0171a1a3, which introduced hfree_next_entry, did not account for the fact that hfree_next_entry frees the hash iterator before removing and returning the next value. It changed the callers to check the number of keys to determine whether anything else needed to be freed, which meant that hfree_next_entry was called one time less than necessary on hashes whose current iterator had been deleted and which consequently appeared empty. This fixes that. I donât know how to test it, but the string table warnings were caus- ing test failures on VMS, so maybe thatâs good enough. M hv.c M sv.c commit f4e68e82b126f2b2bfde4c660b1045c1e4a69455 Author: Father Chrysostomos <[email protected]> Date: Fri Jun 24 06:20:16 2011 -0700 Bypass a switch in gv_fetchpvn for 2-char symbols The switch that checks for ISA, EXPORT, etc. in packages other than main was guarded with an if(len>1) statement. Since ISA is three characters, we can bypass that entire switch for two-charac- ter symbols. M gv.c commit b91b7d1aba69eb050d639e18602ef68fcdd4bbb1 Author: Father Chrysostomos <[email protected]> Date: Thu Jun 23 23:22:29 2011 -0700 Update proto docs after prev commit M pod/perlsub.pod commit 062678b2241d3d1cc3a46f80f402cf4147b825f1 Author: Father Chrysostomos <[email protected]> Date: Thu Jun 23 23:14:17 2011 -0700 Allow the \$ proto to accept any scalar lvalue [perl #91846] This makes the \$ prototypeâs parsing the same as the second argument to read(), making it possible to create a custom myread() function that has the same syntax. This is handled in two places in the prototype-parsing code, to avoid calling scalar() on the op if another character in \[...] will accept it. I donât know what the consequences of that would be. So it calls Perl_op_lvalue_flags in the $ case only if it is not inside brackets. Then in the ] case it checks to see whether there was a $. OP_READ, not OP_ENTERSUB, is passed as the type to Perl_op_lvalue_flags, since OP_ENTERSUB would allow sub foo(\$) to accept an array as an argument. OP_RECV and OP_SYSREAD would have worked, too. M op.c M pod/perldelta.pod M t/comp/proto.t commit f5d552b480dda142e3e1fc3a463194ebdf0b8b3e Author: Father Chrysostomos <[email protected]> Date: Thu Jun 23 21:58:29 2011 -0700 Make Perl_op_lvalue_flags provide a no-croak option This is in preparation for making the \$ prototype accept any lvalue. M op.c M op.h commit d3d7d28f48f0f4ec3f5cf5d018255ea731f01f56 Author: Father Chrysostomos <[email protected]> Date: Thu Jun 23 21:48:07 2011 -0700 op_lvalue .= _flags Add flags param to op_lvalue, so that the caller can ask it not to croak when encountering an unmodifiable op (upcoming). This is in preparation for making the \$ prototype accept any lvalue. There is no mathom, as the changes that this will support are by no means suitable for maint. M embed.fnc M embed.h M global.sym M op.c M op.h M proto.h commit 63983e4c95135b2dd0fa466c28136f053046a340 Author: Father Chrysostomos <[email protected]> Date: Thu Jun 23 15:01:42 2011 -0700 proto.t: Test \$ with subcall()->[elem] This syntax was documented, but there was no test for it. M t/comp/proto.t commit e2ba0c6ffc4123d75fa6d954775fd2e651d79fe8 Author: Father Chrysostomos <[email protected]> Date: Thu Jun 23 14:58:16 2011 -0700 Remove two tests from proto.t These have been superseded by t/op/cproto.t, which came later. M t/comp/proto.t commit 0d235c77627bbba8acd9fee908b6a3a7e034a6a8 Author: Father Chrysostomos <[email protected]> Date: Thu Jun 23 10:29:57 2011 -0700 Make pp_leavesublv use S_return_lvalues The returning code is now almost identical, due to the preceding com- mits, so they can be merged. M pp_ctl.c ----------------------------------------------------------------------- Summary of changes: embed.fnc | 3 +- embed.h | 1 - global.sym | 2 +- gv.c | 2 +- hv.c | 5 +- op.c | 21 ++++++++- op.h | 6 +++ pod/perldelta.pod | 9 ++++ pod/perlsub.pod | 4 +- pp_ctl.c | 125 ++--------------------------------------------------- proto.h | 3 +- sv.c | 4 +- t/comp/proto.t | 16 +++---- 13 files changed, 57 insertions(+), 144 deletions(-) diff --git a/embed.fnc b/embed.fnc index 71c10af..d9a888a 100644 --- a/embed.fnc +++ b/embed.fnc @@ -751,7 +751,8 @@ Apd |void |mg_magical |NN SV* sv Apd |int |mg_set |NN SV* sv Ap |I32 |mg_size |NN SV* sv Ap |void |mini_mktime |NN struct tm *ptm -AMpd |OP* |op_lvalue |NULLOK OP* o|I32 type +AMmd |OP* |op_lvalue |NULLOK OP* o|I32 type +poX |OP* |op_lvalue_flags|NULLOK OP* o|I32 type|U32 flags : To be removed after 5.14 (see [perl #78908]): EXp |OP* |mod |NULLOK OP* o|I32 type : Used in op.c and pp_sys.c diff --git a/embed.h b/embed.h index 77373e1..e2428c9 100644 --- a/embed.h +++ b/embed.h @@ -375,7 +375,6 @@ #define op_dump(a) Perl_op_dump(aTHX_ a) #define op_free(a) Perl_op_free(aTHX_ a) #define op_linklist(a) Perl_op_linklist(aTHX_ a) -#define op_lvalue(a,b) Perl_op_lvalue(aTHX_ a,b) #define op_null(a) Perl_op_null(aTHX_ a) #define op_prepend_elem(a,b,c) Perl_op_prepend_elem(aTHX_ a,b,c) #define op_refcnt_lock() Perl_op_refcnt_lock(aTHX) diff --git a/global.sym b/global.sym index 89fb825..30614c4 100644 --- a/global.sym +++ b/global.sym @@ -426,7 +426,7 @@ Perl_op_contextualize Perl_op_dump Perl_op_free Perl_op_linklist -Perl_op_lvalue +Perl_op_lvalue_flags Perl_op_null Perl_op_prepend_elem Perl_op_refcnt_lock diff --git a/gv.c b/gv.c index 9bb428d..79bc0e9 100644 --- a/gv.c +++ b/gv.c @@ -1291,7 +1291,7 @@ Perl_gv_fetchpvn_flags(pTHX_ const char *nambeg, STRLEN full_len, I32 flags, if (stash != PL_defstash) { /* not the main stash */ /* We only have to check for four names here: EXPORT, ISA, OVERLOAD and VERSION. All the others apply only to the main stash. */ - if (len > 1) { + if (len > 2) { const char * const name2 = name + 1; switch (*name) { case 'E': diff --git a/hv.c b/hv.c index a230c16..c8ed63c 100644 --- a/hv.c +++ b/hv.c @@ -1663,11 +1663,12 @@ S_hfreeentries(pTHX_ HV *hv) { STRLEN index = 0; XPVHV * const xhv = (XPVHV*)SvANY(hv); + SV *sv; PERL_ARGS_ASSERT_HFREEENTRIES; - while (xhv->xhv_keys) { - SvREFCNT_dec(Perl_hfree_next_entry(aTHX_ hv, &index)); + while ((sv = Perl_hfree_next_entry(aTHX_ hv, &index))||xhv->xhv_keys) { + SvREFCNT_dec(sv); } } diff --git a/op.c b/op.c index e5780e3..267bfb9 100644 --- a/op.c +++ b/op.c @@ -1424,7 +1424,7 @@ such as C<$$x = 5> which might have to vivify a reference in C<$x>. */ OP * -Perl_op_lvalue(pTHX_ OP *o, I32 type) +Perl_op_lvalue_flags(pTHX_ OP *o, I32 type, U32 flags) { dVAR; OP *kid; @@ -1567,6 +1567,7 @@ Perl_op_lvalue(pTHX_ OP *o, I32 type) /* FALL THROUGH */ default: nomod: + if (flags & OP_LVALUE_NO_CROAK) return NULL; /* grep, foreach, subcalls, refgen */ if (type == OP_GREPSTART || type == OP_ENTERSUB || type == OP_REFGEN || type == OP_LEAVESUBLV) @@ -8824,7 +8825,14 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) const char *p = proto; const char *const end = proto; contextclass = 0; - while (*--p != '[') {} + while (*--p != '[') + /* \[$] accepts any scalar lvalue */ + if (*p == '$' + && Perl_op_lvalue_flags(aTHX_ + scalar(o3), + OP_READ, /* not entersub */ + OP_LVALUE_NO_CROAK + )) goto wrapref; bad_type(arg, Perl_form(aTHX_ "one of %.*s", (int)(end - p), p), gv_ename(namegv), o3); @@ -8850,8 +8858,15 @@ Perl_ck_entersub_args_proto(pTHX_ OP *entersubop, GV *namegv, SV *protosv) o3->op_type == OP_HELEM || o3->op_type == OP_AELEM) goto wrapref; - if (!contextclass) + if (!contextclass) { + /* \$ accepts any scalar lvalue */ + if (Perl_op_lvalue_flags(aTHX_ + scalar(o3), + OP_READ, /* not entersub */ + OP_LVALUE_NO_CROAK + )) goto wrapref; bad_type(arg, "scalar", gv_ename(namegv), o3); + } break; case '@': if (o3->op_type == OP_RV2AV || diff --git a/op.h b/op.h index 0d03efd..ce17bd5 100644 --- a/op.h +++ b/op.h @@ -763,6 +763,12 @@ preprocessing token; the type of I<arg> depends on I<which>. #define RV2CVOPCV_MARK_EARLY 0x00000001 #define RV2CVOPCV_RETURN_NAME_GV 0x00000002 +#define op_lvalue(op,t) Perl_op_lvalue_flags(aTHX_ op,t,0) + +/* flags for op_lvalue_flags */ + +#define OP_LVALUE_NO_CROAK 1 + /* =head1 Custom Operators diff --git a/pod/perldelta.pod b/pod/perldelta.pod index 751da25..d4bc3c3 100644 --- a/pod/perldelta.pod +++ b/pod/perldelta.pod @@ -33,6 +33,15 @@ here, but most should go in the L</Performance Enhancements> section. You can now limit the size of an array using C<splice(@a,MAX_LEN)> without worrying about warnings. +=head2 The C<\$> prototype accepts any scalar lvalue + +The C<\$> and C<\[$]> subroutine prototypes now accept any scalar lvalue +argument. Previously they only accepted scalars beginning with C<$> and +hash and array elements. This change makes them consistent with the way +the built-in C<read> and C<recv> functions (among others) parse their +arguments. This means that one can override the built-in functions with +custom subroutines that parse their arguments the same way. + =head1 Security XXX Any security-related notices go here. In particular, any security diff --git a/pod/perlsub.pod b/pod/perlsub.pod index 01c525d..4cc0b9c 100644 --- a/pod/perlsub.pod +++ b/pod/perlsub.pod @@ -1077,8 +1077,8 @@ corresponding built-in. Any backslashed prototype character represents an actual argument that must start with that character (optionally preceded by C<my>, -C<our> or C<local>), with the exception of C<$>, which will accept a -hash or array element even without a dollar sign, such as +C<our> or C<local>), with the exception of C<$>, which will +accept any scalar lvalue expression, such as C<$foo = 7> or C<< my_function()->[0] >>. The value passed as part of C<@_> will be a reference to the actual argument given in the subroutine call, obtained by applying C<\> to that argument. diff --git a/pp_ctl.c b/pp_ctl.c index 36ba24a..1057c70 100644 --- a/pp_ctl.c +++ b/pp_ctl.c @@ -2286,8 +2286,10 @@ S_return_lvalues(pTHX_ SV **mark, SV **sp, SV **newsp, I32 gimme, ? sv_2mortal(SvREFCNT_inc_simple_NN(*SP)) : *SP; } - else + else { + EXTEND(newsp,1); *++newsp = &PL_sv_undef; + } if (CxLVAL(cx) & OPpENTERSUB_DEREF) { SvGETMAGIC(TOPs); if (!SvOK(TOPs)) { @@ -2487,7 +2489,6 @@ PP(pp_return) PP(pp_leavesublv) { dVAR; dSP; - SV **mark; SV **newsp; PMOP *newpm; I32 gimme; @@ -2503,125 +2504,7 @@ PP(pp_leavesublv) TAINT_NOT; - if (gimme == G_SCALAR) { - if (CxLVAL(cx) && !(CxLVAL(cx) & OPpENTERSUB_INARGS)) { - /* Leave it as it is if we can. */ - MARK = newsp + 1; - EXTEND_MORTAL(1); - if (MARK == SP) { - if ((SvPADTMP(TOPs) || - (SvFLAGS(TOPs) & (SVf_READONLY | SVf_FAKE)) - == SVf_READONLY - ) && - !SvSMAGICAL(TOPs)) { - LEAVE; - cxstack_ix--; - POPSUB(cx,sv); - PL_curpm = newpm; - LEAVESUB(sv); - DIE(aTHX_ "Can't return %s from lvalue subroutine", - SvREADONLY(TOPs) ? (TOPs == &PL_sv_undef) ? "undef" - : "a readonly value" : "a temporary"); - } - else { /* Can be a localized value - * subject to deletion. */ - PL_tmps_stack[++PL_tmps_ix] = *mark; - SvREFCNT_inc_void(*mark); - } - } - else { - /* sub:lvalue{} will take us here. - Presumably the case of a non-empty array never happens. - */ - LEAVE; - cxstack_ix--; - POPSUB(cx,sv); - PL_curpm = newpm; - LEAVESUB(sv); - DIE(aTHX_ "%s", - (MARK > SP - ? "Can't return undef from lvalue subroutine" - : "Array returned from lvalue subroutine in scalar " - "context" - ) - ); - } - SP = MARK; - } - else { - MARK = newsp + 1; - if (MARK <= SP) { - if (cx->blk_sub.cv && CvDEPTH(cx->blk_sub.cv) > 1) { - *MARK = SvREFCNT_inc(TOPs); - FREETMPS; - sv_2mortal(*MARK); - } - else - *MARK = SvTEMP(TOPs) - ? TOPs - : sv_2mortal(SvREFCNT_inc_simple_NN(TOPs)); - } - else { - MEXTEND(MARK, 0); - *MARK = &PL_sv_undef; - } - SP = MARK; - } - if (CxLVAL(cx) & OPpENTERSUB_DEREF) { - SvGETMAGIC(TOPs); - if (!SvOK(TOPs)) { - U8 deref_type; - if (cx->blk_sub.retop->op_type == OP_RV2SV) - deref_type = OPpDEREF_SV; - else if (cx->blk_sub.retop->op_type == OP_RV2AV) - deref_type = OPpDEREF_AV; - else { - assert(cx->blk_sub.retop->op_type == OP_RV2HV); - deref_type = OPpDEREF_HV; - } - vivify_ref(TOPs, deref_type); - } - } - } - else if (gimme == G_ARRAY) { - const bool ref = CxLVAL(cx) & OPpENTERSUB_INARGS; - assert(!(CxLVAL(cx) & OPpENTERSUB_DEREF)); - if (ref||!CxLVAL(cx)) - for (MARK = newsp + 1; MARK <= SP; MARK++) { - if (!SvTEMP(*MARK)) - *MARK = ref && SvFLAGS(*mark) & SVs_PADTMP - ? sv_mortalcopy(*mark) - : sv_2mortal(SvREFCNT_inc_simple_NN(*MARK)); - } - else { /* Leave it as it is if we can. */ - EXTEND_MORTAL(SP - newsp); - for (mark = newsp + 1; mark <= SP; mark++) { - if (*mark != &PL_sv_undef - && (SvPADTMP(*mark) - || (SvFLAGS(*mark) & (SVf_READONLY|SVf_FAKE)) - == SVf_READONLY - ) - ) { - /* Might be flattened array after $#array = */ - PUTBACK; - LEAVE; - cxstack_ix--; - POPSUB(cx,sv); - PL_curpm = newpm; - LEAVESUB(sv); - DIE(aTHX_ "Can't return a %s from lvalue subroutine", - SvREADONLY(TOPs) ? "readonly value" : "temporary"); - } - else { - /* Can be a localized value subject to deletion. */ - PL_tmps_stack[++PL_tmps_ix] = *mark; - SvREFCNT_inc_void(*mark); - } - } - } - } - - PUTBACK; + S_return_lvalues(aTHX_ newsp, SP, newsp, gimme, cx, newpm); LEAVE; cxstack_ix--; diff --git a/proto.h b/proto.h index 9d47ba5..8fc49de 100644 --- a/proto.h +++ b/proto.h @@ -2765,7 +2765,8 @@ PERL_CALLCONV OP* Perl_op_linklist(pTHX_ OP *o) #define PERL_ARGS_ASSERT_OP_LINKLIST \ assert(o) -PERL_CALLCONV OP* Perl_op_lvalue(pTHX_ OP* o, I32 type); +/* PERL_CALLCONV OP* op_lvalue(pTHX_ OP* o, I32 type); */ +PERL_CALLCONV OP* Perl_op_lvalue_flags(pTHX_ OP* o, I32 type, U32 flags); PERL_CALLCONV void Perl_op_null(pTHX_ OP* o) __attribute__nonnull__(pTHX_1); #define PERL_ARGS_ASSERT_OP_NULL \ diff --git a/sv.c b/sv.c index 2c97cce..04e040c 100644 --- a/sv.c +++ b/sv.c @@ -6180,7 +6180,8 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) goto free_body; } } else if (SvTYPE(iter_sv) == SVt_PVHV) { - if (!HvTOTALKEYS((HV *)iter_sv)) { + sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index); + if (!sv && !HvTOTALKEYS((HV *)iter_sv)) { /* no more elements of current HV to free */ sv = iter_sv; type = SvTYPE(sv); @@ -6197,7 +6198,6 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) assert(!HvARRAY((HV*)sv)); goto free_body; } - sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index); } /* unrolled SvREFCNT_dec and sv_free2 follows: */ diff --git a/t/comp/proto.t b/t/comp/proto.t index b5c8cf2..50aebef 100644 --- a/t/comp/proto.t +++ b/t/comp/proto.t @@ -18,7 +18,7 @@ BEGIN { # strict use strict; -print "1..172\n"; +print "1..174\n"; my $i = 1; @@ -544,6 +544,10 @@ sub sreftest (\$$) { sreftest my $sref, $i++; sreftest($helem{$i}, $i++); sreftest $aelem[0], $i++; + sreftest sub { [0] }->()[0], $i++; + sreftest my $a = 'quidgley', $i++; + print "not " if eval 'return 1; sreftest(3+4)'; + print "ok ", $i++, ' - \$ with invalid argument', "\n"; } # test single term @@ -587,14 +591,6 @@ for my $p ( "", qw{ () ($) ($@) ($%) ($;$) (&) (&\@) (&@) (%) (\%) (\@) } ) { } } -# Not $$;$;$ -print "not " unless prototype "CORE::substr" eq '$$;$$'; -print "ok ", $i++, "\n"; - -# recv takes a scalar reference for its second argument -print "not " unless prototype "CORE::recv" eq '*\\$$$'; -print "ok ", $i++, "\n"; - { my $myvar; my @myarray; @@ -606,6 +602,8 @@ print "ok ", $i++, "\n"; print "not " unless myref($myvar) =~ /^SCALAR\(/; print "ok ", $i++, "\n"; + print "not " unless myref($myvar=7) =~ /^SCALAR\(/; + print "ok ", $i++, "\n"; print "not " unless myref(@myarray) =~ /^ARRAY\(/; print "ok ", $i++, "\n"; print "not " unless myref(%myhash) =~ /^HASH\(/; -- Perl5 Master Repository
