X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/25cf9644e6dfb6b7cb9e767b3f52baa4b81a7df0..17b8f3a1378b3c300c2e4ab298a8418f720a6b84:/av.c?ds=sidebyside diff --git a/av.c b/av.c index 21828a9..f10f124 100644 --- a/av.c +++ b/av.c @@ -89,7 +89,7 @@ Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp, if (key < -1) /* -1 is legal */ Perl_croak(aTHX_ - "panic: av_extend_guts() negative count (%"IVdf")", (IV)key); + "panic: av_extend_guts() negative count (%" IVdf ")", (IV)key); if (key > *maxp) { SV** ary; @@ -140,17 +140,13 @@ Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp, ? SSize_t_MAX : key + newmax; resize: { -#ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */ - static const char oom_array_extend[] = - "Out of memory during array extend"; -#endif /* it should really be newmax+1 here, but if newmax * happens to equal SSize_t_MAX, then newmax+1 is * undefined. This means technically we croak one * index lower than we should in theory; in practice * its unlikely the system has SSize_t_MAX/sizeof(SV*) * bytes to spare! */ - MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend); + MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend"); } #ifdef STRESS_REALLOC { @@ -176,12 +172,8 @@ Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp, else { newmax = key < 3 ? 3 : key; { -#ifdef PERL_MALLOC_WRAP /* Duplicated in pp_hot.c */ - static const char oom_array_extend[] = - "Out of memory during array extend"; -#endif /* see comment above about newmax+1*/ - MEM_WRAP_CHECK_1(newmax, SV*, oom_array_extend); + MEM_WRAP_CHECK_s(newmax, SV*, "Out of memory during array extend"); } Newx(*allocp, newmax+1, SV*); ary = *allocp + 1; @@ -210,7 +202,7 @@ value is non-null before dereferencing it to a C. See L for more information on how to use this function on tied arrays. -The rough perl equivalent is C<$myarray[$idx]>. +The rough perl equivalent is C<$myarray[$key]>. =cut */ @@ -305,7 +297,7 @@ Note that the caller is responsible for suitably incrementing the reference count of C before the call, and decrementing it if the function returned C. -Approximate Perl equivalent: C<$myarray[$key] = $val;>. +Approximate Perl equivalent: C. See L for more information on how to use this function on tied arrays. @@ -364,8 +356,8 @@ Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val) } AvFILLp(av) = key; } - else if (AvREAL(av)) - SvREFCNT_dec(ary[key]); + else if (AvREAL(av) && LIKELY(ary[key] != val)) + SvREFCNT_dec(ary[key]); ary[key] = val; if (SvSMAGICAL(av)) { const MAGIC *mg = SvMAGIC(av); @@ -409,13 +401,18 @@ Perl_av_make(pTHX_ SSize_t size, SV **strp) if (size) { /* "defined" was returning undef for size==0 anyway. */ SV** ary; SSize_t i; + SSize_t orig_ix; + Newx(ary,size,SV*); AvALLOC(av) = ary; AvARRAY(av) = ary; AvMAX(av) = size - 1; AvFILLp(av) = -1; - ENTER; - SAVEFREESV(av); + /* avoid av being leaked if croak when calling magic below */ + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = (SV*)av; + orig_ix = PL_tmps_ix; + for (i = 0; i < size; i++) { assert (*strp); @@ -430,8 +427,11 @@ Perl_av_make(pTHX_ SSize_t size, SV **strp) SV_DO_COW_SVSETSV|SV_NOSTEAL); strp++; } - SvREFCNT_inc_simple_void_NN(av); - LEAVE; + /* disarm av's leak guard */ + if (LIKELY(PL_tmps_ix == orig_ix)) + PL_tmps_ix--; + else + PL_tmps_stack[orig_ix] = &PL_sv_undef; } return av; } @@ -457,6 +457,7 @@ Perl_av_clear(pTHX_ AV *av) { SSize_t extra; bool real; + SSize_t orig_ix = 0; PERL_ARGS_ASSERT_AV_CLEAR; assert(SvTYPE(av) == SVt_PVAV); @@ -482,11 +483,15 @@ Perl_av_clear(pTHX_ AV *av) if (AvMAX(av) < 0) return; - if ((real = !!AvREAL(av))) { + if ((real = cBOOL(AvREAL(av)))) { SV** const ary = AvARRAY(av); SSize_t index = AvFILLp(av) + 1; - ENTER; - SAVEFREESV(SvREFCNT_inc_simple_NN(av)); + + /* avoid av being freed when calling destructors below */ + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av); + orig_ix = PL_tmps_ix; + while (index) { SV * const sv = ary[--index]; /* undef the slot before freeing the value, because a @@ -501,7 +506,14 @@ Perl_av_clear(pTHX_ AV *av) AvARRAY(av) = AvALLOC(av); } AvFILLp(av) = -1; - if (real) LEAVE; + if (real) { + /* disarm av's premature free guard */ + if (LIKELY(PL_tmps_ix == orig_ix)) + PL_tmps_ix--; + else + PL_tmps_stack[orig_ix] = &PL_sv_undef; + SvREFCNT_dec_NN(av); + } } /* @@ -522,6 +534,7 @@ void Perl_av_undef(pTHX_ AV *av) { bool real; + SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible unitialized use */ PERL_ARGS_ASSERT_AV_UNDEF; assert(SvTYPE(av) == SVt_PVAV); @@ -530,10 +543,15 @@ Perl_av_undef(pTHX_ AV *av) if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) av_fill(av, -1); - if ((real = !!AvREAL(av))) { + real = cBOOL(AvREAL(av)); + if (real) { SSize_t key = AvFILLp(av) + 1; - ENTER; - SAVEFREESV(SvREFCNT_inc_simple_NN(av)); + + /* avoid av being freed when calling destructors below */ + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple_NN(av); + orig_ix = PL_tmps_ix; + while (key) SvREFCNT_dec(AvARRAY(av)[--key]); } @@ -544,7 +562,14 @@ Perl_av_undef(pTHX_ AV *av) AvMAX(av) = AvFILLp(av) = -1; if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av)); - if(real) LEAVE; + if (real) { + /* disarm av's premature free guard */ + if (LIKELY(PL_tmps_ix == orig_ix)) + PL_tmps_ix--; + else + PL_tmps_stack[orig_ix] = &PL_sv_undef; + SvREFCNT_dec_NN(av); + } } /* @@ -573,7 +598,7 @@ Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val) Pushes an SV (transferring control of one reference count) onto the end of the array. The array will grow automatically to accommodate the addition. -Perl equivalent: C. +Perl equivalent: C. =cut */ @@ -661,10 +686,9 @@ Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val) =for apidoc av_unshift Unshift the given number of C values onto the beginning of the -array. The array will grow automatically to accommodate the addition. You -must then use C to assign values to these new elements. +array. The array will grow automatically to accommodate the addition. -Perl equivalent: S> +Perl equivalent: S> =cut */ @@ -848,11 +872,13 @@ Perl_av_fill(pTHX_ AV *av, SSize_t fill) /* =for apidoc av_delete -Deletes the element indexed by C from the array, makes the element mortal, -and returns it. If C equals C, the element is freed and null -is returned. Perl equivalent: S> for the -non-C version and a void-context S> for the -C version. +Deletes the element indexed by C from the array, makes the element +mortal, and returns it. If C equals C, the element is +freed and NULL is returned. NULL is also returned if C is out of +range. + +Perl equivalent: S> (with the +C in void context if C is present). =cut */ @@ -981,6 +1007,9 @@ Perl_av_exists(pTHX_ AV *av, SSize_t key) if (key <= AvFILLp(av) && AvARRAY(av)[key]) { + if (SvSMAGICAL(AvARRAY(av)[key]) + && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem)) + return FALSE; return TRUE; } else @@ -1023,17 +1052,27 @@ Perl_av_iter_p(pTHX_ AV *av) { PERL_ARGS_ASSERT_AV_ITER_P; assert(SvTYPE(av) == SVt_PVAV); -#if IVSIZE == I32SIZE - return (IV *)&(mg->mg_len); -#else - if (!mg->mg_ptr) { - IV *temp; - mg->mg_len = IVSIZE; - Newxz(temp, 1, IV); - mg->mg_ptr = (char *) temp; + if (sizeof(IV) == sizeof(SSize_t)) { + return (IV *)&(mg->mg_len); + } else { + if (!mg->mg_ptr) { + IV *temp; + mg->mg_len = IVSIZE; + Newxz(temp, 1, IV); + mg->mg_ptr = (char *) temp; + } + return (IV *)mg->mg_ptr; } - return (IV *)mg->mg_ptr; -#endif +} + +SV * +Perl_av_nonelem(pTHX_ AV *av, SSize_t ix) { + SV * const sv = newSV(0); + PERL_ARGS_ASSERT_AV_NONELEM; + if (!av_store(av,ix,sv)) + return sv_2mortal(sv); /* has tie magic */ + sv_magic(sv, NULL, PERL_MAGIC_nonelem, NULL, 0); + return sv; } /*