X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/ad64d0ecd555e97c5a216efca1ec5a96b7fd0b34..055663bc9d17f8e2ef5ef0a4233d89dd4a69d2a2:/av.c diff --git a/av.c b/av.c index 7bd19ee..67815fc 100644 --- a/av.c +++ b/av.c @@ -9,14 +9,12 @@ */ /* - * "...for the Entwives desired order, and plenty, and peace (by which they - * meant that things should remain where they had set them)." --Treebeard + * '...for the Entwives desired order, and plenty, and peace (by which they + * meant that things should remain where they had set them).' --Treebeard + * + * [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" @@ -24,8 +22,7 @@ void Perl_av_reify(pTHX_ AV *av) { - dVAR; - I32 key; + SSize_t key; PERL_ARGS_ASSERT_AV_REIFY; assert(SvTYPE(av) == SVt_PVAV); @@ -33,21 +30,20 @@ Perl_av_reify(pTHX_ AV *av) if (AvREAL(av)) return; #ifdef DEBUGGING - if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied) && ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "av_reify called on tied array"); + if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) + 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); + SvREFCNT_inc_simple_void(sv); } key = AvARRAY(av) - AvALLOC(av); while (key) - AvALLOC(av)[--key] = &PL_sv_undef; + AvALLOC(av)[--key] = NULL; AvREIFY_off(av); AvREAL_on(av); } @@ -55,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; @@ -72,124 +72,135 @@ Perl_av_extend(pTHX_ AV *av, I32 key) mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied); if (mg) { - dSP; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP,2); - PUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); - mPUSHi(key + 1); - PUTBACK; - call_method("EXTEND", G_SCALAR|G_DISCARD); - POPSTACK; - FREETMPS; - LEAVE; + 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; } - if (key > AvMAX(av)) { - 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 (AvREAL(av)) { - while (tmp) - ary[--tmp] = &PL_sv_undef; - } - if (key > AvMAX(av) - 10) { - newmax = key + AvMAX(av); - 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 + av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av)); +} - if (AvALLOC(av)) { -#if !defined(STRANGE_MALLOC) && !defined(MYMALLOC) - MEM_SIZE bytes; - IV itmp; -#endif +/* 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, SSize_t key, SSize_t *maxp, SV ***allocp, + SV ***arrayp) +{ + 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) { + SSize_t ary_offset = *maxp + 1; + SSize_t to_null = 0; + SSize_t newmax = 0; + + if (av && *allocp != *arrayp) { /* a shifted SV* array exists */ + to_null = *arrayp - *allocp; + *maxp += to_null; + + Move(*arrayp, *allocp, AvFILLp(av)+1, SV*); + + if (key > *maxp - 10) { + newmax = key + *maxp; + 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*)AvALLOC(av)) / - sizeof(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 + AvMAX(av) / 5; - resize: - MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend); -#if defined(STRANGE_MALLOC) || defined(MYMALLOC) - Renew(AvALLOC(av),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(SV*); -#define MALLOC_OVERHEAD 16 - itmp = MALLOC_OVERHEAD; - while ((MEM_SIZE)(itmp - MALLOC_OVERHEAD) < bytes) - itmp += itmp; - itmp -= MALLOC_OVERHEAD; - itmp /= sizeof(SV*); - assert(itmp > newmax); - newmax = itmp - 1; - assert(newmax >= AvMAX(av)); - Newx(ary, newmax+1, SV*); - Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*); - if (AvMAX(av) > 64) - offer_nice_chunk(AvALLOC(av), (AvMAX(av)+1) * sizeof(SV*)); - else - Safefree(AvALLOC(av)); - AvALLOC(av) = ary; + Renew(*allocp,newmax+1, SV*); #endif #ifdef Perl_safesysmalloc_size - resized: + resized: #endif - ary = AvALLOC(av) + AvMAX(av) + 1; - tmp = newmax - AvMAX(av); - 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_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; - tmp = newmax; - AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */ - } - if (AvREAL(av)) { - while (tmp) - ary[--tmp] = &PL_sv_undef; - } - - AvARRAY(av) = AvALLOC(av); - AvMAX(av) = newmax; - } + to_null += newmax - *maxp; + *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 < 3 ? 3 : 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. */ + ary_offset = 0; + to_null = *maxp+1; + goto zero; + } + + if (av && AvREAL(av)) { + zero: + Zero(*allocp + ary_offset,to_null,SV*); + } + + *arrayp = *allocp; } } @@ -197,80 +208,91 @@ Perl_av_extend(pTHX_ AV *av, I32 key) =for apidoc av_fetch Returns the SV at the specified index in the array. The C is the -index. If C is set then the fetch will be part of a store. Check -that the return value is non-null before dereferencing it to a C. +index. If lval 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. See L for more information on how to use this function on tied arrays. +The rough perl equivalent is C<$myarray[$key]>. + =cut */ +static bool +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 && isGV(*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, 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); 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(); 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)); } } - 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)) { - if (!lval) + /* 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; - return av_store(av,key,newSV(0)); + goto emptyness; } - if (AvARRAY(av)[key] == &PL_sv_undef) { - emptyness: - if (lval) - return av_store(av,key,newSV(0)); - return NULL; - } - else 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]) { + emptyness: + return lval ? av_store(av,key,newSV(0)) : NULL; } + return &AvARRAY(av)[key]; } @@ -278,12 +300,17 @@ Perl_av_fetch(pTHX_ register 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 to get the original C. Note -that the caller is responsible for suitably incrementing the reference +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. See L for more information on how to use this function on tied arrays. @@ -292,9 +319,8 @@ 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, SSize_t key, SV *val) { - dVAR; SV** ary; PERL_ARGS_ASSERT_AV_STORE; @@ -304,29 +330,14 @@ Perl_av_store(pTHX_ register 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) { - /* 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) { + if (val) { mg_copy(MUTABLE_SV(av), val, 0, key); } return NULL; @@ -341,7 +352,7 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) } if (SvREADONLY(av) && key >= AvFILL(av)) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak_no_modify(); if (!AvREAL(av) && AvREIFY(av)) av_reify(av); @@ -353,7 +364,7 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) 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; + ary[++AvFILLp(av)] = NULL; } while (AvFILLp(av) < key); } AvFILLp(av) = key; @@ -362,13 +373,19 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) SvREFCNT_dec(ary[key]); ary[key] = val; if (SvSMAGICAL(av)) { - const MAGIC* const mg = SvMAGIC(av); - if (val != &PL_sv_undef) { + const MAGIC *mg = SvMAGIC(av); + bool set = TRUE; + 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 (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) - PL_delaymagic |= DM_ARRAY; - else + if (set) mg_set(MUTABLE_SV(av)); } return &ary[key]; @@ -378,33 +395,55 @@ Perl_av_store(pTHX_ register 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 +into the array, so they may be freed after the call to C. The new AV will have a reference count of 1. +Perl equivalent: C + =cut */ AV * -Perl_av_make(pTHX_ register I32 size, register SV **strp) +Perl_av_make(pTHX_ SSize_t size, SV **strp) { - register 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. */ - register SV** ary; - register I32 i; + SV** ary; + SSize_t i; + SSize_t orig_ix; + Newx(ary,size,SV*); AvALLOC(av) = ary; AvARRAY(av) = ary; - AvFILLp(av) = AvMAX(av) = size - 1; + 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(0); - sv_setsv(ary[i], *strp); + 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; } @@ -412,35 +451,43 @@ Perl_av_make(pTHX_ register I32 size, register SV **strp) /* =for apidoc av_clear -Clears an array, making it empty. Does not free the memory used by the -array itself. +Frees all the elements of an array, leaving it empty. +The XS equivalent of C<@array = ()>. See also L. + +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 */ void -Perl_av_clear(pTHX_ register AV *av) +Perl_av_clear(pTHX_ AV *av) { - dVAR; - I32 extra; + SSize_t extra; + bool real; + SSize_t orig_ix = 0; PERL_ARGS_ASSERT_AV_CLEAR; assert(SvTYPE(av) == SVt_PVAV); #ifdef DEBUGGING - if (SvREFCNT(av) == 0 && ckWARN_d(WARN_DEBUGGING)) { - Perl_warner(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array"); + if (SvREFCNT(av) == 0) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), "Attempt to clear deleted array"); } #endif if (SvREADONLY(av)) - Perl_croak(aTHX_ PL_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; + PL_delaymagic |= DM_ARRAY_ISA; else mg_clear(MUTABLE_SV(av)); } @@ -448,14 +495,20 @@ Perl_av_clear(pTHX_ register AV *av) if (AvMAX(av) < 0) return; - if (AvREAL(av)) { + if ((real = cBOOL(AvREAL(av)))) { SV** const ary = AvARRAY(av); - I32 index = AvFILLp(av) + 1; + 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] = &PL_sv_undef; + ary[index] = NULL; SvREFCNT_dec(sv); } } @@ -465,20 +518,36 @@ Perl_av_clear(pTHX_ register AV *av) AvARRAY(av) = AvALLOC(av); } AvFILLp(av) = -1; - + 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 array itself. +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 */ void -Perl_av_undef(pTHX_ register AV *av) +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); @@ -486,8 +555,15 @@ Perl_av_undef(pTHX_ register AV *av) if (SvTIED_mg((const SV *)av, PERL_MAGIC_tied)) av_fill(av, -1); - if (AvREAL(av)) { - register I32 key = AvFILLp(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]); } @@ -498,6 +574,14 @@ Perl_av_undef(pTHX_ register AV *av) AvMAX(av) = AvFILLp(av) = -1; if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(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); + } } /* @@ -523,36 +607,28 @@ 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. +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. =cut */ void -Perl_av_push(pTHX_ register AV *av, SV *val) +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(aTHX_ PL_no_modify); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - dSP; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP,2); - PUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); - PUSHs(val); - PUTBACK; - ENTER; - call_method("PUSH", G_SCALAR|G_DISCARD); - LEAVE; - POPSTACK; + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(PUSH), G_DISCARD, 1, + val); return; } av_store(av,AvFILLp(av)+1,val); @@ -561,16 +637,18 @@ Perl_av_push(pTHX_ register 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 =cut */ SV * -Perl_av_pop(pTHX_ register AV *av) +Perl_av_pop(pTHX_ AV *av) { - dVAR; SV *retval; MAGIC* mg; @@ -578,30 +656,20 @@ Perl_av_pop(pTHX_ register AV *av) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - dSP; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); - PUTBACK; - ENTER; - if (call_method("POP", G_SCALAR)) { - retval = newSVsv(*PL_stack_sp--); - } else { - retval = &PL_sv_undef; - } - LEAVE; - POPSTACK; + 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; 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; + return retval ? retval : &PL_sv_undef; } /* @@ -630,39 +698,28 @@ 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> =cut */ void -Perl_av_unshift(pTHX_ register AV *av, register I32 num) +Perl_av_unshift(pTHX_ AV *av, SSize_t num) { - dVAR; - register I32 i; + SSize_t i; MAGIC* mg; PERL_ARGS_ASSERT_AV_UNSHIFT; assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - dSP; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP,1+num); - PUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); - while (num-- > 0) { - PUSHs(&PL_sv_undef); - } - PUTBACK; - ENTER; - call_method("UNSHIFT", G_SCALAR|G_DISCARD); - LEAVE; - POPSTACK; + Perl_magic_methcall(aTHX_ MUTABLE_SV(av), mg, SV_CONST(UNSHIFT), + G_DISCARD | G_UNDEF_FILL, num); return; } @@ -681,17 +738,17 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num) AvARRAY(av) = AvARRAY(av) - i; } if (num) { - register SV **ary; - const I32 i = AvFILLp(av); + SV **ary; + const SSize_t i = AvFILLp(av); /* Create extra elements */ - const I32 slide = i > 0 ? i : 0; + 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] = &PL_sv_undef; + ary[--num] = NULL; } while (num); /* Make extra elements into a buffer */ AvMAX(av) -= slide; @@ -703,16 +760,18 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num) /* =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 =cut */ SV * -Perl_av_shift(pTHX_ register AV *av) +Perl_av_shift(pTHX_ AV *av) { - dVAR; SV *retval; MAGIC* mg; @@ -720,72 +779,77 @@ Perl_av_shift(pTHX_ register AV *av) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak_no_modify(); if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - dSP; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - XPUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); - PUTBACK; - ENTER; - if (call_method("SHIFT", G_SCALAR)) { - retval = newSVsv(*PL_stack_sp--); - } else { - retval = &PL_sv_undef; - } - LEAVE; - POPSTACK; + 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); if (AvREAL(av)) - *AvARRAY(av) = &PL_sv_undef; + *AvARRAY(av) = NULL; AvARRAY(av) = AvARRAY(av) + 1; AvMAX(av)--; AvFILLp(av)--; if (SvSMAGICAL(av)) mg_set(MUTABLE_SV(av)); - return retval; + 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. + +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_ register AV *av, I32 fill) +Perl_av_fill(pTHX_ AV *av, SSize_t fill) { - dVAR; MAGIC *mg; PERL_ARGS_ASSERT_AV_FILL; @@ -794,34 +858,25 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill) if (fill < 0) fill = -1; if ((mg = SvTIED_mg((const SV *)av, PERL_MAGIC_tied))) { - dSP; - ENTER; - SAVETMPS; - PUSHSTACKi(PERLSI_MAGIC); - PUSHMARK(SP); - EXTEND(SP,2); - PUSHs(SvTIED_obj(MUTABLE_SV(av), mg)); - mPUSHi(fill + 1); - PUTBACK; - call_method("STORESIZE", G_SCALAR|G_DISCARD); - POPSTACK; - FREETMPS; - LEAVE; + 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); + SSize_t key = AvFILLp(av); SV** const ary = AvARRAY(av); if (AvREAL(av)) { while (key > fill) { SvREFCNT_dec(ary[key]); - ary[key--] = &PL_sv_undef; + ary[key--] = NULL; } } else { while (key < fill) - ary[++key] = &PL_sv_undef; + ary[++key] = NULL; } AvFILLp(av) = fill; @@ -829,52 +884,41 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill) 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. Returns the -deleted element. If C equals C, the element is freed -and null is returned. +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(aTHX_ PL_no_modify); + 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) { @@ -901,23 +945,23 @@ Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) if (!AvREAL(av) && AvREIFY(av)) av_reify(av); sv = AvARRAY(av)[key]; + AvARRAY(av)[key] = NULL; if (key == AvFILLp(av)) { - AvARRAY(av)[key] = &PL_sv_undef; do { AvFILLp(av)--; - } while (--key >= 0 && AvARRAY(av)[key] == &PL_sv_undef); + } while (--key >= 0 && !AvARRAY(av)[key]); } - else - AvARRAY(av)[key] = &PL_sv_undef; 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; } @@ -927,49 +971,49 @@ 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); - if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) { - SV * const sv = sv_newmortal(); + 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) { - 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; - } } - mg_copy(MUTABLE_SV(av), sv, 0, key); - mg = mg_find(sv, PERL_MAGIC_tiedelem); - if (mg) { - magic_existspack(sv, mg); - return (bool)SvTRUE(sv); + if(key >= 0 && regdata_magic) { + if (key <= AvFILL(av)) + return TRUE; + 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); + } + } + } } } @@ -979,9 +1023,11 @@ Perl_av_exists(pTHX_ AV *av, I32 key) return FALSE; } - if (key <= AvFILLp(av) && AvARRAY(av)[key] != &PL_sv_undef - && AvARRAY(av)[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 @@ -990,7 +1036,6 @@ Perl_av_exists(pTHX_ AV *av, I32 key) static MAGIC * S_get_aux_mg(pTHX_ AV *av) { - dVAR; MAGIC *mg; PERL_ARGS_ASSERT_GET_AUX_MG; @@ -1025,25 +1070,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(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; } /* - * Local variables: - * c-indentation-style: bsd - * c-basic-offset: 4 - * indent-tabs-mode: t - * End: - * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */