diff options
| -rw-r--r-- | av.c | 30 | ||||
| -rw-r--r-- | dump.c | 2 | ||||
| -rw-r--r-- | embed.h | 16 | ||||
| -rwxr-xr-x | embed.pl | 5 | ||||
| -rw-r--r-- | global.sym | 1 | ||||
| -rw-r--r-- | objXSUB.h | 4 | ||||
| -rw-r--r-- | op.c | 19 | ||||
| -rw-r--r-- | op.h | 1 | ||||
| -rw-r--r-- | perlapi.c | 7 | ||||
| -rw-r--r-- | pp_hot.c | 138 | ||||
| -rw-r--r-- | proto.h | 4 | ||||
| -rwxr-xr-x | t/op/avhv.t | 41 | ||||
| -rwxr-xr-x | t/op/hashwarn.t | 11 |
13 files changed, 232 insertions, 47 deletions
@@ -805,6 +805,20 @@ S_avhv_index_sv(pTHX_ SV* sv) return index; } +STATIC I32 +S_avhv_index(pTHX_ AV *av, SV *keysv, U32 hash) +{ + HV *keys; + HE *he; + STRLEN n_a; + + keys = avhv_keys(av); + he = hv_fetch_ent(keys, keysv, FALSE, hash); + if (!he) + Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a)); + return avhv_index_sv(HeVAL(he)); +} + HV* Perl_avhv_keys(pTHX_ AV *av) { @@ -824,17 +838,15 @@ Perl_avhv_keys(pTHX_ AV *av) } SV** +Perl_avhv_store_ent(pTHX_ AV *av, SV *keysv, SV *val, U32 hash) +{ + return av_store(av, avhv_index(av, keysv, hash), val); +} + +SV** Perl_avhv_fetch_ent(pTHX_ AV *av, SV *keysv, I32 lval, U32 hash) { - SV **indsvp; - HV *keys = avhv_keys(av); - HE *he; - STRLEN n_a; - - he = hv_fetch_ent(keys, keysv, FALSE, hash); - if (!he) - Perl_croak(aTHX_ "No such pseudo-hash field \"%s\"", SvPV(keysv,n_a)); - return av_fetch(av, avhv_index_sv(HeVAL(he)), lval); + return av_fetch(av, avhv_index(av, keysv, hash), lval); } SV * @@ -433,6 +433,8 @@ Perl_do_op_dump(pTHX_ I32 level, PerlIO *file, OP *o) if (o->op_type == OP_AASSIGN) { if (o->op_private & OPpASSIGN_COMMON) sv_catpv(tmpsv, ",COMMON"); + if (o->op_private & OPpASSIGN_HASH) + sv_catpv(tmpsv, ",HASH"); } else if (o->op_type == OP_SASSIGN) { if (o->op_private & OPpASSIGN_BACKWARDS) @@ -71,6 +71,7 @@ #define avhv_delete_ent Perl_avhv_delete_ent #define avhv_exists_ent Perl_avhv_exists_ent #define avhv_fetch_ent Perl_avhv_fetch_ent +#define avhv_store_ent Perl_avhv_store_ent #define avhv_iternext Perl_avhv_iternext #define avhv_iterval Perl_avhv_iterval #define avhv_keys Perl_avhv_keys @@ -825,6 +826,7 @@ #endif #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) #define avhv_index_sv S_avhv_index_sv +#define avhv_index S_avhv_index #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) #define do_trans_CC_simple S_do_trans_CC_simple @@ -945,6 +947,8 @@ #define qsortsv S_qsortsv #endif #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) +#define do_maybe_phash S_do_maybe_phash +#define do_oddball S_do_oddball #define get_db_sub S_get_db_sub #define method_common S_method_common #endif @@ -1522,6 +1526,7 @@ #define avhv_delete_ent(a,b,c,d) Perl_avhv_delete_ent(aTHX_ a,b,c,d) #define avhv_exists_ent(a,b,c) Perl_avhv_exists_ent(aTHX_ a,b,c) #define avhv_fetch_ent(a,b,c,d) Perl_avhv_fetch_ent(aTHX_ a,b,c,d) +#define avhv_store_ent(a,b,c,d) Perl_avhv_store_ent(aTHX_ a,b,c,d) #define avhv_iternext(a) Perl_avhv_iternext(aTHX_ a) #define avhv_iterval(a,b) Perl_avhv_iterval(aTHX_ a,b) #define avhv_keys(a) Perl_avhv_keys(aTHX_ a) @@ -2249,6 +2254,7 @@ #endif #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) #define avhv_index_sv(a) S_avhv_index_sv(aTHX_ a) +#define avhv_index(a,b,c) S_avhv_index(aTHX_ a,b,c) #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) #define do_trans_CC_simple(a) S_do_trans_CC_simple(aTHX_ a) @@ -2369,6 +2375,8 @@ #define qsortsv(a,b,c) S_qsortsv(aTHX_ a,b,c) #endif #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) +#define do_maybe_phash(a,b,c,d,e) S_do_maybe_phash(aTHX_ a,b,c,d,e) +#define do_oddball(a,b,c) S_do_oddball(aTHX_ a,b,c) #define get_db_sub(a,b) S_get_db_sub(aTHX_ a,b) #define method_common(a,b) S_method_common(aTHX_ a,b) #endif @@ -2958,6 +2966,8 @@ #define avhv_exists_ent Perl_avhv_exists_ent #define Perl_avhv_fetch_ent CPerlObj::Perl_avhv_fetch_ent #define avhv_fetch_ent Perl_avhv_fetch_ent +#define Perl_avhv_store_ent CPerlObj::Perl_avhv_store_ent +#define avhv_store_ent Perl_avhv_store_ent #define Perl_avhv_iternext CPerlObj::Perl_avhv_iternext #define avhv_iternext Perl_avhv_iternext #define Perl_avhv_iterval CPerlObj::Perl_avhv_iterval @@ -4404,6 +4414,8 @@ #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) #define S_avhv_index_sv CPerlObj::S_avhv_index_sv #define avhv_index_sv S_avhv_index_sv +#define S_avhv_index CPerlObj::S_avhv_index +#define avhv_index S_avhv_index #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) #define S_do_trans_CC_simple CPerlObj::S_do_trans_CC_simple @@ -4616,6 +4628,10 @@ #define qsortsv S_qsortsv #endif #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) +#define S_do_maybe_phash CPerlObj::S_do_maybe_phash +#define do_maybe_phash S_do_maybe_phash +#define S_do_oddball CPerlObj::S_do_oddball +#define do_oddball S_do_oddball #define S_get_db_sub CPerlObj::S_get_db_sub #define get_db_sub S_get_db_sub #define S_method_common CPerlObj::S_method_common @@ -1354,6 +1354,7 @@ p |I32 |apply |I32 type|SV** mark|SV** sp Ap |SV* |avhv_delete_ent|AV *ar|SV* keysv|I32 flags|U32 hash Ap |bool |avhv_exists_ent|AV *ar|SV* keysv|U32 hash Ap |SV** |avhv_fetch_ent |AV *ar|SV* keysv|I32 lval|U32 hash +Ap |SV** |avhv_store_ent |AV *ar|SV* keysv|SV* val|U32 hash Ap |HE* |avhv_iternext |AV *ar Ap |SV* |avhv_iterval |AV *ar|HE* entry Ap |HV* |avhv_keys |AV *ar @@ -2156,6 +2157,7 @@ END_EXTERN_C #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) s |I32 |avhv_index_sv |SV* sv +s |I32 |avhv_index |AV* av|SV* sv|U32 hash #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) @@ -2287,6 +2289,9 @@ s |void |qsortsv |SV ** array|size_t num_elts|SVCOMPARE_t f #endif #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) +s |int |do_maybe_phash |AV *ary|SV **lelem|SV **firstlelem \ + |SV **relem|SV **lastrelem +s |void |do_oddball |HV *hash|SV **relem|SV **firstrelem s |CV* |get_db_sub |SV **svp|CV *cv s |SV* |method_common |SV* meth|U32* hashp #endif diff --git a/global.sym b/global.sym index e69747a626..e34d5c08c7 100644 --- a/global.sym +++ b/global.sym @@ -24,6 +24,7 @@ Perl_Gv_AMupdate Perl_avhv_delete_ent Perl_avhv_exists_ent Perl_avhv_fetch_ent +Perl_avhv_store_ent Perl_avhv_iternext Perl_avhv_iterval Perl_avhv_keys @@ -47,6 +47,10 @@ #define Perl_avhv_fetch_ent pPerl->Perl_avhv_fetch_ent #undef avhv_fetch_ent #define avhv_fetch_ent Perl_avhv_fetch_ent +#undef Perl_avhv_store_ent +#define Perl_avhv_store_ent pPerl->Perl_avhv_store_ent +#undef avhv_store_ent +#define avhv_store_ent Perl_avhv_store_ent #undef Perl_avhv_iternext #define Perl_avhv_iternext pPerl->Perl_avhv_iternext #undef avhv_iternext @@ -3273,6 +3273,8 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) if (list_assignment(left)) { dTHR; + OP *curop; + PL_modcount = 0; PL_eval_start = right; /* Grandfathering $[ assignment here. Bletch.*/ left = mod(left, OP_AASSIGN); @@ -3283,12 +3285,19 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) op_free(right); return Nullop; } - o = newBINOP(OP_AASSIGN, flags, - list(force_list(right)), - list(force_list(left)) ); + curop = list(force_list(left)); + o = newBINOP(OP_AASSIGN, flags, list(force_list(right)), curop); o->op_private = 0 | (flags >> 8); + for (curop = ((LISTOP*)curop)->op_first; + curop; curop = curop->op_sibling) + { + if (curop->op_type == OP_RV2HV && + ((UNOP*)curop)->op_first->op_type != OP_GV) { + o->op_private |= OPpASSIGN_HASH; + break; + } + } if (!(left->op_private & OPpLVAL_INTRO)) { - OP *curop; OP *lastop = o; PL_generation++; for (curop = LINKLIST(o); curop != o; curop = LINKLIST(curop)) { @@ -3332,7 +3341,7 @@ Perl_newASSIGNOP(pTHX_ I32 flags, OP *left, I32 optype, OP *right) lastop = curop; } if (curop != o) - o->op_private = OPpASSIGN_COMMON; + o->op_private |= OPpASSIGN_COMMON; } if (right && right->op_type == OP_SPLIT) { OP* tmpop; @@ -118,6 +118,7 @@ Deprecated. Use C<GIMME_V> instead. /* Private for OP_AASSIGN */ #define OPpASSIGN_COMMON 64 /* Left & right have syms in common. */ +#define OPpASSIGN_HASH 32 /* Assigning to possible pseudohash. */ /* Private for OP_SASSIGN */ #define OPpASSIGN_BACKWARDS 64 /* Left & right switched. */ @@ -103,6 +103,13 @@ Perl_avhv_fetch_ent(pTHXo_ AV *ar, SV* keysv, I32 lval, U32 hash) return ((CPerlObj*)pPerl)->Perl_avhv_fetch_ent(ar, keysv, lval, hash); } +#undef Perl_avhv_store_ent +SV** +Perl_avhv_store_ent(pTHXo_ AV *ar, SV* keysv, SV* val, U32 hash) +{ + return ((CPerlObj*)pPerl)->Perl_avhv_store_ent(ar, keysv, val, hash); +} + #undef Perl_avhv_iternext HE* Perl_avhv_iternext(pTHXo_ AV *ar) @@ -621,6 +621,93 @@ PP(pp_rv2hv) } } +STATIC int +S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem, + SV **lastrelem) +{ + OP *leftop; + SV *tmpstr; + I32 i; + + leftop = ((BINOP*)PL_op)->op_last; + assert(leftop); + assert(leftop->op_type == OP_NULL && leftop->op_targ == OP_LIST); + leftop = ((LISTOP*)leftop)->op_first; + assert(leftop); + /* Skip PUSHMARK and each element already assigned to. */ + for (i = lelem - firstlelem; i > 0; i--) { + leftop = leftop->op_sibling; + assert(leftop); + } + if (leftop->op_type != OP_RV2HV) + return 0; + + /* pseudohash */ + if (av_len(ary) > 0) + av_fill(ary, 0); /* clear all but the fields hash */ + if (lastrelem >= relem) { + while (relem < lastrelem) { /* gobble up all the rest */ + SV *tmpstr; + assert(relem[0]); + assert(relem[1]); + /* Avoid a memory leak when avhv_store_ent dies. */ + tmpstr = sv_newmortal(); + sv_setsv(tmpstr,relem[1]); /* value */ + relem[1] = tmpstr; + if (avhv_store_ent(ary,relem[0],tmpstr,0)) + SvREFCNT_inc(tmpstr); + if (SvMAGICAL(ary) != 0 && SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + relem += 2; + TAINT_NOT; + } + } + if (relem == lastrelem) + return 1; + return 2; +} + +STATIC void +S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem) +{ + if (*relem) { + SV *tmpstr; + if (ckWARN(WARN_MISC)) { + if (relem == firstrelem && + SvROK(*relem) && + (SvTYPE(SvRV(*relem)) == SVt_PVAV || + SvTYPE(SvRV(*relem)) == SVt_PVHV)) + { + Perl_warner(aTHX_ WARN_MISC, + "Reference found where even-sized list expected"); + } + else + Perl_warner(aTHX_ WARN_MISC, + "Odd number of elements in hash assignment"); + } + if (SvTYPE(hash) == SVt_PVAV) { + /* pseudohash */ + tmpstr = sv_newmortal(); + if (avhv_store_ent((AV*)hash,*relem,tmpstr,0)) + SvREFCNT_inc(tmpstr); + if (SvMAGICAL(hash) && SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + } + else { + HE *didstore; + tmpstr = NEWSV(29,0); + didstore = hv_store_ent(hash,*relem,tmpstr,0); + if (SvMAGICAL(hash)) { + if (SvSMAGICAL(tmpstr)) + mg_set(tmpstr); + if (!didstore) + sv_2mortal(tmpstr); + } + } + TAINT_NOT; + } +} + PP(pp_aassign) { djSP; @@ -646,21 +733,22 @@ PP(pp_aassign) * special care that assigning the identifier on the left doesn't * clobber a value on the right that's used later in the list. */ - if (PL_op->op_private & OPpASSIGN_COMMON) { + if (PL_op->op_private & (OPpASSIGN_COMMON)) { EXTEND_MORTAL(lastrelem - firstrelem + 1); - for (relem = firstrelem; relem <= lastrelem; relem++) { - /*SUPPRESS 560*/ - if (sv = *relem) { + for (relem = firstrelem; relem <= lastrelem; relem++) { + /*SUPPRESS 560*/ + if (sv = *relem) { TAINT_NOT; /* Each item is independent */ - *relem = sv_mortalcopy(sv); + *relem = sv_mortalcopy(sv); } - } + } } relem = firstrelem; lelem = firstlelem; ary = Null(AV*); hash = Null(HV*); + while (lelem <= lastlelem) { TAINT_NOT; /* Each item stands on its own, taintwise. */ sv = *lelem++; @@ -668,7 +756,19 @@ PP(pp_aassign) case SVt_PVAV: ary = (AV*)sv; magic = SvMAGICAL(ary) != 0; - + if (PL_op->op_private & OPpASSIGN_HASH) { + switch (do_maybe_phash(ary, lelem, firstlelem, relem, + lastrelem)) + { + case 0: + goto normal_array; + case 1: + do_oddball((HV*)ary, relem, firstrelem); + } + relem = lastrelem + 1; + break; + } + normal_array: av_clear(ary); av_extend(ary, lastrelem - relem); i = 0; @@ -688,7 +788,7 @@ PP(pp_aassign) TAINT_NOT; } break; - case SVt_PVHV: { + case SVt_PVHV: { /* normal hash */ SV *tmpstr; hash = (HV*)sv; @@ -715,27 +815,7 @@ PP(pp_aassign) TAINT_NOT; } if (relem == lastrelem) { - if (*relem) { - HE *didstore; - if (ckWARN(WARN_MISC)) { - if (relem == firstrelem && - SvROK(*relem) && - ( SvTYPE(SvRV(*relem)) == SVt_PVAV || - SvTYPE(SvRV(*relem)) == SVt_PVHV ) ) - Perl_warner(aTHX_ WARN_MISC, "Reference found where even-sized list expected"); - else - Perl_warner(aTHX_ WARN_MISC, "Odd number of elements in hash assignment"); - } - tmpstr = NEWSV(29,0); - didstore = hv_store_ent(hash,*relem,tmpstr,0); - if (magic) { - if (SvSMAGICAL(tmpstr)) - mg_set(tmpstr); - if (!didstore) - sv_2mortal(tmpstr); - } - TAINT_NOT; - } + do_oddball(hash, relem, firstrelem); relem++; } } @@ -64,6 +64,7 @@ PERL_CALLCONV I32 Perl_apply(pTHX_ I32 type, SV** mark, SV** sp); PERL_CALLCONV SV* Perl_avhv_delete_ent(pTHX_ AV *ar, SV* keysv, I32 flags, U32 hash); PERL_CALLCONV bool Perl_avhv_exists_ent(pTHX_ AV *ar, SV* keysv, U32 hash); PERL_CALLCONV SV** Perl_avhv_fetch_ent(pTHX_ AV *ar, SV* keysv, I32 lval, U32 hash); +PERL_CALLCONV SV** Perl_avhv_store_ent(pTHX_ AV *ar, SV* keysv, SV* val, U32 hash); PERL_CALLCONV HE* Perl_avhv_iternext(pTHX_ AV *ar); PERL_CALLCONV SV* Perl_avhv_iterval(pTHX_ AV *ar, HE* entry); PERL_CALLCONV HV* Perl_avhv_keys(pTHX_ AV *ar); @@ -932,6 +933,7 @@ END_EXTERN_C #if defined(PERL_IN_AV_C) || defined(PERL_DECL_PROT) STATIC I32 S_avhv_index_sv(pTHX_ SV* sv); +STATIC I32 S_avhv_index(pTHX_ AV* av, SV* sv, U32 hash); #endif #if defined(PERL_IN_DOOP_C) || defined(PERL_DECL_PROT) @@ -1061,6 +1063,8 @@ STATIC void S_qsortsv(pTHX_ SV ** array, size_t num_elts, SVCOMPARE_t f); #endif #if defined(PERL_IN_PP_HOT_C) || defined(PERL_DECL_PROT) +STATIC int S_do_maybe_phash(pTHX_ AV *ary, SV **lelem, SV **firstlelem, SV **relem, SV **lastrelem); +STATIC void S_do_oddball(pTHX_ HV *hash, SV **relem, SV **firstrelem); STATIC CV* S_get_db_sub(pTHX_ SV **svp, CV *cv); STATIC SV* S_method_common(pTHX_ SV* meth, U32* hashp); #endif diff --git a/t/op/avhv.t b/t/op/avhv.t index 23f9c69c8c..cd7c957619 100755 --- a/t/op/avhv.t +++ b/t/op/avhv.t @@ -1,5 +1,5 @@ #!./perl - + BEGIN { chdir 't' if -d 't'; unshift @INC, '../lib'; @@ -17,7 +17,7 @@ sub STORESIZE { $#{$_[0]} = $_[1]+1 } package main; -print "1..20\n"; +print "1..28\n"; $sch = { 'abc' => 1, @@ -139,3 +139,40 @@ print "ok 19\n"; print "not " unless "$avhv->{bar}" eq "yyy"; print "ok 20\n"; + +# hash assignment +%$avhv = (); +print "not " unless ref($avhv->[0]) eq 'HASH'; +print "ok 21\n"; + +%hv = %$avhv; +print "not " if grep defined, values %hv; +print "ok 22\n"; +print "not " if grep ref, keys %hv; +print "ok 23\n"; + +%$avhv = (foo => 29, pants => 2, bar => 0); +print "not " unless "@$avhv[1..3]" eq '29 0 2'; +print "ok 24\n"; + +my $extra; +my @extra; +($extra, %$avhv) = ("moo", foo => 42, pants => 53, bar => "HIKE!"); +print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and $extra eq 'moo'; +print "ok 25\n"; + +%$avhv = (); +(%$avhv, $extra) = (foo => 42, pants => 53, bar => "HIKE!"); +print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and !defined $extra; +print "ok 26\n"; + +@extra = qw(whatever and stuff); +%$avhv = (); +(%$avhv, @extra) = (foo => 42, pants => 53, bar => "HIKE!"); +print "not " unless "@$avhv[1..3]" eq '42 HIKE! 53' and @extra == 0; +print "ok 27\n"; + +%$avhv = (); +(@extra, %$avhv) = (foo => 42, pants => 53, bar => "HIKE!"); +print "not " unless ref $avhv->[0] eq 'HASH' and @extra == 6; +print "ok 28\n"; diff --git a/t/op/hashwarn.t b/t/op/hashwarn.t index 634e7e1f25..0b6f10feee 100755 --- a/t/op/hashwarn.t +++ b/t/op/hashwarn.t @@ -14,7 +14,7 @@ BEGIN { # ...and save 'em as we go $SIG{'__WARN__'} = sub { push @warnings, @_ }; $| = 1; - print "1..7\n"; + print "1..9\n"; } END { print "not ok\n# Uncaught warnings:\n@warnings\n" if @warnings } @@ -66,6 +66,13 @@ my $ref_msg = '/^Reference found where even-sized list expected/'; %hash = sub { print "ok" }; test_warning 6, shift @warnings, $odd_msg; + my $avhv = [{x=>1,y=>2}]; + %$avhv = (x=>13,'y'); + test_warning 7, shift @warnings, $odd_msg; + + %$avhv = 'x'; + test_warning 8, shift @warnings, $odd_msg; + $_ = { 1..10 }; - test 7, ! @warnings, "Unexpected warning"; + test 9, ! @warnings, "Unexpected warning"; } |