X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/1a3362a5d4e9f2d3548e2937ecf5a9a8a1ac7898..8936b48a49448f4e7b8a0b9849a085b48ac700ff:/av.c diff --git a/av.c b/av.c index 6e08454..b251822 100644 --- a/av.c +++ b/av.c @@ -80,23 +80,35 @@ Perl_av_extend(pTHX_ AV *av, I32 key) arg1); return; } - if (key > AvMAX(av)) { + av_extend_guts(av,key,&AvMAX(av),&AvALLOC(av),&AvARRAY(av)); +} + +/* The guts of av_extend. *Not* for general use! */ +void +Perl_av_extend_guts(pTHX_ AV *av, I32 key, SSize_t *maxp, SV ***allocp, + SV ***arrayp) +{ + dVAR; + + PERL_ARGS_ASSERT_AV_EXTEND_GUTS; + + if (key > *maxp) { SV** ary; I32 tmp; I32 newmax; - if (AvALLOC(av) != AvARRAY(av)) { - ary = AvALLOC(av) + AvFILLp(av) + 1; - tmp = AvARRAY(av) - AvALLOC(av); - Move(AvARRAY(av), AvALLOC(av), AvFILLp(av)+1, SV*); - AvMAX(av) += tmp; - AvARRAY(av) = AvALLOC(av); + if (av && *allocp != *arrayp) { + ary = *allocp + AvFILLp(av) + 1; + tmp = *arrayp - *allocp; + Move(*arrayp, *allocp, AvFILLp(av)+1, SV*); + *maxp += tmp; + *arrayp = *allocp; if (AvREAL(av)) { while (tmp) ary[--tmp] = &PL_sv_undef; } - if (key > AvMAX(av) - 10) { - newmax = key + AvMAX(av); + if (key > *maxp - 10) { + newmax = key + *maxp; goto resize; } } @@ -106,7 +118,7 @@ Perl_av_extend(pTHX_ AV *av, I32 key) "Out of memory during array extend"; /* Duplicated in pp_hot.c */ #endif - if (AvALLOC(av)) { + if (*allocp) { #if !defined(STRANGE_MALLOC) && !defined(MYMALLOC) MEM_SIZE bytes; IV itmp; @@ -126,17 +138,17 @@ Perl_av_extend(pTHX_ AV *av, I32 key) memory that might never be read. So, I feel, better to keep the current lazy system of only writing to it if our caller has a need for more space. NWC */ - newmax = Perl_safesysmalloc_size((void*)AvALLOC(av)) / + newmax = Perl_safesysmalloc_size((void*)*allocp) / sizeof(const SV *) - 1; if (key <= newmax) goto resized; #endif - newmax = key + AvMAX(av) / 5; + newmax = key + *maxp / 5; resize: MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend); #if defined(STRANGE_MALLOC) || defined(MYMALLOC) - Renew(AvALLOC(av),newmax+1, SV*); + Renew(*allocp,newmax+1, SV*); #else bytes = (newmax + 1) * sizeof(const SV *); #define MALLOC_OVERHEAD 16 @@ -147,42 +159,38 @@ Perl_av_extend(pTHX_ AV *av, I32 key) itmp /= sizeof(const SV *); assert(itmp > newmax); newmax = itmp - 1; - assert(newmax >= AvMAX(av)); + assert(newmax >= *maxp); Newx(ary, newmax+1, SV*); - Copy(AvALLOC(av), ary, AvMAX(av)+1, SV*); - if (AvMAX(av) > 64) - offer_nice_chunk(AvALLOC(av), - (AvMAX(av)+1) * sizeof(const SV *)); - else - Safefree(AvALLOC(av)); - AvALLOC(av) = ary; + Copy(*allocp, ary, *maxp+1, SV*); + Safefree(*allocp); + *allocp = ary; #endif #ifdef Perl_safesysmalloc_size resized: #endif - ary = AvALLOC(av) + AvMAX(av) + 1; - tmp = newmax - AvMAX(av); + ary = *allocp + *maxp + 1; + tmp = newmax - *maxp; if (av == PL_curstack) { /* Oops, grew stack (via av_store()?) */ - PL_stack_sp = AvALLOC(av) + (PL_stack_sp - PL_stack_base); - PL_stack_base = AvALLOC(av); + PL_stack_sp = *allocp + (PL_stack_sp - PL_stack_base); + PL_stack_base = *allocp; PL_stack_max = PL_stack_base + newmax; } } else { newmax = key < 3 ? 3 : key; MEM_WRAP_CHECK_1(newmax+1, SV*, oom_array_extend); - Newx(AvALLOC(av), newmax+1, SV*); - ary = AvALLOC(av) + 1; + Newx(*allocp, newmax+1, SV*); + ary = *allocp + 1; tmp = newmax; - AvALLOC(av)[0] = &PL_sv_undef; /* For the stacks */ + *allocp[0] = &PL_sv_undef; /* For the stacks */ } - if (AvREAL(av)) { + if (av && AvREAL(av)) { while (tmp) ary[--tmp] = &PL_sv_undef; } - AvARRAY(av) = AvALLOC(av); - AvMAX(av) = newmax; + *arrayp = *allocp; + *maxp = newmax; } } } @@ -199,11 +207,37 @@ See L for more information on how to use this function on tied arrays. The rough perl equivalent is C<$myarray[$idx]>. + =cut */ +static bool +S_adjust_index(pTHX_ AV *av, const MAGIC *mg, I32 *keyp) +{ + bool adjust_index = 1; + if (mg) { + /* Handle negative array indices 20020222 MJD */ + SV * const ref = SvTIED_obj(MUTABLE_SV(av), mg); + SvGETMAGIC(ref); + if (SvROK(ref) && SvOBJECT(SvRV(ref))) { + SV * const * const negative_indices_glob = + hv_fetchs(SvSTASH(SvRV(ref)), NEGATIVE_INDICES_VAR, 0); + + if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob))) + adjust_index = 0; + } + } + + if (adjust_index) { + *keyp += AvFILL(av) + 1; + if (*keyp < 0) + return FALSE; + } + return TRUE; +} + SV** -Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval) +Perl_av_fetch(pTHX_ AV *av, I32 key, I32 lval) { dVAR; @@ -216,23 +250,8 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval) if (tied_magic || mg_find((const SV *)av, PERL_MAGIC_regdata)) { SV *sv; if (key < 0) { - I32 adjust_index = 1; - if (tied_magic) { - /* Handle negative array indices 20020222 MJD */ - SV * const * const negative_indices_glob = - hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), - tied_magic))), - NEGATIVE_INDICES_VAR, 16, 0); - - if (negative_indices_glob && SvTRUE(GvSV(*negative_indices_glob))) - adjust_index = 0; - } - - if (adjust_index) { - key += AvFILL(av) + 1; - if (key < 0) + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) return NULL; - } } sv = sv_newmortal(); @@ -252,18 +271,12 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval) return NULL; } - if (key > AvFILLp(av)) { - if (!lval) - return NULL; - return av_store(av,key,newSV(0)); + if (key > AvFILLp(av) || AvARRAY(av)[key] == &PL_sv_undef) { + emptyness: + return lval ? av_store(av,key,newSV(0)) : NULL; } - if (AvARRAY(av)[key] == &PL_sv_undef) { - emptyness: - if (lval) - return av_store(av,key,newSV(0)); - return NULL; - } - else if (AvREIFY(av) + + 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 */ @@ -278,11 +291,16 @@ Perl_av_fetch(pTHX_ register AV *av, I32 key, I32 lval) 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 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. +Approximate Perl equivalent: C<$myarray[$key] = $val;>. + See L for more information on how to use this function on tied arrays. @@ -290,7 +308,7 @@ more information on how to use this function on tied arrays. */ SV** -Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) +Perl_av_store(pTHX_ AV *av, I32 key, SV *val) { dVAR; SV** ary; @@ -308,21 +326,9 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) if (SvRMAGICAL(av)) { const MAGIC * const tied_magic = mg_find((const SV *)av, PERL_MAGIC_tied); if (tied_magic) { - /* Handle negative array indices 20020222 MJD */ if (key < 0) { - bool adjust_index = 1; - SV * const * const negative_indices_glob = - hv_fetch(SvSTASH(SvRV(SvTIED_obj(MUTABLE_SV(av), - tied_magic))), - NEGATIVE_INDICES_VAR, 16, 0); - if (negative_indices_glob - && SvTRUE(GvSV(*negative_indices_glob))) - adjust_index = 0; - if (adjust_index) { - key += AvFILL(av) + 1; - if (key < 0) + if (!S_adjust_index(aTHX_ av, tied_magic, &key)) return 0; - } } if (val != &PL_sv_undef) { mg_copy(MUTABLE_SV(av), val, 0, key); @@ -339,7 +345,7 @@ Perl_av_store(pTHX_ register AV *av, I32 key, SV *val) } if (SvREADONLY(av) && key >= AvFILL(av)) - Perl_croak(aTHX_ "%s", PL_no_modify); + Perl_croak_no_modify(); if (!AvREAL(av) && AvREIFY(av)) av_reify(av); @@ -360,13 +366,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 != &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 (PL_delaymagic && mg->mg_type == PERL_MAGIC_isa) - PL_delaymagic |= DM_ARRAY; - else + if (set) mg_set(MUTABLE_SV(av)); } return &ary[key]; @@ -379,24 +391,29 @@ 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. +Perl equivalent: C + =cut */ AV * -Perl_av_make(pTHX_ register I32 size, register SV **strp) +Perl_av_make(pTHX_ I32 size, SV **strp) { - register AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV)); + AV * const av = MUTABLE_AV(newSV_type(SVt_PVAV)); /* 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; + I32 i; Newx(ary,size,SV*); AvALLOC(av) = ary; AvARRAY(av) = ary; - AvFILLp(av) = AvMAX(av) = size - 1; + AvMAX(av) = size - 1; + AvFILLp(av) = -1; + ENTER; + SAVEFREESV(av); for (i = 0; i < size; i++) { assert (*strp); @@ -404,11 +421,15 @@ Perl_av_make(pTHX_ register I32 size, register SV **strp) have multiple references to the same temp scalar (e.g. from a list slice) */ + SvGETMAGIC(*strp); /* before newSV, in case it dies */ + AvFILLp(av)++; ary[i] = newSV(0); sv_setsv_flags(ary[i], *strp, - SV_GMAGIC|SV_DO_COW_SVSETSV|SV_NOSTEAL); + SV_DO_COW_SVSETSV|SV_NOSTEAL); strp++; } + SvREFCNT_inc_simple_void_NN(av); + LEAVE; } return av; } @@ -416,17 +437,21 @@ 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. Perl equivalent: C<@myarray = ();>. +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. + +Perl equivalent: C<@myarray = ();>. =cut */ void -Perl_av_clear(pTHX_ register AV *av) +Perl_av_clear(pTHX_ AV *av) { dVAR; I32 extra; + bool real; PERL_ARGS_ASSERT_AV_CLEAR; assert(SvTYPE(av) == SVt_PVAV); @@ -438,13 +463,13 @@ Perl_av_clear(pTHX_ register AV *av) #endif if (SvREADONLY(av)) - Perl_croak(aTHX_ "%s", 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)); } @@ -452,9 +477,11 @@ Perl_av_clear(pTHX_ register AV *av) if (AvMAX(av) < 0) return; - if (AvREAL(av)) { + 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 @@ -469,20 +496,24 @@ Perl_av_clear(pTHX_ register AV *av) AvARRAY(av) = AvALLOC(av); } AvFILLp(av) = -1; - + if (real) LEAVE; } /* =for apidoc av_undef -Undefines the array. Frees the memory used by the array itself. +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. =cut */ void -Perl_av_undef(pTHX_ register AV *av) +Perl_av_undef(pTHX_ AV *av) { + bool real; + PERL_ARGS_ASSERT_AV_UNDEF; assert(SvTYPE(av) == SVt_PVAV); @@ -490,8 +521,10 @@ 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; + if ((real = !!AvREAL(av))) { + I32 key = AvFILLp(av) + 1; + ENTER; + SAVEFREESV(SvREFCNT_inc_simple_NN(av)); while (key) SvREFCNT_dec(AvARRAY(av)[--key]); } @@ -502,6 +535,7 @@ Perl_av_undef(pTHX_ register AV *av) AvMAX(av) = AvFILLp(av) = -1; if(SvRMAGICAL(av)) mg_clear(MUTABLE_SV(av)); + if(real) LEAVE; } /* @@ -528,14 +562,15 @@ 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. Like C, this takes ownership of one -reference count. +to accommodate the addition. This takes ownership of one reference count. + +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; @@ -544,7 +579,7 @@ Perl_av_push(pTHX_ register AV *av, SV *val) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak(aTHX_ "%s", PL_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, @@ -560,11 +595,13 @@ Perl_av_push(pTHX_ register AV *av, SV *val) Pops an SV off the end of the array. 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; @@ -574,7 +611,7 @@ Perl_av_pop(pTHX_ register AV *av) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak(aTHX_ "%s", PL_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) @@ -619,21 +656,23 @@ 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. +Perl equivalent: C + =cut */ void -Perl_av_unshift(pTHX_ register AV *av, register I32 num) +Perl_av_unshift(pTHX_ AV *av, I32 num) { dVAR; - register I32 i; + I32 i; MAGIC* mg; PERL_ARGS_ASSERT_AV_UNSHIFT; assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak(aTHX_ "%s", PL_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", @@ -656,7 +695,7 @@ Perl_av_unshift(pTHX_ register AV *av, register I32 num) AvARRAY(av) = AvARRAY(av) - i; } if (num) { - register SV **ary; + SV **ary; const I32 i = AvFILLp(av); /* Create extra elements */ const I32 slide = i > 0 ? i : 0; @@ -678,14 +717,17 @@ 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 +Shifts an SV off the beginning of the +array. 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; @@ -695,7 +737,7 @@ Perl_av_shift(pTHX_ register AV *av) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak(aTHX_ "%s", PL_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) @@ -721,6 +763,8 @@ Perl_av_shift(pTHX_ register AV *av) Returns the highest index in the array. The number of elements in the array is C. Returns -1 if the array is empty. +The Perl equivalent for this is C<$#myarray>. + =cut */ @@ -748,7 +792,7 @@ the same as C. =cut */ void -Perl_av_fill(pTHX_ register AV *av, I32 fill) +Perl_av_fill(pTHX_ AV *av, I32 fill) { dVAR; MAGIC *mg; @@ -791,11 +835,11 @@ Perl_av_fill(pTHX_ register AV *av, I32 fill) /* =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. 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. Perl equivalent: C for the +non-C version and a void-context C for the +C version. =cut */ @@ -809,30 +853,16 @@ Perl_av_delete(pTHX_ AV *av, I32 key, I32 flags) assert(SvTYPE(av) == SVt_PVAV); if (SvREADONLY(av)) - Perl_croak(aTHX_ "%s", 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,35 +931,34 @@ Perl_av_exists(pTHX_ AV *av, I32 key) 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 cBOOL(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); + } + } + } } } @@ -1002,8 +1031,8 @@ Perl_av_iter_p(pTHX_ AV *av) { * Local variables: * c-indentation-style: bsd * c-basic-offset: 4 - * indent-tabs-mode: t + * indent-tabs-mode: nil * End: * - * ex: set ts=8 sts=4 sw=4 noet: + * ex: set ts=8 sts=4 sw=4 et: */