X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/eb578fdb5569b91c28466a4d1939e381ff6ceaf4..8936b48a49448f4e7b8a0b9849a085b48ac700ff:/av.c diff --git a/av.c b/av.c index f8f123a..b251822 100644 --- a/av.c +++ b/av.c @@ -80,23 +80,35 @@ Perl_av_extend(pTHX_ AV *av, I32 key) arg1); return; } - if (key > AvMAX(av)) { + av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av)); +} + +/* The guts of av_extend. *Not* for general use! */ +void +Perl_av_extend_guts(pTHX_ AV *av, I32 key, SSize_t *maxp, SV ***allocp, + SV ***arrayp) +{ + dVAR; + + PERL_ARGS_ASSERT_AV_EXTEND_GUTS; + + if (key > *maxp) { SV** ary; I32 tmp; I32 newmax; - if (AvALLOC(av) != AvARRAY(av)) { - ary = AvALLOC(av) + AvFILLp(av) + 1; - tmp = AvARRAY(av) - AvALLOC(av); - Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*); - AvMAX(av) += tmp; - AvARRAY(av) = AvALLOC(av); + if (av && *allocp != *arrayp) { + ary = *allocp + AvFILLp(av) + 1; + tmp = *arrayp - *allocp; + Move(*arrayp, *allocp, AvFILLp(av)+1, SV*); + *maxp += tmp; + *arrayp = *allocp; if (AvREAL(av)) { while (tmp) ary[--tmp] = &PL_sv_undef; } - if (key > AvMAX(av) - 10) { - newmax = key + AvMAX(av); + if (key > *maxp - 10) { + newmax = key + *maxp; goto resize; } } @@ -106,7 +118,7 @@ Perl_av_extend(pTHX_ AV *av, I32 key) "Out of memory during array extend"; /* Duplicated in pp_hot.c */ #endif - if (AvALLOC(av)) { + if (*allocp) { #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC) MEM_SIZE bytes; IV itmp; @@ -126,17 +138,17 @@ Perl_av_extend(pTHX_ AV *av, I32 key) memory that might never be read. So, I feel, better to keep the current lazy system of only writing to it if our caller has a need for more space. NWC */ - newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) / + newmax = Perl_safesysmalloc_size((void*)*allocp) / sizeof(const SV *) - 1; if (key <= newmax) goto resized; #endif - newmax = key + AvMAX(av) / 5; + newmax = key + *maxp / 5; resize: MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend); #if defined(STRANGE_MALLOC) || defined(MYMALLOC) - Renew(AvALLOC(av),newmax+1, SV*); + Renew(*allocp,newmax+1, SV*); #else bytes = (newmax + 1) * sizeof(const SV *); #define MALLOC_OVERHEAD 16 @@ -147,38 +159,38 @@ Perl_av_extend(pTHX_ AV *av, I32 key) itmp /= sizeof(const SV *); assert(itmp > newmax); newmax = itmp - 1; - assert(newmax >= AvMAX(av)); + assert(newmax >= *maxp); Newx(ary, newmax+1, SV*); - Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*); - Safefree(AvALLOC(av)); - AvALLOC(av) = ary; + Copy(*allocp, ary, *maxp+1, SV*); + Safefree(*allocp); + *allocp = ary; #endif #ifdef Perl_safesysmalloc_size resized: #endif - ary = AvALLOC(av) + AvMAX(av) + 1; - tmp = newmax - AvMAX(av); + ary = *allocp + *maxp + 1; + tmp = newmax - *maxp; if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */ - PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base); - PL_stack_base = AvALLOC(av); + PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base); + PL_stack_base = *allocp; PL_stack_max = PL_stack_base + newmax; } } else { newmax = key < 3 ? 3 : key; MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend); - Newx(AvALLOC(av), newmax+1, SV*); - ary = AvALLOC(av) + 1; + Newx(*allocp, newmax+1, SV*); + ary = *allocp + 1; tmp = newmax; - AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */ + *allocp[0] = &PL_sv_undef; /* For the stacks */ } - if (AvREAL(av)) { + if (av && AvREAL(av)) { while (tmp) ary[--tmp] = &PL_sv_undef; } - AvARRAY(av) = AvALLOC(av); - AvMAX(av) = newmax; + *arrayp = *allocp; + *maxp = newmax; } } } @@ -199,8 +211,33 @@ The rough perl equivalent is C<$myarray[$idx]>. =cut */ +static bool +S_adjust_index(pTHX_ AV *av, const MAGIC *mg, I32 *keyp) +{ + bool adjust_index = 1; + if (mg) { + /* Handle negative array indices 20020222 MJD */ + SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg); + SvGETMAGIC(ref); + if (SvROK(ref) && SvOBJECT(SvRV(ref))) { + SV * const * const negative_indices_glob = + hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0); + + if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob))) + adjust_index = 0; + } + } + + if (adjust_index) { + *keyp += AvFILL(av) + 1; + if (*keyp < 0) + return FALSE; + } + return TRUE; +} + SV** -Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval) +Perl_av_fetch(pTHX_ AV *av, I32 key, I32 lval) { dVAR; @@ -213,23 +250,8 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval) if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) { SV *sv; if (key < 0) { - I32 adjust_index = 1; - if (tied_magic) { - /* Handle negative array indices 20020222 MJD */ - SV * const * const negative_indices_glob = - hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), - tied_magic))), - NEGATIVE_INDICES_VAR, 16, 0); - - if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob))) - adjust_index = 0; - } - - if (adjust_index) { - key += AvFILL(av) + 1; - if (key < 0) + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) return NULL; - } } sv = sv_newmortal(); @@ -286,7 +308,7 @@ more information on how to use this function on tied arrays. */ SV** -Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) +Perl_av_store(pTHX_ AV *av, I32 key, SV *val) { dVAR; SV** ary; @@ -304,21 +326,9 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) if (SvRMAGICAL(av)) { const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied); if (tied_magic) { - /* Handle negative array indices 20020222 MJD */ if (key < 0) { - bool adjust_index = 1; - SV * const * const negative_indices_glob = - hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), - tied_magic))), - NEGATIVE_INDICES_VAR, 16, 0); - if (negative_indices_glob - && SvTRUE(GvSV(*negative_indices_glob))) - adjust_index = 0; - if (adjust_index) { - key += AvFILL(av) + 1; - if (key < 0) + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) return 0; - } } if (val != &PL_sv_undef) { mg_copy(MUTABLE_SV(av), val, 0, key); @@ -335,7 +345,7 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) } if (SvREADONLY(av) && key >= AvFILL(av)) - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); if (!AvREAL(av) && AvREIFY(av)) av_reify(av); @@ -387,7 +397,7 @@ Perl equivalent: C */ AV * -Perl_av_make(pTHX_ register I32 size, register SV **strp) +Perl_av_make(pTHX_ I32 size, SV **strp) { AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV)); /* sv_upgrade does AvREAL_only() */ @@ -400,7 +410,10 @@ Perl_av_make(pTHX_ register I32 size, register SV **strp) Newx(ary,size,SV*); AvALLOC(av) = ary; AvARRAY(av) = ary; - AvFILLp(av) = AvMAX(av) = size - 1; + AvMAX(av) = size - 1; + AvFILLp(av) = -1; + ENTER; + SAVEFREESV(av); for (i = 0; i < size; i++) { assert (*strp); @@ -408,11 +421,15 @@ Perl_av_make(pTHX_ register I32 size, register SV **strp) have multiple references to the same temp scalar (e.g. from a list slice) */ + SvGETMAGIC(*strp); /* before newSV, in case it dies */ + AvFILLp(av)++; ary[i] = newSV(0); sv_setsv_flags(ary[i], *strp, - SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL); + SV_DO_COW_SVSETSV|SV_NOSTEAL); strp++; } + SvREFCNT_inc_simple_void_NN(av); + LEAVE; } return av; } @@ -430,7 +447,7 @@ Perl equivalent: C<@myarray = ();>. */ void -Perl_av_clear(pTHX_ register AV *av) +Perl_av_clear(pTHX_ AV *av) { dVAR; I32 extra; @@ -446,7 +463,7 @@ Perl_av_clear(pTHX_ register AV *av) #endif if (SvREADONLY(av)) - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); /* Give any tie a chance to cleanup first */ if (SvRMAGICAL(av)) { @@ -493,7 +510,7 @@ be freed. */ void -Perl_av_undef(pTHX_ register AV *av) +Perl_av_undef(pTHX_ AV *av) { bool real; @@ -553,7 +570,7 @@ Perl equivalent: C. */ void -Perl_av_push(pTHX_ register AV *av, SV *val) +Perl_av_push(pTHX_ AV *av, SV *val) { dVAR; MAGIC *mg; @@ -562,7 +579,7 @@ Perl_av_push(pTHX_ register AV *av, SV *val) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "PUSH", G_DISCARD, 1, @@ -584,7 +601,7 @@ Perl equivalent: C */ SV * -Perl_av_pop(pTHX_ register AV *av) +Perl_av_pop(pTHX_ AV *av) { dVAR; SV *retval; @@ -594,7 +611,7 @@ Perl_av_pop(pTHX_ register AV *av) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "POP", 0, 0); if (retval) @@ -645,7 +662,7 @@ Perl equivalent: C */ void -Perl_av_unshift(pTHX_ register AV *av, register I32 num) +Perl_av_unshift(pTHX_ AV *av, I32 num) { dVAR; I32 i; @@ -655,7 +672,7 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT", @@ -710,7 +727,7 @@ Perl equivalent: C */ SV * -Perl_av_shift(pTHX_ register AV *av) +Perl_av_shift(pTHX_ AV *av) { dVAR; SV *retval; @@ -720,7 +737,7 @@ Perl_av_shift(pTHX_ register AV *av) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "SHIFT", 0, 0); if (retval) @@ -775,7 +792,7 @@ the same as C. =cut */ void -Perl_av_fill(pTHX_ register AV *av, I32 fill) +Perl_av_fill(pTHX_ AV *av, I32 fill) { dVAR; MAGIC *mg; @@ -836,30 +853,16 @@ Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(aTHX); + Perl_croak_no_modify(); if (SvRMAGICAL(av)) { const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied); if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) { - /* Handle negative array indices 20020222 MJD */ SV **svp; if (key < 0) { - unsigned adjust_index = 1; - if (tied_magic) { - SV * const * const negative_indices_glob = - hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), - tied_magic))), - NEGATIVE_INDICES_VAR, 16, 0); - if (negative_indices_glob - && SvTRUE(GvSV(*negative_indices_glob))) - adjust_index = 0; - } - if (adjust_index) { - key += AvFILL(av) + 1; - if (key < 0) + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) return NULL; - } } svp = av_fetch(av, key, TRUE); if (svp) { @@ -931,27 +934,11 @@ Perl_av_exists(pTHX_ AV *av, I32 key) const MAGIC * const regdata_magic = mg_find((const SV *)av, PERL_MAGIC_regdata); if (tied_magic || regdata_magic) { - SV * const sv = sv_newmortal(); MAGIC *mg; /* Handle negative array indices 20020222 MJD */ if (key < 0) { - unsigned adjust_index = 1; - if (tied_magic) { - SV * const * const negative_indices_glob = - hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), - tied_magic))), - NEGATIVE_INDICES_VAR, 16, 0); - if (negative_indices_glob - && SvTRUE(GvSV(*negative_indices_glob))) - adjust_index = 0; - } - if (adjust_index) { - key += AvFILL(av) + 1; - if (key < 0) + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) return FALSE; - else - return TRUE; - } } if(key >= 0 && regdata_magic) { @@ -960,14 +947,18 @@ Perl_av_exists(pTHX_ AV *av, I32 key) else return FALSE; } - - mg_copy(MUTABLE_SV(av), sv, 0, key); - mg = mg_find(sv, PERL_MAGIC_tiedelem); - if (mg) { - magic_existspack(sv, mg); - return cBOOL(SvTRUE_nomg(sv)); - } - + { + SV * const sv = sv_newmortal(); + mg_copy(MUTABLE_SV(av), sv, 0, key); + mg = mg_find(sv, PERL_MAGIC_tiedelem); + if (mg) { + magic_existspack(sv, mg); + { + I32 retbool = SvTRUE_nomg_NN(sv); + return cBOOL(retbool); + } + } + } } }