X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/61b16eb90f32a2433d6de43e477a03b8d9fed039..64f5c2c41358c299ea0b3c7c9ab04fd866c17ce4:/av.c diff --git a/av.c b/av.c index cb99ceb..918844c 100644 --- a/av.c +++ b/av.c @@ -87,6 +87,10 @@ Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp, { PERL_ARGS_ASSERT_AV_EXTEND_GUTS; + if (key < -1) /* -1 is legal */ + Perl_croak(aTHX_ + "panic: av_extend_guts() negative count (%" IVdf ")", (IV)key); + if (key > *maxp) { SV** ary; SSize_t tmp; @@ -136,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 { @@ -172,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; @@ -206,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 */ @@ -240,10 +236,13 @@ S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *keyp) SV** Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval) { + SSize_t neg; + SSize_t size; + PERL_ARGS_ASSERT_AV_FETCH; assert(SvTYPE(av) == SVt_PVAV); - if (SvRMAGICAL(av)) { + if (UNLIKELY(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)) { @@ -264,23 +263,23 @@ Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval) } } - if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) + neg = (key < 0); + size = AvFILLp(av) + 1; + key += neg * size; /* handle negative index without using branch */ + + /* the cast from SSize_t to Size_t allows both (key < 0) and (key >= size) + * to be tested as a single condition */ + if ((Size_t)key >= (Size_t)size) { + if (UNLIKELY(neg)) return NULL; + goto emptyness; } - if (key > AvFILLp(av) || !AvARRAY(av)[key]) { + if (!AvARRAY(av)[key]) { emptyness: return lval ? av_store(av,key,newSV(0)) : NULL; } - if (AvREIFY(av) - && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */ - || SvIS_FREED(AvARRAY(av)[key]))) { - AvARRAY(av)[key] = NULL; /* 1/2 reify */ - goto emptyness; - } return &AvARRAY(av)[key]; } @@ -298,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. @@ -402,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); @@ -423,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; } @@ -432,11 +439,15 @@ Perl_av_make(pTHX_ SSize_t size, SV **strp) /* =for apidoc av_clear -Clears an array, making it empty. Does not free the memory C uses to -store its list of scalars. If any destructors are triggered as a result, -C itself may be freed when this function returns. +Frees the all the elements of an array, leaving it empty. +The XS equivalent of C<@array = ()>. See also L. -Perl equivalent: C<@myarray = ();>. +Note that it is possible that the actions of a destructor called directly +or indirectly by freeing an element of the array could cause the reference +count of the array itself to be reduced (e.g. by deleting an entry in the +symbol table). So it is a possibility that the AV could have been freed +(or even reallocated) on return from the call unless you hold a reference +to it. =cut */ @@ -446,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); @@ -471,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 @@ -490,15 +506,26 @@ 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); + } } /* =for apidoc av_undef -Undefines the array. Frees the memory used by the av to store its list of -scalars. If any destructors are triggered as a result, C itself may -be freed. +Undefines the array. The XS equivalent of C. + +As well as freeing all the elements of the array (like C), this +also frees the memory used by the av to store its list of scalars. + +See L for a note about the array possibly being invalid on +return. =cut */ @@ -507,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); @@ -515,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]); } @@ -529,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); + } } /* @@ -555,10 +595,10 @@ Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val) /* =for apidoc av_push -Pushes an SV onto the end of the array. The array will grow automatically -to accommodate the addition. This takes ownership of one reference count. +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 */ @@ -646,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 */ @@ -833,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 */ @@ -966,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 @@ -1008,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; } /*