X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/5aaab254c02795622bdf42e348ad8473aa1fc643..HEAD:/av.c diff --git a/av.c b/av.c index b251822..15c039b 100644 --- a/av.c +++ b/av.c @@ -15,10 +15,6 @@ * [p.476 of _The Lord of the Rings_, III/iv: "Treebeard"] */ -/* -=head1 Array Manipulation Functions -*/ - #include "EXTERN.h" #define PERL_IN_AV_C #include "perl.h" @@ -26,30 +22,28 @@ void Perl_av_reify(pTHX_ AV *av) { - dVAR; - I32 key; + SSize_t key; PERL_ARGS_ASSERT_AV_REIFY; assert(SvTYPE(av) == SVt_PVAV); if (AvREAL(av)) - return; + return; #ifdef DEBUGGING if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array"); #endif key = AvMAX(av) + 1; while (key > AvFILLp(av) + 1) - AvARRAY(av)[--key] = &PL_sv_undef; + AvARRAY(av)[--key] = NULL; while (key) { - SV * const sv = AvARRAY(av)[--key]; - assert(sv); - if (sv != &PL_sv_undef) - SvREFCNT_inc_simple_void_NN(sv); + SV * const sv = AvARRAY(av)[--key]; + if (sv != &PL_sv_undef) + SvREFCNT_inc_simple_void(sv); } key = AvARRAY(av) - AvALLOC(av); - while (key) - AvALLOC(av)[--key] = &PL_sv_undef; + if (key) + Zero(AvALLOC(av), key, SV*); AvREIFY_off(av); AvREAL_on(av); } @@ -57,16 +51,20 @@ Perl_av_reify(pTHX_ AV *av) /* =for apidoc av_extend -Pre-extend an array. The C is the index to which the array should be -extended. +Pre-extend an array so that it is capable of storing values at indexes +C<0..key>. Thus C guarantees that the array can store 100 +elements, i.e. that C through C +on a plain array will work without any further memory allocation. + +If the av argument is a tied array then will call the C tied +array method with an argument of C<(key+1)>. =cut */ void -Perl_av_extend(pTHX_ AV *av, I32 key) +Perl_av_extend(pTHX_ AV *av, SSize_t key) { - dVAR; MAGIC *mg; PERL_ARGS_ASSERT_AV_EXTEND; @@ -74,124 +72,154 @@ Perl_av_extend(pTHX_ AV *av, I32 key) mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied); if (mg) { - SV *arg1 = sv_newmortal(); - sv_setiv(arg1, (IV)(key + 1)); - Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "EXTEND", G_DISCARD, 1, - arg1); - return; + SV *arg1 = sv_newmortal(); + /* NOTE: the API for av_extend() is NOT the same as the tie method EXTEND. + * + * The C function takes an *index* (assumes 0 indexed arrays) and ensures + * that the array is at least as large as the index provided. + * + * The tied array method EXTEND takes a *count* and ensures that the array + * is at least that many elements large. Thus we have to +1 the key when + * we call the tied method. + */ + sv_setiv(arg1, (IV)(key + 1)); + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(EXTEND), G_DISCARD, 1, + arg1); + return; } av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av)); } /* The guts of av_extend. *Not* for general use! */ +/* Also called directly from pp_assign, padlist_store, padnamelist_store */ void -Perl_av_extend_guts(pTHX_ AV *av, I32 key, SSize_t *maxp, SV ***allocp, - SV ***arrayp) +Perl_av_extend_guts(pTHX_ AV *av, SSize_t key, SSize_t *maxp, SV ***allocp, + SV ***arrayp) { - dVAR; - 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; - I32 tmp; - I32 newmax; - - 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 > *maxp - 10) { - newmax = key + *maxp; - goto resize; - } - } - else { -#ifdef PERL_MALLOC_WRAP - static const char oom_array_extend[] = - "Out of memory during array extend"; /* Duplicated in pp_hot.c */ -#endif + SSize_t ary_offset = *maxp + 1; /* Start NULL initialization + * from this element */ + SSize_t to_null = 0; /* How many elements to Zero */ + SSize_t newmax = 0; - if (*allocp) { -#if !defined(STRANGE_MALLOC) && !defined(MYMALLOC) - MEM_SIZE bytes; - IV itmp; -#endif + if (av && *allocp != *arrayp) { /* a shifted SV* array exists */ + + /* to_null will contain the number of elements currently + * shifted and about to be unshifted. If the array has not + * been shifted to the maximum possible extent, this will be + * a smaller number than (*maxp - AvFILLp(av)). */ + to_null = *arrayp - *allocp; + + *maxp += to_null; + ary_offset = AvFILLp(av) + 1; + + Move(*arrayp, *allocp, AvFILLp(av)+1, SV*); + + if (key > *maxp - 10) { + newmax = key + *maxp; + + /* Zero everything above AvFILLp(av), which could be more + * elements than have actually been shifted. If we don't + * do this, trailing elements at the end of the resized + * array may not be correctly initialized. */ + to_null = *maxp - AvFILLp(av); + + goto resize; + } + } else if (*allocp) { /* a full SV* array exists */ #ifdef Perl_safesysmalloc_size - /* Whilst it would be quite possible to move this logic around - (as I did in the SV code), so as to set AvMAX(av) early, - based on calling Perl_safesysmalloc_size() immediately after - allocation, I'm not convinced that it is a great idea here. - In an array we have to loop round setting everything to - &PL_sv_undef, which means writing to memory, potentially lots - of it, whereas for the SV buffer case we don't touch the - "bonus" memory. So there there is no cost in telling the - world about it, whereas here we have to do work before we can - tell the world about it, and that work involves writing to - 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*)*allocp) / - sizeof(const SV *) - 1; - - if (key <= newmax) - goto resized; + /* Whilst it would be quite possible to move this logic around + (as I did in the SV code), so as to set AvMAX(av) early, + based on calling Perl_safesysmalloc_size() immediately after + allocation, I'm not convinced that it is a great idea here. + In an array we have to loop round setting everything to + NULL, which means writing to memory, potentially lots + of it, whereas for the SV buffer case we don't touch the + "bonus" memory. So there there is no cost in telling the + world about it, whereas here we have to do work before we can + tell the world about it, and that work involves writing to + 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*)*allocp) / + sizeof(const SV *) - 1; + + if (key <= newmax) + goto resized; #endif - newmax = key + *maxp / 5; - resize: - MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend); -#if defined(STRANGE_MALLOC) || defined(MYMALLOC) - Renew(*allocp,newmax+1, SV*); + /* overflow-safe version of newmax = key + *maxp/5 */ + newmax = *maxp / 5; + newmax = (key > SSize_t_MAX - newmax) + ? SSize_t_MAX : key + newmax; + resize: + { + /* 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_s(newmax, SV*, "Out of memory during array extend"); + } +#ifdef STRESS_REALLOC + { + SV ** const old_alloc = *allocp; + Newx(*allocp, newmax+1, SV*); + Copy(old_alloc, *allocp, *maxp + 1, SV*); + Safefree(old_alloc); + } #else - bytes = (newmax + 1) * sizeof(const SV *); -#define MALLOC_OVERHEAD 16 - itmp = MALLOC_OVERHEAD; - while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes) - itmp += itmp; - itmp -= MALLOC_OVERHEAD; - itmp /= sizeof(const SV *); - assert(itmp > newmax); - newmax = itmp - 1; - assert(newmax >= *maxp); - Newx(ary, newmax+1, SV*); - Copy(*allocp, ary, *maxp+1, SV*); - Safefree(*allocp); - *allocp = ary; + Renew(*allocp,newmax+1, SV*); #endif #ifdef Perl_safesysmalloc_size - resized: + resized: #endif - ary = *allocp + *maxp + 1; - tmp = newmax - *maxp; - if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */ - 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(*allocp, newmax+1, SV*); - ary = *allocp + 1; - tmp = newmax; - *allocp[0] = &PL_sv_undef; /* For the stacks */ - } - if (av && AvREAL(av)) { - while (tmp) - ary[--tmp] = &PL_sv_undef; - } - - *arrayp = *allocp; - *maxp = newmax; - } + to_null += newmax - *maxp; /* Initialize all new elements + * (newmax - *maxp) in addition to + * any previously specified */ + *maxp = newmax; + + /* See GH#18014 for discussion of when this might be needed: */ + if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */ + PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base); + PL_stack_base = *allocp; + PL_stack_max = PL_stack_base + newmax; + } + } else { /* there is no SV* array yet */ + *maxp = key < PERL_ARRAY_NEW_MIN_KEY ? + PERL_ARRAY_NEW_MIN_KEY : key; + { + /* see comment above about newmax+1*/ + MEM_WRAP_CHECK_s(*maxp, SV*, + "Out of memory during array extend"); + } + /* Newxz isn't used below because testing showed it to be slower + * than Newx+Zero (also slower than Newx + the previous while + * loop) for small arrays, which are very common in perl. */ + Newx(*allocp, *maxp+1, SV*); + /* Stacks require only the first element to be &PL_sv_undef + * (set elsewhere). However, since non-stack AVs are likely + * to dominate in modern production applications, stacks + * don't get any special treatment here. + * See https://github.com/Perl/perl5/pull/18690 for more detail */ + ary_offset = 0; + to_null = *maxp+1; /* Initialize all new array elements */ + goto zero; + } + + if (av && AvREAL(av)) { + zero: + Zero(*allocp + ary_offset,to_null,SV*); + } + + *arrayp = *allocp; } } @@ -199,89 +227,90 @@ Perl_av_extend_guts(pTHX_ AV *av, I32 key, SSize_t *maxp, SV ***allocp, =for apidoc av_fetch Returns the SV at the specified index in the array. The C is the -index. If lval is true, you are guaranteed to get a real SV back (in case +index. If C is true, you are guaranteed to get a real SV back (in case it wasn't real before), which you can then modify. Check that the return -value is non-null before dereferencing it to a C. +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 */ static bool -S_adjust_index(pTHX_ AV *av, const MAGIC *mg, I32 *keyp) +S_adjust_index(pTHX_ AV *av, const MAGIC *mg, SSize_t *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; - } + /* 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 && isGV(*negative_indices_glob) + && SvTRUE(GvSV(*negative_indices_glob))) + adjust_index = 0; + } } if (adjust_index) { - *keyp += AvFILL(av) + 1; - if (*keyp < 0) - return FALSE; + *keyp += AvFILL(av) + 1; + if (*keyp < 0) + return FALSE; } return TRUE; } SV** -Perl_av_fetch(pTHX_ AV *av, I32 key, I32 lval) +Perl_av_fetch(pTHX_ AV *av, SSize_t key, I32 lval) { - dVAR; + 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); + = mg_find((const SV *)av, PERL_MAGIC_tied); if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) { - SV *sv; - if (key < 0) { - if (!S_adjust_index(aTHX_ av, tied_magic, &key)) - return NULL; - } - - sv = sv_newmortal(); - sv_upgrade(sv, SVt_PVLV); - mg_copy(MUTABLE_SV(av), sv, 0, key); - if (!tied_magic) /* for regdata, force leavesub to make copies */ - SvTEMP_off(sv); - LvTYPE(sv) = 't'; - LvTARG(sv) = sv; /* fake (SV**) */ - return &(LvTARG(sv)); + SV *sv; + if (key < 0) { + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) + return NULL; + } + + sv = newSV_type_mortal(SVt_PVLV); + mg_copy(MUTABLE_SV(av), sv, 0, key); + if (!tied_magic) /* for regdata, force leavesub to make copies */ + SvTEMP_off(sv); + LvTYPE(sv) = 't'; + LvTARG(sv) = sv; /* fake (SV**) */ + return &(LvTARG(sv)); } } - if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) - return NULL; - } + neg = (key < 0); + size = AvFILLp(av) + 1; + key += neg * size; /* handle negative index without using branch */ - if (key > AvFILLp(av) || AvARRAY(av)[key] == &PL_sv_undef) { - emptyness: - return lval ? av_store(av,key,newSV(0)) : NULL; + /* 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 emptiness; } - if (AvREIFY(av) - && (!AvARRAY(av)[key] /* eg. @_ could have freed elts */ - || SvIS_FREED(AvARRAY(av)[key]))) { - AvARRAY(av)[key] = &PL_sv_undef; /* 1/2 reify */ - goto emptyness; + if (!AvARRAY(av)[key]) { + emptiness: + return lval ? av_store(av,key,newSV_type(SVt_NULL)) : NULL; } + return &AvARRAY(av)[key]; } @@ -289,17 +318,17 @@ Perl_av_fetch(pTHX_ AV *av, I32 key, I32 lval) =for apidoc av_store Stores an SV in an array. The array index is specified as C. The -return value will be NULL if the operation failed or if the value did not +return value will be C if the operation failed or if the value did not need to be actually stored within the array (as in the case of tied -arrays). Otherwise, it can be dereferenced +arrays). Otherwise, it can be dereferenced to get the C that was stored there (= C)). Note that the caller is responsible for suitably incrementing the reference count of C before the call, and decrementing it if the function -returned NULL. +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. @@ -308,9 +337,8 @@ more information on how to use this function on tied arrays. */ SV** -Perl_av_store(pTHX_ AV *av, I32 key, SV *val) +Perl_av_store(pTHX_ AV *av, SSize_t key, SV *val) { - dVAR; SV** ary; PERL_ARGS_ASSERT_AV_STORE; @@ -320,66 +348,104 @@ Perl_av_store(pTHX_ AV *av, I32 key, SV *val) (unicode_alternate may be NULL). */ - if (!val) - val = &PL_sv_undef; - if (SvRMAGICAL(av)) { const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied); if (tied_magic) { if (key < 0) { - if (!S_adjust_index(aTHX_ av, tied_magic, &key)) + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) return 0; } - if (val != &PL_sv_undef) { - mg_copy(MUTABLE_SV(av), val, 0, key); - } - return NULL; + if (val) { + mg_copy(MUTABLE_SV(av), val, 0, key); + } + return NULL; } } if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) - return NULL; + key += AvFILL(av) + 1; + if (key < 0) + return NULL; } if (SvREADONLY(av) && key >= AvFILL(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if (!AvREAL(av) && AvREIFY(av)) - av_reify(av); + av_reify(av); if (key > AvMAX(av)) - av_extend(av,key); + av_extend(av,key); ary = AvARRAY(av); if (AvFILLp(av) < key) { - if (!AvREAL(av)) { - if (av == PL_curstack && key > PL_stack_sp - PL_stack_base) - PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */ - do { - ary[++AvFILLp(av)] = &PL_sv_undef; - } while (AvFILLp(av) < key); - } - AvFILLp(av) = key; + if (!AvREAL(av)) { + if (av == PL_curstack && key > PL_stack_sp - PL_stack_base) + PL_stack_sp = PL_stack_base + key; /* XPUSH in disguise */ + do { + ary[++AvFILLp(av)] = NULL; + } while (AvFILLp(av) < key); + } + AvFILLp(av) = key; } else if (AvREAL(av)) - SvREFCNT_dec(ary[key]); + SvREFCNT_dec(ary[key]); + + /* store the val into the AV before we call magic so that the magic can + * "see" the new value. Especially set magic on the AV itself. */ ary[key] = val; + if (SvSMAGICAL(av)) { - const MAGIC *mg = SvMAGIC(av); - bool set = TRUE; - for (; mg; mg = mg->mg_moremagic) { - if (!isUPPER(mg->mg_type)) continue; - if (val != &PL_sv_undef) { - sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key); - } - if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) { - PL_delaymagic |= DM_ARRAY_ISA; - set = FALSE; - } - } - if (set) - mg_set(MUTABLE_SV(av)); + const MAGIC *mg = SvMAGIC(av); + bool set = TRUE; + /* We have to increment the refcount on val before we call any magic, + * as it is now stored in the AV (just before this block), we will + * then call the magic handlers which might die/Perl_croak, and + * longjmp up the stack to the most recent exception trap. Which means + * the caller code that would be expected to handle the refcount + * increment likely would never be executed, leading to a double free. + * This can happen in a case like + * + * @ary = (1); + * + * or this: + * + * if (av_store(av,n,sv)) SvREFCNT_inc(sv); + * + * where @ary/av has set magic applied to it which can die. In the + * first case the sv representing 1 would be mortalized, so when the + * set magic threw an exception it would be freed as part of the + * normal stack unwind. However this leaves the av structure still + * holding a valid visible pointer to the now freed value. In practice + * the next SV created will reuse the same reference, but without the + * refcount to account for the previous ownership and we end up with + * warnings about a totally different variable being double freed in + * the form of "attempt to free unreferenced variable" + * warnings/errors. + * + * https://github.com/Perl/perl5/issues/20675 + * + * Arguably the API for av_store is broken in the face of magic. Instead + * av_store should be responsible for the refcount increment, and only + * not do it when specifically told to do so (eg, when storing an + * otherwise unreferenced scalar into an AV). + */ + SvREFCNT_inc(val); /* see comment above */ + for (; mg; mg = mg->mg_moremagic) { + if (!isUPPER(mg->mg_type)) continue; + if (val) { + sv_magic(val, MUTABLE_SV(av), toLOWER(mg->mg_type), 0, key); + } + if (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) { + PL_delaymagic |= DM_ARRAY_ISA; + set = FALSE; + } + } + if (set) + mg_set(MUTABLE_SV(av)); + /* And now we are done the magic, we have to decrement it back as the av_store() api + * says the caller is responsible for the refcount increment, assuming + * av_store returns true. */ + SvREFCNT_dec(val); } return &ary[key]; } @@ -387,9 +453,9 @@ Perl_av_store(pTHX_ AV *av, I32 key, SV *val) /* =for apidoc av_make -Creates a new AV and populates it with a list of SVs. The SVs are copied -into the array, so they may be freed after the call to av_make. The new AV -will have a reference count of 1. +Creates a new AV and populates it with a list (C<**strp>, length C) of +SVs. A copy is made of each SV, so their refcounts are not changed. The new +AV will have a reference count of 1. Perl equivalent: C @@ -397,51 +463,169 @@ Perl equivalent: C */ AV * -Perl_av_make(pTHX_ I32 size, SV **strp) +Perl_av_make(pTHX_ SSize_t size, SV **strp) { - AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV)); + AV * const av = newAV(); /* sv_upgrade does AvREAL_only() */ PERL_ARGS_ASSERT_AV_MAKE; assert(SvTYPE(av) == SVt_PVAV); if (size) { /* "defined" was returning undef for size==0 anyway. */ SV** ary; - I32 i; - Newx(ary,size,SV*); - AvALLOC(av) = ary; - AvARRAY(av) = ary; - AvMAX(av) = size - 1; - AvFILLp(av) = -1; - ENTER; - SAVEFREESV(av); - for (i = 0; i < size; i++) { - assert (*strp); - - /* Don't let sv_setsv swipe, since our source array might - 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_DO_COW_SVSETSV|SV_NOSTEAL); - strp++; - } - SvREFCNT_inc_simple_void_NN(av); - LEAVE; + SSize_t i; + SSize_t orig_ix; + + Newx(ary,size,SV*); + AvALLOC(av) = ary; + AvARRAY(av) = ary; + AvMAX(av) = size - 1; + /* 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); + + /* Don't let sv_setsv swipe, since our source array might + 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_type(SVt_NULL); + sv_setsv_flags(ary[i], *strp, + SV_DO_COW_SVSETSV|SV_NOSTEAL); + strp++; + } + /* 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; } /* +=for apidoc newAVav + +Creates a new AV and populates it with values copied from an existing AV. The +new AV will have a reference count of 1, and will contain newly created SVs +copied from the original SV. The original source will remain unchanged. + +Perl equivalent: C + +=cut +*/ + +AV * +Perl_newAVav(pTHX_ AV *oav) +{ + PERL_ARGS_ASSERT_NEWAVAV; + + Size_t count = av_count(oav); + + if(UNLIKELY(!oav) || count == 0) + return newAV(); + + AV *ret = newAV_alloc_x(count); + + /* avoid ret being leaked if croak when calling magic below */ + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = (SV *)ret; + SSize_t ret_at_tmps_ix = PL_tmps_ix; + + Size_t i; + if(LIKELY(!SvRMAGICAL(oav) && AvREAL(oav) && (SvTYPE(oav) == SVt_PVAV))) { + for(i = 0; i < count; i++) { + SV **svp = av_fetch_simple(oav, i, 0); + av_push_simple(ret, svp ? newSVsv(*svp) : &PL_sv_undef); + } + } else { + for(i = 0; i < count; i++) { + SV **svp = av_fetch(oav, i, 0); + av_push_simple(ret, svp ? newSVsv(*svp) : &PL_sv_undef); + } + } + + /* disarm leak guard */ + if(LIKELY(PL_tmps_ix == ret_at_tmps_ix)) + PL_tmps_ix--; + else + PL_tmps_stack[ret_at_tmps_ix] = &PL_sv_undef; + + return ret; +} + +/* +=for apidoc newAVhv + +Creates a new AV and populates it with keys and values copied from an existing +HV. The new AV will have a reference count of 1, and will contain newly +created SVs copied from the original HV. The original source will remain +unchanged. + +Perl equivalent: C + +=cut +*/ + +AV * +Perl_newAVhv(pTHX_ HV *ohv) +{ + PERL_ARGS_ASSERT_NEWAVHV; + + if(UNLIKELY(!ohv)) + return newAV(); + + bool tied = SvRMAGICAL(ohv) && mg_find(MUTABLE_SV(ohv), PERL_MAGIC_tied); + + Size_t nkeys = hv_iterinit(ohv); + /* This number isn't perfect but it doesn't matter; it only has to be + * close to make the initial allocation about the right size + */ + AV *ret = newAV_alloc_xz(nkeys ? nkeys * 2 : 2); + + /* avoid ret being leaked if croak when calling magic below */ + EXTEND_MORTAL(1); + PL_tmps_stack[++PL_tmps_ix] = (SV *)ret; + SSize_t ret_at_tmps_ix = PL_tmps_ix; + + + HE *he; + while((he = hv_iternext(ohv))) { + if(tied) { + av_push_simple(ret, newSVsv(hv_iterkeysv(he))); + av_push_simple(ret, newSVsv(hv_iterval(ohv, he))); + } + else { + av_push_simple(ret, newSVhek(HeKEY_hek(he))); + av_push_simple(ret, HeVAL(he) ? newSVsv(HeVAL(he)) : &PL_sv_undef); + } + } + + /* disarm leak guard */ + if(LIKELY(PL_tmps_ix == ret_at_tmps_ix)) + PL_tmps_ix--; + else + PL_tmps_stack[ret_at_tmps_ix] = &PL_sv_undef; + + return ret; +} + +/* =for apidoc av_clear -Clears an array, making it empty. Does not free the memory the av uses to -store its list of scalars. If any destructors are triggered as a result, -the av itself may be freed when this function returns. +Frees 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 */ @@ -449,62 +633,73 @@ Perl equivalent: C<@myarray = ();>. void Perl_av_clear(pTHX_ AV *av) { - dVAR; - I32 extra; bool real; + SSize_t orig_ix = 0; PERL_ARGS_ASSERT_AV_CLEAR; assert(SvTYPE(av) == SVt_PVAV); #ifdef DEBUGGING if (SvREFCNT(av) == 0) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array"); + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array"); } #endif if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); /* Give any tie a chance to cleanup first */ if (SvRMAGICAL(av)) { - const MAGIC* const mg = SvMAGIC(av); - if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa) - PL_delaymagic |= DM_ARRAY_ISA; + const MAGIC* const mg = SvMAGIC(av); + if (PL_delaymagic && mg && mg->mg_type == PERL_MAGIC_isa) + PL_delaymagic |= DM_ARRAY_ISA; else - mg_clear(MUTABLE_SV(av)); + mg_clear(MUTABLE_SV(av)); } if (AvMAX(av) < 0) - return; - - if ((real = !!AvREAL(av))) { - SV** const ary = AvARRAY(av); - I32 index = AvFILLp(av) + 1; - ENTER; - SAVEFREESV(SvREFCNT_inc_simple_NN(av)); - while (index) { - SV * const sv = ary[--index]; - /* undef the slot before freeing the value, because a - * destructor might try to modify this array */ - ary[index] = &PL_sv_undef; - SvREFCNT_dec(sv); - } - } - extra = AvARRAY(av) - AvALLOC(av); - if (extra) { - AvMAX(av) += extra; - AvARRAY(av) = AvALLOC(av); + return; + + if ((real = cBOOL(AvREAL(av)))) { + SV** const ary = AvARRAY(av); + SSize_t index = AvFILLp(av) + 1; + + /* 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 + * destructor might try to modify this array */ + ary[index] = NULL; + SvREFCNT_dec(sv); + } } AvFILLp(av) = -1; - if (real) LEAVE; + av_remove_offset(av); + + 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, the av 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 */ @@ -513,20 +708,26 @@ void Perl_av_undef(pTHX_ AV *av) { bool real; + SSize_t orig_ix = PL_tmps_ix; /* silence bogus warning about possible uninitialized use */ PERL_ARGS_ASSERT_AV_UNDEF; assert(SvTYPE(av) == SVt_PVAV); /* Give any tie a chance to cleanup first */ if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) - av_fill(av, -1); - - if ((real = !!AvREAL(av))) { - I32 key = AvFILLp(av) + 1; - ENTER; - SAVEFREESV(SvREFCNT_inc_simple_NN(av)); - while (key) - SvREFCNT_dec(AvARRAY(av)[--key]); + av_fill(av, -1); + + real = cBOOL(AvREAL(av)); + if (real) { + SSize_t key = AvFILLp(av) + 1; + + /* 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]); } Safefree(AvALLOC(av)); @@ -535,7 +736,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); + } } /* @@ -554,17 +762,17 @@ Perl_av_create_and_push(pTHX_ AV **const avp, SV *const val) PERL_ARGS_ASSERT_AV_CREATE_AND_PUSH; if (!*avp) - *avp = newAV(); + *avp = newAV(); av_push(*avp, 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 */ @@ -572,19 +780,18 @@ Perl equivalent: C. void Perl_av_push(pTHX_ AV *av, SV *val) { - dVAR; MAGIC *mg; PERL_ARGS_ASSERT_AV_PUSH; assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + 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, - val); - return; + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1, + val); + return; } av_store(av,AvFILLp(av)+1,val); } @@ -592,8 +799,9 @@ Perl_av_push(pTHX_ AV *av, SV *val) /* =for apidoc av_pop -Pops an SV off the end of the array. Returns C<&PL_sv_undef> if the array -is empty. +Removes one SV from the end of the array, reducing its size by one and +returning the SV (transferring control of one reference count) to the +caller. Returns C<&PL_sv_undef> if the array is empty. Perl equivalent: C @@ -603,7 +811,6 @@ Perl equivalent: C SV * Perl_av_pop(pTHX_ AV *av) { - dVAR; SV *retval; MAGIC* mg; @@ -611,20 +818,20 @@ Perl_av_pop(pTHX_ AV *av) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + 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) - retval = newSVsv(retval); - return retval; + retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(POP), 0, 0); + if (retval) + retval = newSVsv(retval); + return retval; } if (AvFILL(av) < 0) - return &PL_sv_undef; + return &PL_sv_undef; retval = AvARRAY(av)[AvFILLp(av)]; - AvARRAY(av)[AvFILLp(av)--] = &PL_sv_undef; + AvARRAY(av)[AvFILLp(av)--] = NULL; if (SvSMAGICAL(av)) - mg_set(MUTABLE_SV(av)); - return retval; + mg_set(MUTABLE_SV(av)); + return retval ? retval : &PL_sv_undef; } /* @@ -644,7 +851,7 @@ Perl_av_create_and_unshift_one(pTHX_ AV **const avp, SV *const val) PERL_ARGS_ASSERT_AV_CREATE_AND_UNSHIFT_ONE; if (!*avp) - *avp = newAV(); + *avp = newAV(); av_unshift(*avp, 1); return av_store(*avp, 0, val); } @@ -653,73 +860,74 @@ 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: C - =cut */ void -Perl_av_unshift(pTHX_ AV *av, I32 num) +Perl_av_unshift(pTHX_ AV *av, SSize_t num) { - dVAR; - I32 i; + SSize_t i; MAGIC* mg; PERL_ARGS_ASSERT_AV_UNSHIFT; assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "UNSHIFT", - G_DISCARD | G_UNDEF_FILL, num); - return; + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT), + G_DISCARD | G_UNDEF_FILL, num); + return; } if (num <= 0) return; if (!AvREAL(av) && AvREIFY(av)) - av_reify(av); + av_reify(av); i = AvARRAY(av) - AvALLOC(av); if (i) { - if (i > num) - i = num; - num -= i; + if (i > num) + i = num; + num -= i; - AvMAX(av) += i; - AvFILLp(av) += i; - AvARRAY(av) = AvARRAY(av) - i; + AvMAX(av) += i; + AvFILLp(av) += i; + AvARRAY(av) = AvARRAY(av) - i; +#ifdef PERL_RC_STACK + Zero(AvARRAY(av), i, SV*); +#endif } if (num) { - SV **ary; - const I32 i = AvFILLp(av); - /* Create extra elements */ - const I32 slide = i > 0 ? i : 0; - num += slide; - av_extend(av, i + num); - AvFILLp(av) += num; - ary = AvARRAY(av); - Move(ary, ary + num, i + 1, SV*); - do { - ary[--num] = &PL_sv_undef; - } while (num); - /* Make extra elements into a buffer */ - AvMAX(av) -= slide; - AvFILLp(av) -= slide; - AvARRAY(av) = AvARRAY(av) + slide; + SV **ary; + const SSize_t i = AvFILLp(av); + /* Create extra elements */ + const SSize_t slide = i > 0 ? i : 0; + num += slide; + av_extend(av, i + num); + AvFILLp(av) += num; + ary = AvARRAY(av); + Move(ary, ary + num, i + 1, SV*); + do { + ary[--num] = NULL; + } while (num); + /* Make extra elements into a buffer */ + AvMAX(av) -= slide; + AvFILLp(av) -= slide; + AvARRAY(av) = AvARRAY(av) + slide; } } /* =for apidoc av_shift -Shifts an SV off the beginning of the -array. Returns C<&PL_sv_undef> if the -array is empty. +Removes one SV from the start of the array, reducing its size by one and +returning the SV (transferring control of one reference count) to the +caller. Returns C<&PL_sv_undef> if the array is empty. Perl equivalent: C @@ -729,7 +937,6 @@ Perl equivalent: C SV * Perl_av_shift(pTHX_ AV *av) { - dVAR; SV *retval; MAGIC* mg; @@ -737,132 +944,148 @@ Perl_av_shift(pTHX_ AV *av) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + 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) - retval = newSVsv(retval); - return retval; + retval = Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(SHIFT), 0, 0); + if (retval) + retval = newSVsv(retval); + return retval; } if (AvFILL(av) < 0) return &PL_sv_undef; retval = *AvARRAY(av); +#ifndef PERL_RC_STACK if (AvREAL(av)) - *AvARRAY(av) = &PL_sv_undef; + *AvARRAY(av) = NULL; +#endif AvARRAY(av) = AvARRAY(av) + 1; AvMAX(av)--; AvFILLp(av)--; if (SvSMAGICAL(av)) - mg_set(MUTABLE_SV(av)); - return retval; + mg_set(MUTABLE_SV(av)); + return retval ? retval : &PL_sv_undef; } /* +=for apidoc av_tindex +=for apidoc_item av_top_index + +These behave identically. +If the array C is empty, these return -1; otherwise they return the maximum +value of the indices of all the array elements which are currently defined in +C. + +They process 'get' magic. + +The Perl equivalent for these is C<$#av>. + +Use C> to get the number of elements in an array. + =for apidoc av_len -Returns the highest index in the array. The number of elements in the -array is C. Returns -1 if the array is empty. +Same as L. Note that, unlike what the name implies, it returns +the maximum index in the array. This is unlike L, which returns what +you would expect. -The Perl equivalent for this is C<$#myarray>. +B>>. =cut */ -I32 +SSize_t Perl_av_len(pTHX_ AV *av) { PERL_ARGS_ASSERT_AV_LEN; - assert(SvTYPE(av) == SVt_PVAV); - return AvFILL(av); + return av_top_index(av); } /* =for apidoc av_fill Set the highest index in the array to the given number, equivalent to -Perl's C<$#array = $fill;>. +Perl's S>. -The number of elements in the an array will be C after -av_fill() returns. If the array was previously shorter, then the -additional elements appended are set to C. If the array -was longer, then the excess elements are freed. C is +The number of elements in the array will be S> after +C returns. If the array was previously shorter, then the +additional elements appended are set to NULL. If the array +was longer, then the excess elements are freed. S> is the same as C. =cut */ void -Perl_av_fill(pTHX_ AV *av, I32 fill) +Perl_av_fill(pTHX_ AV *av, SSize_t fill) { - dVAR; MAGIC *mg; PERL_ARGS_ASSERT_AV_FILL; assert(SvTYPE(av) == SVt_PVAV); if (fill < 0) - fill = -1; + fill = -1; if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - SV *arg1 = sv_newmortal(); - sv_setiv(arg1, (IV)(fill + 1)); - Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, "STORESIZE", G_DISCARD, - 1, arg1); - return; + SV *arg1 = sv_newmortal(); + sv_setiv(arg1, (IV)(fill + 1)); + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(STORESIZE), G_DISCARD, + 1, arg1); + return; } if (fill <= AvMAX(av)) { - I32 key = AvFILLp(av); - SV** const ary = AvARRAY(av); - - if (AvREAL(av)) { - while (key > fill) { - SvREFCNT_dec(ary[key]); - ary[key--] = &PL_sv_undef; - } - } - else { - while (key < fill) - ary[++key] = &PL_sv_undef; - } - - AvFILLp(av) = fill; - if (SvSMAGICAL(av)) - mg_set(MUTABLE_SV(av)); + SSize_t key = AvFILLp(av); + SV** const ary = AvARRAY(av); + + if (AvREAL(av)) { + while (key > fill) { + SvREFCNT_dec(ary[key]); + ary[key--] = NULL; + } + } + else { + while (key < fill) + ary[++key] = NULL; + } + + AvFILLp(av) = fill; + if (SvSMAGICAL(av)) + mg_set(MUTABLE_SV(av)); } else - (void)av_store(av,fill,&PL_sv_undef); + (void)av_store(av,fill,NULL); } /* =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: C for the -non-C version and a void-context C 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 */ SV * -Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) +Perl_av_delete(pTHX_ AV *av, SSize_t key, I32 flags) { - dVAR; SV *sv; PERL_ARGS_ASSERT_AV_DELETE; assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if (SvRMAGICAL(av)) { const MAGIC * const tied_magic - = mg_find((const SV *)av, PERL_MAGIC_tied); + = mg_find((const SV *)av, PERL_MAGIC_tied); if ((tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata))) { SV **svp; if (key < 0) { - if (!S_adjust_index(aTHX_ av, tied_magic, &key)) - return NULL; + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) + return NULL; } svp = av_fetch(av, key, TRUE); if (svp) { @@ -872,40 +1095,40 @@ Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) sv_unmagic(sv, PERL_MAGIC_tiedelem); /* No longer an element */ return sv; } - return NULL; + return NULL; } } } if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) - return NULL; + key += AvFILL(av) + 1; + if (key < 0) + return NULL; } if (key > AvFILLp(av)) - return NULL; + return NULL; else { - if (!AvREAL(av) && AvREIFY(av)) - av_reify(av); - sv = AvARRAY(av)[key]; - if (key == AvFILLp(av)) { - AvARRAY(av)[key] = &PL_sv_undef; - do { - AvFILLp(av)--; - } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef); - } - else - AvARRAY(av)[key] = &PL_sv_undef; - if (SvSMAGICAL(av)) - mg_set(MUTABLE_SV(av)); + if (!AvREAL(av) && AvREIFY(av)) + av_reify(av); + sv = AvARRAY(av)[key]; + AvARRAY(av)[key] = NULL; + if (key == AvFILLp(av)) { + do { + AvFILLp(av)--; + } while (--key >= 0 && !AvARRAY(av)[key]); + } + if (SvSMAGICAL(av)) + mg_set(MUTABLE_SV(av)); } - if (flags & G_DISCARD) { - SvREFCNT_dec(sv); - sv = NULL; + if(sv != NULL) { + if (flags & G_DISCARD) { + SvREFCNT_dec_NN(sv); + return NULL; + } + else if (AvREAL(av)) + sv_2mortal(sv); } - else if (AvREAL(av)) - sv = sv_2mortal(sv); return sv; } @@ -915,29 +1138,28 @@ Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) Returns true if the element indexed by C has been initialized. This relies on the fact that uninitialized array elements are set to -C<&PL_sv_undef>. +C. Perl equivalent: C. =cut */ bool -Perl_av_exists(pTHX_ AV *av, I32 key) +Perl_av_exists(pTHX_ AV *av, SSize_t key) { - dVAR; PERL_ARGS_ASSERT_AV_EXISTS; assert(SvTYPE(av) == SVt_PVAV); if (SvRMAGICAL(av)) { const MAGIC * const tied_magic - = mg_find((const SV *)av, PERL_MAGIC_tied); + = mg_find((const SV *)av, PERL_MAGIC_tied); const MAGIC * const regdata_magic = mg_find((const SV *)av, PERL_MAGIC_regdata); if (tied_magic || regdata_magic) { MAGIC *mg; /* Handle negative array indices 20020222 MJD */ if (key < 0) { - if (!S_adjust_index(aTHX_ av, tied_magic, &key)) + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) return FALSE; } @@ -947,39 +1169,40 @@ Perl_av_exists(pTHX_ AV *av, I32 key) else return FALSE; } - { - 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); - } - } - } + { + 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); + } + } + } } } if (key < 0) { - key += AvFILL(av) + 1; - if (key < 0) - return FALSE; + key += AvFILL(av) + 1; + if (key < 0) + return FALSE; } - if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef - && AvARRAY(av)[key]) + if (key <= AvFILLp(av) && AvARRAY(av)[key]) { - return TRUE; + if (SvSMAGICAL(AvARRAY(av)[key]) + && mg_find(AvARRAY(av)[key], PERL_MAGIC_nonelem)) + return FALSE; + return TRUE; } else - return FALSE; + return FALSE; } static MAGIC * S_get_aux_mg(pTHX_ AV *av) { - dVAR; MAGIC *mg; PERL_ARGS_ASSERT_GET_AUX_MG; @@ -988,11 +1211,11 @@ S_get_aux_mg(pTHX_ AV *av) { mg = mg_find((const SV *)av, PERL_MAGIC_arylen_p); if (!mg) { - mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p, - &PL_vtbl_arylen_p, 0, 0); - assert(mg); - /* sv_magicext won't set this for us because we pass in a NULL obj */ - mg->mg_flags |= MGf_REFCOUNTED; + mg = sv_magicext(MUTABLE_SV(av), 0, PERL_MAGIC_arylen_p, + &PL_vtbl_arylen_p, 0, 0); + assert(mg); + /* sv_magicext won't set this for us because we pass in a NULL obj */ + mg->mg_flags |= MGf_REFCOUNTED; } return mg; } @@ -1014,25 +1237,29 @@ 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_type(SVt_NULL); + 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; } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: nil - * End: - * * ex: set ts=8 sts=4 sw=4 et: */