X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/9dc0b5dcb80b5128172acb8c4bd670aa72142821..50627f8079af8414075aa4b4eec91a3bb1aa86b8:/sv.c diff --git a/sv.c b/sv.c index 03a2589..0b85abe 100644 --- a/sv.c +++ b/sv.c @@ -63,30 +63,36 @@ av, hv...) contains type and reference count information, as well as a pointer to the body (struct xrv, xpv, xpviv...), which contains fields specific to each type. -Normally, this allocation is done using arenas, which by default are -approximately 4K chunks of memory parcelled up into N heads or bodies. The -first slot in each arena is reserved, and is used to hold a link to the next -arena. In the case of heads, the unused first slot also contains some flags -and a note of the number of slots. Snaked through each arena chain is a -linked list of free items; when this becomes empty, an extra arena is -allocated and divided up into N items which are threaded into the free list. +In all but the most memory-paranoid configuations (ex: PURIFY), this +allocation is done using arenas, which by default are approximately 4K +chunks of memory parcelled up into N heads or bodies (of same size). +Sv-bodies are allocated by their sv-type, guaranteeing size +consistency needed to allocate safely from arrays. + +The first slot in each arena is reserved, and is used to hold a link +to the next arena. In the case of heads, the unused first slot also +contains some flags and a note of the number of slots. Snaked through +each arena chain is a linked list of free items; when this becomes +empty, an extra arena is allocated and divided up into N items which +are threaded into the free list. The following global variables are associated with arenas: PL_sv_arenaroot pointer to list of SV arenas PL_sv_root pointer to list of free SV structures - PL_foo_arenaroot pointer to list of foo arenas, - PL_foo_root pointer to list of free foo bodies - ... for foo in xiv, xnv, xrv, xpv etc. + PL_body_arenaroots[] array of pointers to list of arenas, 1 per svtype + PL_body_roots[] array of pointers to list of free bodies of svtype + arrays are indexed by the svtype needed -Note that some of the larger and more rarely used body types (eg xpvio) -are not allocated using arenas, but are instead just malloc()/free()ed as -required. Also, if PURIFY is defined, arenas are abandoned altogether, -with all items individually malloc()ed. In addition, a few SV heads are -not allocated from an arena, but are instead directly created as static -or auto variables, eg PL_sv_undef. The size of arenas can be changed from -the default by setting PERL_ARENA_SIZE appropriately at compile time. +Note that some of the larger and more rarely used body types (eg +xpvio) are not allocated using arenas, but are instead just +malloc()/free()ed as required. + +In addition, a few SV heads are not allocated from an arena, but are +instead directly created as static or auto variables, eg PL_sv_undef. +The size of arenas can be changed from the default by setting +PERL_ARENA_SIZE appropriately at compile time. The SV arena serves the secondary purpose of allowing still-live SVs to be located and destroyed during final cleanup. @@ -106,8 +112,7 @@ list, and call more_xiv() etc to add a new arena if the list is empty. At the time of very final cleanup, sv_free_arenas() is called from perl_destruct() to physically free all the arenas allocated since the -start of the interpreter. Note that this also clears PL_he_arenaroot, -which is otherwise dealt with in hv.c. +start of the interpreter. Manipulation of any of the PL_*root pointers is protected by enclosing LOCK_SV_MUTEX; ... UNLOCK_SV_MUTEX calls which should Do the Right Thing @@ -140,7 +145,7 @@ called by visit() for each SV]): of zero. called repeatedly from perl_destruct() until there are no SVs left. -=head2 Summary +=head2 Arena allocator API Summary Private API to rest of sv.c @@ -165,21 +170,52 @@ Public API: * "A time to plant, and a time to uproot what was planted..." */ +/* + * nice_chunk and nice_chunk size need to be set + * and queried under the protection of sv_mutex + */ +void +Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) +{ + void *new_chunk; + U32 new_chunk_size; + LOCK_SV_MUTEX; + new_chunk = (void *)(chunk); + new_chunk_size = (chunk_size); + if (new_chunk_size > PL_nice_chunk_size) { + Safefree(PL_nice_chunk); + PL_nice_chunk = (char *) new_chunk; + PL_nice_chunk_size = new_chunk_size; + } else { + Safefree(chunk); + } + UNLOCK_SV_MUTEX; +} #ifdef DEBUG_LEAKING_SCALARS -# ifdef NETWARE -# define FREE_SV_DEBUG_FILE(sv) PerlMemfree((sv)->sv_debug_file) -# else -# define FREE_SV_DEBUG_FILE(sv) PerlMemShared_free((sv)->sv_debug_file) -# endif +# define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file) #else # define FREE_SV_DEBUG_FILE(sv) #endif +#ifdef PERL_POISON +# define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv) +/* Whilst I'd love to do this, it seems that things like to check on + unreferenced scalars +# define POSION_SV_HEAD(sv) Poison(sv, 1, struct STRUCT_SV) +*/ +# define POSION_SV_HEAD(sv) Poison(&SvANY(sv), 1, void *), \ + Poison(&SvREFCNT(sv), 1, U32) +#else +# define SvARENA_CHAIN(sv) SvANY(sv) +# define POSION_SV_HEAD(sv) +#endif + #define plant_SV(p) \ STMT_START { \ FREE_SV_DEBUG_FILE(p); \ - SvANY(p) = (void *)PL_sv_root; \ + POSION_SV_HEAD(p); \ + SvARENA_CHAIN(p) = (void *)PL_sv_root; \ SvFLAGS(p) = SVTYPEMASK; \ PL_sv_root = (p); \ --PL_sv_count; \ @@ -189,7 +225,7 @@ Public API: #define uproot_SV(p) \ STMT_START { \ (p) = PL_sv_root; \ - PL_sv_root = (SV*)SvANY(p); \ + PL_sv_root = (SV*)SvARENA_CHAIN(p); \ ++PL_sv_count; \ } STMT_END @@ -209,7 +245,7 @@ S_more_sv(pTHX) } else { char *chunk; /* must use New here to match call to */ - New(704,chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */ + Newx(chunk,PERL_ARENA_SIZE,char); /* Safefree() in sv_free_arenas() */ sv_add_arena(chunk, PERL_ARENA_SIZE, 0); } uproot_SV(sv); @@ -239,11 +275,7 @@ S_new_SV(pTHX) (PL_curcop ? CopLINE(PL_curcop) : 0) : PL_copline); sv->sv_debug_inpad = 0; sv->sv_debug_cloned = 0; -# ifdef NETWARE sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; -# else - sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; -# endif return sv; } @@ -340,7 +372,7 @@ Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) svend = &sva[SvREFCNT(sva) - 1]; sv = sva + 1; while (sv < svend) { - SvANY(sv) = (void *)(SV*)(sv + 1); + SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1); #ifdef DEBUGGING SvREFCNT(sv) = 0; #endif @@ -349,7 +381,7 @@ Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) SvFLAGS(sv) = SVTYPEMASK; sv++; } - SvANY(sv) = 0; + SvARENA_CHAIN(sv) = 0; #ifdef DEBUGGING SvREFCNT(sv) = 0; #endif @@ -416,18 +448,19 @@ Perl_sv_report_used(pTHX) static void do_clean_objs(pTHX_ SV *ref) { - SV* target; - - if (SvROK(ref) && SvOBJECT(target = SvRV(ref))) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); - if (SvWEAKREF(ref)) { - sv_del_backref(target, ref); - SvWEAKREF_off(ref); - SvRV_set(ref, NULL); - } else { - SvROK_off(ref); - SvRV_set(ref, NULL); - SvREFCNT_dec(target); + if (SvROK(ref)) { + SV * const target = SvRV(ref); + if (SvOBJECT(target)) { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); + if (SvWEAKREF(ref)) { + sv_del_backref(target, ref); + SvWEAKREF_off(ref); + SvRV_set(ref, NULL); + } else { + SvROK_off(ref); + SvRV_set(ref, NULL); + SvREFCNT_dec(target); + } } } @@ -441,7 +474,11 @@ static void do_clean_named_objs(pTHX_ SV *sv) { if (SvTYPE(sv) == SVt_PVGV && GvGP(sv)) { - if ( SvOBJECT(GvSV(sv)) || + if (( +#ifdef PERL_DONT_CREATE_GVSV + GvSV(sv) && +#endif + SvOBJECT(GvSV(sv))) || (GvAV(sv) && SvOBJECT(GvAV(sv))) || (GvHV(sv) && SvOBJECT(GvHV(sv))) || (GvIO(sv) && SvOBJECT(GvIO(sv))) || @@ -526,7 +563,6 @@ heads and bodies within the arenas must already have been freed. =cut */ - #define free_arena(name) \ STMT_START { \ S_free_arena(aTHX_ (void**) PL_ ## name ## _arenaroot); \ @@ -539,6 +575,7 @@ Perl_sv_free_arenas(pTHX) { SV* sva; SV* svanext; + int i; /* Free arenas here, but be careful about fake ones. (We assume contiguity of the fake ones with the corresponding real ones.) */ @@ -551,746 +588,371 @@ Perl_sv_free_arenas(pTHX) if (!SvFAKE(sva)) Safefree(sva); } - - free_arena(xnv); - free_arena(xpv); - free_arena(xpviv); - free_arena(xpvnv); - free_arena(xpvcv); - free_arena(xpvav); - free_arena(xpvhv); - free_arena(xpvmg); - free_arena(xpvgv); - free_arena(xpvlv); - free_arena(xpvbm); - free_arena(he); -#if defined(USE_ITHREADS) - free_arena(pte); -#endif - if (PL_nice_chunk) - Safefree(PL_nice_chunk); + for (i=0; i FUV_MAX_SEARCH_SIZE)) - return Nullsv; + Newx(start, count*size, char); + *((void **) start) = *arena_root; + *arena_root = (void *)start; - array = HvARRAY(hv); + end = start + (count-1) * size; - for (i=HvMAX(hv); i>0; i--) { - register HE *entry; - for (entry = array[i]; entry; entry = HeNEXT(entry)) { - if (HeVAL(entry) != val) - continue; - if ( HeVAL(entry) == &PL_sv_undef || - HeVAL(entry) == &PL_sv_placeholder) - continue; - if (!HeKEY(entry)) - return Nullsv; - if (HeKLEN(entry) == HEf_SVKEY) - return sv_mortalcopy(HeKEY_sv(entry)); - return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry))); - } - } - return Nullsv; -} + /* The initial slot is used to link the arenas together, so it isn't to be + linked into the list of ready-to-use bodies. */ -/* Look for an entry in the array whose value has the same SV as val; - * If so, return the index, otherwise return -1. */ + start += size; -STATIC I32 -S_find_array_subscript(pTHX_ AV *av, SV* val) -{ - SV** svp; - I32 i; - if (!av || SvMAGICAL(av) || !AvARRAY(av) || - (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) - return -1; + *root = (void *)start; - svp = AvARRAY(av); - for (i=AvFILLp(av); i>=0; i--) { - if (svp[i] == val && svp[i] != &PL_sv_undef) - return i; + while (start < end) { + char * const next = start + size; + *(void**) start = (void *)next; + start = next; } - return -1; -} + *(void **)start = 0; -/* S_varname(): return the name of a variable, optionally with a subscript. - * If gv is non-zero, use the name of that global, along with gvtype (one - * of "$", "@", "%"); otherwise use the name of the lexical at pad offset - * targ. Depending on the value of the subscript_type flag, return: - */ + return *root; +} -#define FUV_SUBSCRIPT_NONE 1 /* "@foo" */ -#define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */ -#define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */ -#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */ +/* grab a new thing from the free list, allocating more if necessary */ -STATIC SV* -S_varname(pTHX_ GV *gv, const char *gvtype, PADOFFSET targ, - SV* keyname, I32 aindex, int subscript_type) -{ +/* 1st, the inline version */ - SV * const name = sv_newmortal(); - if (gv) { +#define new_body_inline(xpv, size, sv_type) \ + STMT_START { \ + void **r3wt = &PL_body_roots[sv_type]; \ + LOCK_SV_MUTEX; \ + xpv = *((void **)(r3wt)) \ + ? *((void **)(r3wt)) : S_more_bodies(aTHX_ size, sv_type); \ + *(r3wt) = *(void**)(xpv); \ + UNLOCK_SV_MUTEX; \ + } STMT_END - /* simulate gv_fullname4(), but add literal '^' for $^FOO names - * XXX get rid of all this if gv_fullnameX() ever supports this - * directly */ - - const char *p; - HV * const hv = GvSTASH(gv); - sv_setpv(name, gvtype); - if (!hv) - p = "???"; - else if (!(p=HvNAME_get(hv))) - p = "__ANON__"; - if (strNE(p, "main")) { - sv_catpv(name,p); - sv_catpvn(name,"::", 2); - } - if (GvNAMELEN(gv)>= 1 && - ((unsigned int)*GvNAME(gv)) <= 26) - { /* handle $^FOO */ - Perl_sv_catpvf(aTHX_ name,"^%c", *GvNAME(gv) + 'A' - 1); - sv_catpvn(name,GvNAME(gv)+1,GvNAMELEN(gv)-1); - } - else - sv_catpvn(name,GvNAME(gv),GvNAMELEN(gv)); - } - else { - U32 unused; - CV * const cv = find_runcv(&unused); - SV *sv; - AV *av; +/* now use the inline version in the proper function */ - if (!cv || !CvPADLIST(cv)) - return Nullsv; - av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE)); - sv = *av_fetch(av, targ, FALSE); - /* SvLEN in a pad name is not to be trusted */ - sv_setpv(name, SvPV_nolen_const(sv)); - } +#ifndef PURIFY - if (subscript_type == FUV_SUBSCRIPT_HASH) { - SV * const sv = NEWSV(0,0); - *SvPVX(name) = '$'; - Perl_sv_catpvf(aTHX_ name, "{%s}", - pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32)); - SvREFCNT_dec(sv); - } - else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { - *SvPVX(name) = '$'; - Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex); - } - else if (subscript_type == FUV_SUBSCRIPT_WITHIN) - sv_insert(name, 0, 0, "within ", 7); +/* This isn't being used with -DPURIFY, so don't declare it. Otherwise + compilers issue warnings. */ - return name; +STATIC void * +S_new_body(pTHX_ size_t size, svtype sv_type) +{ + void *xpv; + new_body_inline(xpv, size, sv_type); + return xpv; } +#endif -/* -=for apidoc find_uninit_var +/* return a thing to the free list */ -Find the name of the undefined variable (if any) that caused the operator o -to issue a "Use of uninitialized value" warning. -If match is true, only return a name if it's value matches uninit_sv. -So roughly speaking, if a unary operator (such as OP_COS) generates a -warning, then following the direct child of the op may yield an -OP_PADSV or OP_GV that gives the name of the undefined variable. On the -other hand, with OP_ADD there are two branches to follow, so we only print -the variable name if we get an exact match. +#define del_body(thing, root) \ + STMT_START { \ + void **thing_copy = (void **)thing; \ + LOCK_SV_MUTEX; \ + *thing_copy = *root; \ + *root = (void*)thing_copy; \ + UNLOCK_SV_MUTEX; \ + } STMT_END -The name is returned as a mortal SV. +/* + Revisiting type 3 arenas, there are 4 body-types which have some + members that are never accessed. They are XPV, XPVIV, XPVAV, + XPVHV, which have corresponding types: xpv_allocated, + xpviv_allocated, xpvav_allocated, xpvhv_allocated, -Assumes that PL_op is the op that originally triggered the error, and that -PL_comppad/PL_curpad points to the currently executing pad. + For these types, the arenas are carved up into *_allocated size + chunks, we thus avoid wasted memory for those unaccessed members. + When bodies are allocated, we adjust the pointer back in memory by + the size of the bit not allocated, so it's as if we allocated the + full structure. (But things will all go boom if you write to the + part that is "not there", because you'll be overwriting the last + members of the preceding structure in memory.) -=cut + We calculate the correction using the STRUCT_OFFSET macro. For example, if + xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero, + and the pointer is unchanged. If the allocated structure is smaller (no + initial NV actually allocated) then the net effect is to subtract the size + of the NV from the pointer, to return a new pointer as if an initial NV were + actually allocated. + + This is the same trick as was used for NV and IV bodies. Ironically it + doesn't need to be used for NV bodies any more, because NV is now at the + start of the structure. IV bodies don't need it either, because they are + no longer allocated. */ + +/* The following 2 arrays hide the above details in a pair of + lookup-tables, allowing us to be body-type agnostic. + + size maps svtype to its body's allocated size. + offset maps svtype to the body-pointer adjustment needed + + NB: elements in latter are 0 or <0, and are added during + allocation, and subtracted during deallocation. It may be clearer + to invert the values, and call it shrinkage_by_svtype. */ -STATIC SV * -S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) -{ - dVAR; - SV *sv; - AV *av; - GV *gv; - OP *o, *o2, *kid; +struct body_details { + size_t size; /* Size to allocate */ + size_t copy; /* Size of structure to copy (may be shorter) */ + size_t offset; + bool cant_upgrade; /* Can upgrade this type */ + bool zero_nv; /* zero the NV when upgrading from this */ + bool arena; /* Allocated from an arena */ +}; - if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || - uninit_sv == &PL_sv_placeholder))) - return Nullsv; +#define HADNV FALSE +#define NONV TRUE - switch (obase->op_type) { +#ifdef PURIFY +/* With -DPURFIY we allocate everything directly, and don't use arenas. + This seems a rather elegant way to simplify some of the code below. */ +#define HASARENA FALSE +#else +#define HASARENA TRUE +#endif +#define NOARENA FALSE - case OP_RV2AV: - case OP_RV2HV: - case OP_PADAV: - case OP_PADHV: - { - const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV); - const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV); - I32 index = 0; - SV *keysv = Nullsv; - int subscript_type = FUV_SUBSCRIPT_WITHIN; +/* A macro to work out the offset needed to subtract from a pointer to (say) - if (pad) { /* @lex, %lex */ - sv = PAD_SVl(obase->op_targ); - gv = Nullgv; - } - else { - if (cUNOPx(obase)->op_first->op_type == OP_GV) { - /* @global, %global */ - gv = cGVOPx_gv(cUNOPx(obase)->op_first); - if (!gv) - break; - sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv); - } - else /* @{expr}, %{expr} */ - return find_uninit_var(cUNOPx(obase)->op_first, - uninit_sv, match); - } +typedef struct { + STRLEN xpv_cur; + STRLEN xpv_len; +} xpv_allocated; - /* attempt to find a match within the aggregate */ - if (hash) { - keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv); - if (keysv) - subscript_type = FUV_SUBSCRIPT_HASH; - } - else { - index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); - if (index >= 0) - subscript_type = FUV_SUBSCRIPT_ARRAY; - } +to make its members accessible via a pointer to (say) - if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) - break; +struct xpv { + NV xnv_nv; + STRLEN xpv_cur; + STRLEN xpv_len; +}; - return varname(gv, hash ? "%" : "@", obase->op_targ, - keysv, index, subscript_type); - } +*/ - case OP_PADSV: - if (match && PAD_SVl(obase->op_targ) != uninit_sv) - break; - return varname(Nullgv, "$", obase->op_targ, - Nullsv, 0, FUV_SUBSCRIPT_NONE); +#define relative_STRUCT_OFFSET(longer, shorter, member) \ + (STRUCT_OFFSET(shorter, member) - STRUCT_OFFSET(longer, member)) + +/* Calculate the length to copy. Specifically work out the length less any + final padding the compiler needed to add. See the comment in sv_upgrade + for why copying the padding proved to be a bug. */ + +#define copy_length(type, last_member) \ + STRUCT_OFFSET(type, last_member) \ + + sizeof (((type*)SvANY((SV*)0))->last_member) + +static const struct body_details bodies_by_type[] = { + {0, 0, 0, FALSE, NONV, NOARENA}, + /* IVs are in the head, so the allocation size is 0 */ + {0, sizeof(IV), STRUCT_OFFSET(XPVIV, xiv_iv), FALSE, NONV, NOARENA}, + /* 8 bytes on most ILP32 with IEEE doubles */ + {sizeof(NV), sizeof(NV), 0, FALSE, HADNV, HASARENA}, + /* RVs are in the head now */ + /* However, this slot is overloaded and used by the pte */ + {0, 0, 0, FALSE, NONV, NOARENA}, + /* 8 bytes on most ILP32 with IEEE doubles */ + {sizeof(xpv_allocated), + copy_length(XPV, xpv_len) + + relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur), + - relative_STRUCT_OFFSET(XPV, xpv_allocated, xpv_cur), + FALSE, NONV, HASARENA}, + /* 12 */ + {sizeof(xpviv_allocated), + copy_length(XPVIV, xiv_u) + + relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur), + - relative_STRUCT_OFFSET(XPVIV, xpviv_allocated, xpv_cur), + FALSE, NONV, HASARENA}, + /* 20 */ + {sizeof(XPVNV), copy_length(XPVNV, xiv_u), 0, FALSE, HADNV, HASARENA}, + /* 28 */ + {sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, FALSE, HADNV, HASARENA}, + /* 36 */ + {sizeof(XPVBM), sizeof(XPVBM), 0, TRUE, HADNV, HASARENA}, + /* 48 */ + {sizeof(XPVGV), sizeof(XPVGV), 0, TRUE, HADNV, HASARENA}, + /* 64 */ + {sizeof(XPVLV), sizeof(XPVLV), 0, TRUE, HADNV, HASARENA}, + /* 20 */ + {sizeof(xpvav_allocated), + copy_length(XPVAV, xmg_stash) + + relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill), + - relative_STRUCT_OFFSET(XPVAV, xpvav_allocated, xav_fill), + TRUE, HADNV, HASARENA}, + /* 20 */ + {sizeof(xpvhv_allocated), + copy_length(XPVHV, xmg_stash) + + relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill), + - relative_STRUCT_OFFSET(XPVHV, xpvhv_allocated, xhv_fill), + TRUE, HADNV, HASARENA}, + /* 76 */ + {sizeof(XPVCV), sizeof(XPVCV), 0, TRUE, HADNV, HASARENA}, + /* 80 */ + {sizeof(XPVFM), sizeof(XPVFM), 0, TRUE, HADNV, NOARENA}, + /* 84 */ + {sizeof(XPVIO), sizeof(XPVIO), 0, TRUE, HADNV, NOARENA} +}; + +#define new_body_type(sv_type) \ + (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\ + - bodies_by_type[sv_type].offset) + +#define del_body_type(p, sv_type) \ + del_body(p, &PL_body_roots[sv_type]) + + +#define new_body_allocated(sv_type) \ + (void *)((char *)S_new_body(aTHX_ bodies_by_type[sv_type].size, sv_type)\ + - bodies_by_type[sv_type].offset) + +#define del_body_allocated(p, sv_type) \ + del_body(p + bodies_by_type[sv_type].offset, &PL_body_roots[sv_type]) - case OP_GVSV: - gv = cGVOPx_gv(obase); - if (!gv || (match && GvSV(gv) != uninit_sv)) - break; - return varname(gv, "$", 0, Nullsv, 0, FUV_SUBSCRIPT_NONE); - case OP_AELEMFAST: - if (obase->op_flags & OPf_SPECIAL) { /* lexical array */ - if (match) { - SV **svp; - av = (AV*)PAD_SV(obase->op_targ); - if (!av || SvRMAGICAL(av)) - break; - svp = av_fetch(av, (I32)obase->op_private, FALSE); - if (!svp || *svp != uninit_sv) - break; - } - return varname(Nullgv, "$", obase->op_targ, - Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); - } - else { - gv = cGVOPx_gv(obase); - if (!gv) - break; - if (match) { - SV **svp; - av = GvAV(gv); - if (!av || SvRMAGICAL(av)) - break; - svp = av_fetch(av, (I32)obase->op_private, FALSE); - if (!svp || *svp != uninit_sv) - break; - } - return varname(gv, "$", 0, - Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); - } - break; - - case OP_EXISTS: - o = cUNOPx(obase)->op_first; - if (!o || o->op_type != OP_NULL || - ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM)) - break; - return find_uninit_var(cBINOPo->op_last, uninit_sv, match); - - case OP_AELEM: - case OP_HELEM: - if (PL_op == obase) - /* $a[uninit_expr] or $h{uninit_expr} */ - return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match); +#define my_safemalloc(s) (void*)safemalloc(s) +#define my_safecalloc(s) (void*)safecalloc(s, 1) +#define my_safefree(p) safefree((char*)p) - gv = Nullgv; - o = cBINOPx(obase)->op_first; - kid = cBINOPx(obase)->op_last; +#ifdef PURIFY - /* get the av or hv, and optionally the gv */ - sv = Nullsv; - if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) { - sv = PAD_SV(o->op_targ); - } - else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) - && cUNOPo->op_first->op_type == OP_GV) - { - gv = cGVOPx_gv(cUNOPo->op_first); - if (!gv) - break; - sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv); - } - if (!sv) - break; +#define new_XNV() my_safemalloc(sizeof(XPVNV)) +#define del_XNV(p) my_safefree(p) - if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) { - /* index is constant */ - if (match) { - if (SvMAGICAL(sv)) - break; - if (obase->op_type == OP_HELEM) { - HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0); - if (!he || HeVAL(he) != uninit_sv) - break; - } - else { - SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE); - if (!svp || *svp != uninit_sv) - break; - } - } - if (obase->op_type == OP_HELEM) - return varname(gv, "%", o->op_targ, - cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH); - else - return varname(gv, "@", o->op_targ, Nullsv, - SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY); - ; - } - else { - /* index is an expression; - * attempt to find a match within the aggregate */ - if (obase->op_type == OP_HELEM) { - SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv); - if (keysv) - return varname(gv, "%", o->op_targ, - keysv, 0, FUV_SUBSCRIPT_HASH); - } - else { - const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); - if (index >= 0) - return varname(gv, "@", o->op_targ, - Nullsv, index, FUV_SUBSCRIPT_ARRAY); - } - if (match) - break; - return varname(gv, - (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) - ? "@" : "%", - o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN); - } +#define new_XPVNV() my_safemalloc(sizeof(XPVNV)) +#define del_XPVNV(p) my_safefree(p) - break; +#define new_XPVAV() my_safemalloc(sizeof(XPVAV)) +#define del_XPVAV(p) my_safefree(p) - case OP_AASSIGN: - /* only examine RHS */ - return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match); +#define new_XPVHV() my_safemalloc(sizeof(XPVHV)) +#define del_XPVHV(p) my_safefree(p) - case OP_OPEN: - o = cUNOPx(obase)->op_first; - if (o->op_type == OP_PUSHMARK) - o = o->op_sibling; +#define new_XPVMG() my_safemalloc(sizeof(XPVMG)) +#define del_XPVMG(p) my_safefree(p) - if (!o->op_sibling) { - /* one-arg version of open is highly magical */ +#define new_XPVGV() my_safemalloc(sizeof(XPVGV)) +#define del_XPVGV(p) my_safefree(p) - if (o->op_type == OP_GV) { /* open FOO; */ - gv = cGVOPx_gv(o); - if (match && GvSV(gv) != uninit_sv) - break; - return varname(gv, "$", 0, - Nullsv, 0, FUV_SUBSCRIPT_NONE); - } - /* other possibilities not handled are: - * open $x; or open my $x; should return '${*$x}' - * open expr; should return '$'.expr ideally - */ - break; - } - goto do_op; +#else /* !PURIFY */ - /* ops where $_ may be an implicit arg */ - case OP_TRANS: - case OP_SUBST: - case OP_MATCH: - if ( !(obase->op_flags & OPf_STACKED)) { - if (uninit_sv == ((obase->op_private & OPpTARGET_MY) - ? PAD_SVl(obase->op_targ) - : DEFSV)) - { - sv = sv_newmortal(); - sv_setpvn(sv, "$_", 2); - return sv; - } - } - goto do_op; +#define new_XNV() new_body_type(SVt_NV) +#define del_XNV(p) del_body_type(p, SVt_NV) - case OP_PRTF: - case OP_PRINT: - /* skip filehandle as it can't produce 'undef' warning */ - o = cUNOPx(obase)->op_first; - if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK) - o = o->op_sibling->op_sibling; - goto do_op2; +#define new_XPVNV() new_body_type(SVt_PVNV) +#define del_XPVNV(p) del_body_type(p, SVt_PVNV) +#define new_XPVAV() new_body_allocated(SVt_PVAV) +#define del_XPVAV(p) del_body_allocated(p, SVt_PVAV) - case OP_RV2SV: - case OP_CUSTOM: - case OP_ENTERSUB: - match = 1; /* XS or custom code could trigger random warnings */ - goto do_op; +#define new_XPVHV() new_body_allocated(SVt_PVHV) +#define del_XPVHV(p) del_body_allocated(p, SVt_PVHV) - case OP_SCHOMP: - case OP_CHOMP: - if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) - return sv_2mortal(newSVpv("${$/}", 0)); - /* FALL THROUGH */ +#define new_XPVMG() new_body_type(SVt_PVMG) +#define del_XPVMG(p) del_body_type(p, SVt_PVMG) - default: - do_op: - if (!(obase->op_flags & OPf_KIDS)) - break; - o = cUNOPx(obase)->op_first; - - do_op2: - if (!o) - break; +#define new_XPVGV() new_body_type(SVt_PVGV) +#define del_XPVGV(p) del_body_type(p, SVt_PVGV) - /* if all except one arg are constant, or have no side-effects, - * or are optimized away, then it's unambiguous */ - o2 = Nullop; - for (kid=o; kid; kid = kid->op_sibling) { - if (kid && - ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) - || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) - || (kid->op_type == OP_PUSHMARK) - ) - ) - continue; - if (o2) { /* more than one found */ - o2 = Nullop; - break; - } - o2 = kid; - } - if (o2) - return find_uninit_var(o2, uninit_sv, match); +#endif /* PURIFY */ - /* scan all args */ - while (o) { - sv = find_uninit_var(o, uninit_sv, 1); - if (sv) - return sv; - o = o->op_sibling; - } - break; - } - return Nullsv; -} +/* no arena for you! */ +#define new_NOARENA(details) \ + my_safemalloc((details)->size + (details)->offset) +#define new_NOARENAZ(details) \ + my_safecalloc((details)->size + (details)->offset) /* -=for apidoc report_uninit +=for apidoc sv_upgrade -Print appropriate "Use of uninitialized variable" warning +Upgrade an SV to a more complex form. Generally adds a new body type to the +SV, then copies across as much information as possible from the old body. +You generally want to use the C macro wrapper. See also C. =cut */ void -Perl_report_uninit(pTHX_ SV* uninit_sv) +Perl_sv_upgrade(pTHX_ register SV *sv, U32 new_type) { - if (PL_op) { - SV* varname = Nullsv; - if (uninit_sv) { - varname = find_uninit_var(PL_op, uninit_sv,0); - if (varname) - sv_insert(varname, 0, 0, " ", 1); - } - Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, - varname ? SvPV_nolen_const(varname) : "", - " in ", OP_DESC(PL_op)); + void* old_body; + void* new_body; + const U32 old_type = SvTYPE(sv); + const struct body_details *const old_type_details + = bodies_by_type + old_type; + const struct body_details *new_type_details = bodies_by_type + new_type; + + if (new_type != SVt_PV && SvIsCOW(sv)) { + sv_force_normal_flags(sv, 0); } - else - Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, - "", "", ""); -} -STATIC void * -S_more_bodies (pTHX_ void **arena_root, void **root, size_t size) -{ - char *start; - const char *end; - const size_t count = PERL_ARENA_SIZE/size; - New(0, start, count*size, char); - *((void **) start) = *arena_root; - *arena_root = (void *)start; + if (old_type == new_type) + return; - end = start + (count-1) * size; + if (old_type > new_type) + Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", + (int)old_type, (int)new_type); - /* The initial slot is used to link the arenas together, so it isn't to be - linked into the list of ready-to-use bodies. */ - start += size; + old_body = SvANY(sv); - *root = (void *)start; - - while (start < end) { - char * const next = start + size; - *(void**) start = (void *)next; - start = next; - } - *(void **)start = 0; - - return *root; -} - -/* grab a new thing from the free list, allocating more if necessary */ - -STATIC void * -S_new_body(pTHX_ void **arena_root, void **root, size_t size) -{ - void *xpv; - LOCK_SV_MUTEX; - xpv = *root ? *root : S_more_bodies(aTHX_ arena_root, root, size); - *root = *(void**)xpv; - UNLOCK_SV_MUTEX; - return xpv; -} - -/* return a thing to the free list */ - -#define del_body(thing, root) \ - STMT_START { \ - LOCK_SV_MUTEX; \ - *(void **)thing = *root; \ - *root = (void*)thing; \ - UNLOCK_SV_MUTEX; \ - } STMT_END - -/* Conventionally we simply malloc() a big block of memory, then divide it - up into lots of the thing that we're allocating. - - This macro will expand to call to S_new_body. So for XPVBM (with ithreads), - it would become - - S_new_body(my_perl, (void**)&(my_perl->Ixpvbm_arenaroot), - (void**)&(my_perl->Ixpvbm_root), sizeof(XPVBM), 0) -*/ - -#define new_body(TYPE,lctype) \ - S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \ - (void**)&PL_ ## lctype ## _root, \ - sizeof(TYPE)) - -#define del_body_type(p,TYPE,lctype) \ - del_body((void*)p, (void**)&PL_ ## lctype ## _root) - -/* But for some types, we cheat. The type starts with some members that are - never accessed. So we allocate the substructure, starting at the first used - member, then adjust the pointer back in memory by the size of the bit not - allocated, so it's as if we allocated the full structure. - (But things will all go boom if you write to the part that is "not there", - because you'll be overwriting the last members of the preceding structure - in memory.) - - We calculate the correction using the STRUCT_OFFSET macro. For example, if - xpv_allocated is the same structure as XPV then the two OFFSETs sum to zero, - and the pointer is unchanged. If the allocated structure is smaller (no - initial NV actually allocated) then the net effect is to subtract the size - of the NV from the pointer, to return a new pointer as if an initial NV were - actually allocated. - - This is the same trick as was used for NV and IV bodies. Ironically it - doesn't need to be used for NV bodies any more, because NV is now at the - start of the structure. IV bodies don't need it either, because they are - no longer allocated. */ - -#define new_body_allocated(TYPE,lctype,member) \ - (void*)((char*)S_new_body(aTHX_ (void**)&PL_ ## lctype ## _arenaroot, \ - (void**)&PL_ ## lctype ## _root, \ - sizeof(lctype ## _allocated)) - \ - STRUCT_OFFSET(TYPE, member) \ - + STRUCT_OFFSET(lctype ## _allocated, member)) - - -#define del_body_allocated(p,TYPE,lctype,member) \ - del_body((void*)((char*)p + STRUCT_OFFSET(TYPE, member) \ - - STRUCT_OFFSET(lctype ## _allocated, member)), \ - (void**)&PL_ ## lctype ## _root) - -#define my_safemalloc(s) (void*)safemalloc(s) -#define my_safefree(p) safefree((char*)p) - -#ifdef PURIFY - -#define new_XNV() my_safemalloc(sizeof(XPVNV)) -#define del_XNV(p) my_safefree(p) - -#define new_XPV() my_safemalloc(sizeof(XPV)) -#define del_XPV(p) my_safefree(p) - -#define new_XPVIV() my_safemalloc(sizeof(XPVIV)) -#define del_XPVIV(p) my_safefree(p) - -#define new_XPVNV() my_safemalloc(sizeof(XPVNV)) -#define del_XPVNV(p) my_safefree(p) - -#define new_XPVCV() my_safemalloc(sizeof(XPVCV)) -#define del_XPVCV(p) my_safefree(p) - -#define new_XPVAV() my_safemalloc(sizeof(XPVAV)) -#define del_XPVAV(p) my_safefree(p) - -#define new_XPVHV() my_safemalloc(sizeof(XPVHV)) -#define del_XPVHV(p) my_safefree(p) - -#define new_XPVMG() my_safemalloc(sizeof(XPVMG)) -#define del_XPVMG(p) my_safefree(p) - -#define new_XPVGV() my_safemalloc(sizeof(XPVGV)) -#define del_XPVGV(p) my_safefree(p) - -#define new_XPVLV() my_safemalloc(sizeof(XPVLV)) -#define del_XPVLV(p) my_safefree(p) - -#define new_XPVBM() my_safemalloc(sizeof(XPVBM)) -#define del_XPVBM(p) my_safefree(p) - -#else /* !PURIFY */ - -#define new_XNV() new_body(NV, xnv) -#define del_XNV(p) del_body_type(p, NV, xnv) - -#define new_XPV() new_body_allocated(XPV, xpv, xpv_cur) -#define del_XPV(p) del_body_allocated(p, XPV, xpv, xpv_cur) - -#define new_XPVIV() new_body_allocated(XPVIV, xpviv, xpv_cur) -#define del_XPVIV(p) del_body_allocated(p, XPVIV, xpviv, xpv_cur) - -#define new_XPVNV() new_body(XPVNV, xpvnv) -#define del_XPVNV(p) del_body_type(p, XPVNV, xpvnv) - -#define new_XPVCV() new_body(XPVCV, xpvcv) -#define del_XPVCV(p) del_body_type(p, XPVCV, xpvcv) - -#define new_XPVAV() new_body_allocated(XPVAV, xpvav, xav_fill) -#define del_XPVAV(p) del_body_allocated(p, XPVAV, xpvav, xav_fill) - -#define new_XPVHV() new_body_allocated(XPVHV, xpvhv, xhv_fill) -#define del_XPVHV(p) del_body_allocated(p, XPVHV, xpvhv, xhv_fill) - -#define new_XPVMG() new_body(XPVMG, xpvmg) -#define del_XPVMG(p) del_body_type(p, XPVMG, xpvmg) - -#define new_XPVGV() new_body(XPVGV, xpvgv) -#define del_XPVGV(p) del_body_type(p, XPVGV, xpvgv) - -#define new_XPVLV() new_body(XPVLV, xpvlv) -#define del_XPVLV(p) del_body_type(p, XPVLV, xpvlv) - -#define new_XPVBM() new_body(XPVBM, xpvbm) -#define del_XPVBM(p) del_body_type(p, XPVBM, xpvbm) - -#endif /* PURIFY */ - -#define new_XPVFM() my_safemalloc(sizeof(XPVFM)) -#define del_XPVFM(p) my_safefree(p) - -#define new_XPVIO() my_safemalloc(sizeof(XPVIO)) -#define del_XPVIO(p) my_safefree(p) - -/* -=for apidoc sv_upgrade - -Upgrade an SV to a more complex form. Generally adds a new body type to the -SV, then copies across as much information as possible from the old body. -You generally want to use the C macro wrapper. See also C. - -=cut -*/ - -void -Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) -{ - void** old_body_arena; - size_t old_body_offset; - size_t old_body_length; /* Well, the length to copy. */ - void* old_body; -#ifndef NV_ZERO_IS_ALLBITS_ZERO - /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct - 0.0 for us. */ - bool zero_nv = TRUE; -#endif - void* new_body; - size_t new_body_length; - size_t new_body_offset; - void** new_body_arena; - void** new_body_arenaroot; - const U32 old_type = SvTYPE(sv); - - if (mt != SVt_PV && SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); - } - - if (SvTYPE(sv) == mt) - return; - - if (SvTYPE(sv) > mt) - Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", - (int)SvTYPE(sv), (int)mt); - - - old_body = SvANY(sv); - old_body_arena = 0; - old_body_offset = 0; - old_body_length = 0; - new_body_offset = 0; - new_body_length = ~0; - - /* Copying structures onto other structures that have been neatly zeroed - has a subtle gotcha. Consider XPVMG + /* Copying structures onto other structures that have been neatly zeroed + has a subtle gotcha. Consider XPVMG +------+------+------+------+------+-------+-------+ | NV | CUR | LEN | IV | MAGIC | STASH | @@ -1325,55 +987,32 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) So we are careful and work out the size of used parts of all the structures. */ - switch (SvTYPE(sv)) { + switch (old_type) { case SVt_NULL: break; case SVt_IV: - if (mt == SVt_NV) - mt = SVt_PVNV; - else if (mt < SVt_PVIV) - mt = SVt_PVIV; - old_body_offset = STRUCT_OFFSET(XPVIV, xiv_iv); - old_body_length = sizeof(IV); + if (new_type < SVt_PVIV) { + new_type = (new_type == SVt_NV) + ? SVt_PVNV : SVt_PVIV; + new_type_details = bodies_by_type + new_type; + } break; case SVt_NV: - old_body_arena = (void **) &PL_xnv_root; - old_body_length = sizeof(NV); -#ifndef NV_ZERO_IS_ALLBITS_ZERO - zero_nv = FALSE; -#endif - if (mt < SVt_PVNV) - mt = SVt_PVNV; + if (new_type < SVt_PVNV) { + new_type = SVt_PVNV; + new_type_details = bodies_by_type + new_type; + } break; case SVt_RV: break; case SVt_PV: - old_body_arena = (void **) &PL_xpv_root; - old_body_offset = STRUCT_OFFSET(XPV, xpv_cur) - - STRUCT_OFFSET(xpv_allocated, xpv_cur); - old_body_length = STRUCT_OFFSET(XPV, xpv_len) - + sizeof (((XPV*)SvANY(sv))->xpv_len) - - old_body_offset; - if (mt <= SVt_IV) - mt = SVt_PVIV; - else if (mt == SVt_NV) - mt = SVt_PVNV; + assert(new_type > SVt_PV); + assert(SVt_IV < SVt_PV); + assert(SVt_NV < SVt_PV); break; case SVt_PVIV: - old_body_arena = (void **) &PL_xpviv_root; - old_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur) - - STRUCT_OFFSET(xpviv_allocated, xpv_cur); - old_body_length = STRUCT_OFFSET(XPVIV, xiv_u) - + sizeof (((XPVIV*)SvANY(sv))->xiv_u) - - old_body_offset; break; case SVt_PVNV: - old_body_arena = (void **) &PL_xpvnv_root; - old_body_length = STRUCT_OFFSET(XPVNV, xiv_u) - + sizeof (((XPVNV*)SvANY(sv))->xiv_u); -#ifndef NV_ZERO_IS_ALLBITS_ZERO - zero_nv = FALSE; -#endif break; case SVt_PVMG: /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, @@ -1384,21 +1023,16 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) Given that it only has meaning inside the pad, it shouldn't be set on anything that can get upgraded. */ assert((SvFLAGS(sv) & SVpad_TYPED) == 0); - old_body_arena = (void **) &PL_xpvmg_root; - old_body_length = STRUCT_OFFSET(XPVMG, xmg_stash) - + sizeof (((XPVMG*)SvANY(sv))->xmg_stash); -#ifndef NV_ZERO_IS_ALLBITS_ZERO - zero_nv = FALSE; -#endif break; default: - Perl_croak(aTHX_ "Can't upgrade that kind of scalar"); + if (old_type_details->cant_upgrade) + Perl_croak(aTHX_ "Can't upgrade that kind of scalar"); } SvFLAGS(sv) &= ~SVTYPEMASK; - SvFLAGS(sv) |= mt; + SvFLAGS(sv) |= new_type; - switch (mt) { + switch (new_type) { case SVt_NULL: Perl_croak(aTHX_ "Can't upgrade to undef"); case SVt_IV: @@ -1453,114 +1087,64 @@ Perl_sv_upgrade(pTHX_ register SV *sv, U32 mt) } break; + + case SVt_PVIV: + /* XXX Is this still needed? Was it ever needed? Surely as there is + no route from NV to PVIV, NOK can never be true */ + assert(!SvNOKp(sv)); + assert(!SvNOK(sv)); case SVt_PVIO: - new_body = new_XPVIO(); - new_body_length = sizeof(XPVIO); - goto zero; case SVt_PVFM: - new_body = new_XPVFM(); - new_body_length = sizeof(XPVFM); - goto zero; - case SVt_PVBM: - new_body_length = sizeof(XPVBM); - new_body_arena = (void **) &PL_xpvbm_root; - new_body_arenaroot = (void **) &PL_xpvbm_arenaroot; - goto new_body; case SVt_PVGV: - new_body_length = sizeof(XPVGV); - new_body_arena = (void **) &PL_xpvgv_root; - new_body_arenaroot = (void **) &PL_xpvgv_arenaroot; - goto new_body; case SVt_PVCV: - new_body_length = sizeof(XPVCV); - new_body_arena = (void **) &PL_xpvcv_root; - new_body_arenaroot = (void **) &PL_xpvcv_arenaroot; - goto new_body; case SVt_PVLV: - new_body_length = sizeof(XPVLV); - new_body_arena = (void **) &PL_xpvlv_root; - new_body_arenaroot = (void **) &PL_xpvlv_arenaroot; - goto new_body; case SVt_PVMG: - new_body_length = sizeof(XPVMG); - new_body_arena = (void **) &PL_xpvmg_root; - new_body_arenaroot = (void **) &PL_xpvmg_arenaroot; - goto new_body; case SVt_PVNV: - new_body_length = sizeof(XPVNV); - new_body_arena = (void **) &PL_xpvnv_root; - new_body_arenaroot = (void **) &PL_xpvnv_arenaroot; - goto new_body; - case SVt_PVIV: - new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur) - - STRUCT_OFFSET(xpviv_allocated, xpv_cur); - new_body_length = sizeof(XPVIV) - new_body_offset; - new_body_arena = (void **) &PL_xpviv_root; - new_body_arenaroot = (void **) &PL_xpviv_arenaroot; - /* XXX Is this still needed? Was it ever needed? Surely as there is - no route from NV to PVIV, NOK can never be true */ - if (SvNIOK(sv)) - (void)SvIOK_on(sv); - SvNOK_off(sv); - goto new_body_no_NV; case SVt_PV: - new_body_offset = STRUCT_OFFSET(XPV, xpv_cur) - - STRUCT_OFFSET(xpv_allocated, xpv_cur); - new_body_length = sizeof(XPV) - new_body_offset; - new_body_arena = (void **) &PL_xpv_root; - new_body_arenaroot = (void **) &PL_xpv_arenaroot; - new_body_no_NV: - /* PV and PVIV don't have an NV slot. */ -#ifndef NV_ZERO_IS_ALLBITS_ZERO - zero_nv = FALSE; -#endif - - new_body: - assert(new_body_length); -#ifndef PURIFY - /* This points to the start of the allocated area. */ - new_body = S_new_body(aTHX_ new_body_arenaroot, new_body_arena, - new_body_length); -#else - /* We always allocated the full length item with PURIFY */ - new_body_length += new_body_offset; - new_body_offset = 0; - new_body = my_safemalloc(new_body_length); -#endif - zero: - Zero(new_body, new_body_length, char); - new_body = ((char *)new_body) - new_body_offset; + assert(new_type_details->size); + /* We always allocated the full length item with PURIFY. To do this + we fake things so that arena is false for all 16 types.. */ + if(new_type_details->arena) { + /* This points to the start of the allocated area. */ + new_body_inline(new_body, new_type_details->size, new_type); + Zero(new_body, new_type_details->size, char); + new_body = ((char *)new_body) - new_type_details->offset; + } else { + new_body = new_NOARENAZ(new_type_details); + } SvANY(sv) = new_body; - if (old_body_length) { - Copy((char *)old_body + old_body_offset, - (char *)new_body + old_body_offset, - old_body_length, char); + if (old_type_details->copy) { + Copy((char *)old_body + old_type_details->offset, + (char *)new_body + old_type_details->offset, + old_type_details->copy, char); } #ifndef NV_ZERO_IS_ALLBITS_ZERO - if (zero_nv) + /* If NV 0.0 is store as all bits 0 then Zero() already creates a correct + 0.0 for us. */ + if (old_type_details->zero_nv) SvNV_set(sv, 0); #endif - if (mt == SVt_PVIO) + if (new_type == SVt_PVIO) IoPAGE_LEN(sv) = 60; if (old_type < SVt_RV) SvPV_set(sv, 0); break; default: - Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", mt); + Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", new_type); } - - if (old_body_arena) { + if (old_type_details->size) { + /* If the old body had an allocated size, then we need to free it. */ #ifdef PURIFY my_safefree(old_body); #else - del_body((void*)((char*)old_body + old_body_offset), - old_body_arena); + del_body((void*)((char*)old_body + old_type_details->offset), + &PL_body_roots[old_type]); #endif } } @@ -1750,21 +1334,9 @@ Like C, but also handles 'set' magic. void Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) { - /* With these two if statements: - u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 - - without - u=1.35 s=0.47 cu=73.45 cs=11.43 scripts=270 tests=20865 - - If you wish to remove them, please benchmark to see what the effect is - */ - if (u <= (UV)IV_MAX) { - sv_setiv(sv, (IV)u); - } else { - sv_setiv(sv, 0); - SvIsUV_on(sv); - sv_setuv(sv,u); - } + sv_setiv(sv, 0); + SvIsUV_on(sv); + sv_setuv(sv,u); SvSETMAGIC(sv); } @@ -1833,11 +1405,11 @@ S_not_a_number(pTHX_ SV *sv) const char *pv; if (DO_UTF8(sv)) { - dsv = sv_2mortal(newSVpv("", 0)); + dsv = sv_2mortal(newSVpvn("", 0)); pv = sv_uni_display(dsv, sv, 10, 0); } else { char *d = tmpbuf; - char *limit = tmpbuf + sizeof(tmpbuf) - 8; + const char * const limit = tmpbuf + sizeof(tmpbuf) - 8; /* each *s can expand to 4 chars + "...\0", i.e. need room for 8 chars */ @@ -2053,16 +1625,6 @@ S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) } #endif /* !NV_PRESERVES_UV*/ -/* sv_2iv() is now a macro using Perl_sv_2iv_flags(); - * this function provided for binary compatibility only - */ - -IV -Perl_sv_2iv(pTHX_ register SV *sv) -{ - return sv_2iv_flags(sv, SV_GMAGIC); -} - /* =for apidoc sv_2iv_flags @@ -2090,7 +1652,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) return asIV(sv); if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); } return 0; @@ -2098,11 +1660,13 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) } if (SvTHINKFIRST(sv)) { if (SvROK(sv)) { - SV* tmpstr; - if (SvAMAGIC(sv) && (tmpstr=AMG_CALLun(sv,numer)) && - (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) - return SvIV(tmpstr); - return PTR2IV(SvRV(sv)); + if (SvAMAGIC(sv)) { + SV * const tmpstr=AMG_CALLun(sv,numer); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvIV(tmpstr); + } + } + return PTR2IV(SvRV(sv)); } if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); @@ -2350,7 +1914,7 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) #endif /* NV_PRESERVES_UV */ } } else { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); if (SvTYPE(sv) < SVt_IV) /* Typically the caller expects that sv_any is not NULL now. */ @@ -2362,16 +1926,6 @@ Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); } -/* sv_2uv() is now a macro using Perl_sv_2uv_flags(); - * this function provided for binary compatibility only - */ - -UV -Perl_sv_2uv(pTHX_ register SV *sv) -{ - return sv_2uv_flags(sv, SV_GMAGIC); -} - /* =for apidoc sv_2uv_flags @@ -2398,7 +1952,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) return asUV(sv); if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); } return 0; @@ -2639,7 +2193,7 @@ Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) } else { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); } if (SvTYPE(sv) < SVt_IV) @@ -2673,7 +2227,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvNOKp(sv)) return SvNVX(sv); if (SvPOKp(sv) && SvLEN(sv)) { - if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && + if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && !grok_number(SvPVX_const(sv), SvCUR(sv), NULL)) not_a_number(sv); return Atof(SvPVX_const(sv)); @@ -2686,7 +2240,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) } if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); } return (NV)0; @@ -2753,7 +2307,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) else if (SvPOKp(sv) && SvLEN(sv)) { UV value; const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); - if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !numtype) + if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) not_a_number(sv); #ifdef NV_PRESERVES_UV if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) @@ -2835,7 +2389,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) #endif /* NV_PRESERVES_UV */ } else { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); if (SvTYPE(sv) < SVt_NV) /* Typically the caller expects that sv_any is not NULL now. */ @@ -2911,20 +2465,6 @@ S_asUV(pTHX_ SV *sv) return U_V(Atof(SvPVX_const(sv))); } -/* -=for apidoc sv_2pv_nolen - -Like C, but doesn't return the length too. You should usually -use the macro wrapper C instead. -=cut -*/ - -char * -Perl_sv_2pv_nolen(pTHX_ register SV *sv) -{ - return sv_2pv(sv, 0); -} - /* uiv_2buf(): private routine for use by sv_2pv_flags(): print an IV or * UV as a string towards the end of buf, and return pointers to start and * end of it. @@ -2933,10 +2473,10 @@ Perl_sv_2pv_nolen(pTHX_ register SV *sv) */ static char * -uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) +S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) { char *ptr = buf + TYPE_CHARS(UV); - char *ebuf = ptr; + char * const ebuf = ptr; int sign; if (is_uv) @@ -2957,16 +2497,6 @@ uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) return ptr; } -/* sv_2pv() is now a macro using Perl_sv_2pv_flags(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) -{ - return sv_2pv_flags(sv, lp, SV_GMAGIC); -} - /* =for apidoc sv_2pv_flags @@ -2987,6 +2517,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) SV *tsv, *origsv; char tbuf[64]; /* Must fit sprintf/Gconvert of longest IV/NV */ char *tmpbuf = tbuf; + STRLEN len = 0; /* Hush gcc. len is always initialised before use. */ if (!sv) { if (lp) @@ -3006,12 +2537,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) return SvPVX(sv); } if (SvIOKp(sv)) { - if (SvIsUV(sv)) - (void)sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv)); - else - (void)sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv)); + len = SvIsUV(sv) ? my_sprintf(tmpbuf,"%"UVuf, (UV)SvUVX(sv)) + : my_sprintf(tmpbuf,"%"IVdf, (IV)SvIVX(sv)); tsv = Nullsv; - goto tokensave; + goto tokensave_has_len; } if (SvNOKp(sv)) { Gconvert(SvNVX(sv), NV_DIG, 0, tmpbuf); @@ -3020,7 +2549,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } if (!SvROK(sv)) { if (!(SvFLAGS(sv) & SVs_PADTMP)) { - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing) + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); } if (lp) @@ -3128,7 +2657,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } } - New(616, mg->mg_ptr, mg->mg_len + 1 + left, char); + Newx(mg->mg_ptr, mg->mg_len + 1 + left, char); Copy("(?", mg->mg_ptr, 2, char); Copy(reflags, mg->mg_ptr+2, left, char); Copy(":", mg->mg_ptr+left+2, 1, char); @@ -3172,7 +2701,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } tsv = NEWSV(0,0); if (SvOBJECT(sv)) { - const char *name = HvNAME_get(SvSTASH(sv)); + const char * const name = HvNAME_get(SvSTASH(sv)); Perl_sv_setpvf(aTHX_ tsv, "%s=%s(0x%"UVxf")", name ? name : "__ANON__" , typestr, PTR2UV(sv)); } @@ -3245,8 +2774,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) #endif } else { - if (ckWARN(WARN_UNINITIALIZED) - && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) report_uninit(sv); if (lp) *lp = 0; @@ -3256,7 +2784,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) return (char *)""; } { - STRLEN len = s - SvPVX_const(sv); + const STRLEN len = s - SvPVX_const(sv); if (lp) *lp = len; SvCUR_set(sv, len); @@ -3271,12 +2799,15 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) return SvPVX(sv); tokensave: + len = strlen(tmpbuf); + tokensave_has_len: + assert (!tsv); if (SvROK(sv)) { /* XXX Skip this when sv_pvn_force calls */ /* Sneaky stuff here */ tokensaveref: if (!tsv) - tsv = newSVpv(tmpbuf, 0); + tsv = newSVpvn(tmpbuf, len); sv_2mortal(tsv); if (lp) *lp = SvCUR(tsv); @@ -3284,21 +2815,11 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } else { dVAR; - STRLEN len; - const char *t; - if (tsv) { - sv_2mortal(tsv); - t = SvPVX_const(tsv); - len = SvCUR(tsv); - } - else { - t = tmpbuf; - len = strlen(tmpbuf); - } #ifdef FIXNEGATIVEZERO - if (len == 2 && t[0] == '-' && t[1] == '0') { - t = "0"; + if (len == 2 && tmpbuf[0] == '-' && tmpbuf[1] == '0') { + tmpbuf[0] = '0'; + tmpbuf[1] = 0; len = 1; } #endif @@ -3308,7 +2829,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) s = SvGROW_mutable(sv, len + 1); SvCUR_set(sv, len); SvPOKp_on(sv); - return memcpy(s, t, len + 1); + return memcpy(s, tmpbuf, len + 1); } } @@ -3339,23 +2860,6 @@ Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) } /* -=for apidoc sv_2pvbyte_nolen - -Return a pointer to the byte-encoded representation of the SV. -May cause the SV to be downgraded from UTF-8 as a side-effect. - -Usually accessed via the C macro. - -=cut -*/ - -char * -Perl_sv_2pvbyte_nolen(pTHX_ register SV *sv) -{ - return sv_2pvbyte(sv, 0); -} - -/* =for apidoc sv_2pvbyte Return a pointer to the byte-encoded representation of the SV, and set *lp @@ -3375,23 +2879,6 @@ Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) } /* -=for apidoc sv_2pvutf8_nolen - -Return a pointer to the UTF-8-encoded representation of the SV. -May cause the SV to be upgraded to UTF-8 as a side-effect. - -Usually accessed via the C macro. - -=cut -*/ - -char * -Perl_sv_2pvutf8_nolen(pTHX_ register SV *sv) -{ - return sv_2pvutf8(sv, 0); -} - -/* =for apidoc sv_2pvutf8 Return a pointer to the UTF-8-encoded representation of the SV, and set *lp @@ -3406,9 +2893,10 @@ char * Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) { sv_utf8_upgrade(sv); - return SvPV(sv,*lp); + return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); } + /* =for apidoc sv_2bool @@ -3421,8 +2909,7 @@ sv_true() or its macro equivalent. bool Perl_sv_2bool(pTHX_ register SV *sv) { - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (!SvOK(sv)) return 0; @@ -3455,17 +2942,6 @@ Perl_sv_2bool(pTHX_ register SV *sv) } } -/* sv_utf8_upgrade() is now a macro using sv_utf8_upgrade_flags(); - * this function provided for binary compatibility only - */ - - -STRLEN -Perl_sv_utf8_upgrade(pTHX_ register SV *sv) -{ - return sv_utf8_upgrade_flags(sv, SV_GMAGIC); -} - /* =for apidoc sv_utf8_upgrade @@ -3524,7 +3000,7 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) * chars in the PV. Given that there isn't such a flag * make the loop as fast as possible. */ const U8 *s = (U8 *) SvPVX_const(sv); - const U8 *e = (U8 *) SvEND(sv); + const U8 * const e = (U8 *) SvEND(sv); const U8 *t = s; int hibit = 0; @@ -3648,7 +3124,7 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) return FALSE; e = (const U8 *) SvEND(sv); while (c < e) { - U8 ch = *c++; + const U8 ch = *c++; if (!UTF8_IS_INVARIANT(ch)) { SvUTF8_on(sv); break; @@ -3658,16 +3134,6 @@ Perl_sv_utf8_decode(pTHX_ register SV *sv) return TRUE; } -/* sv_setsv() is now a macro using Perl_sv_setsv_flags(); - * this function provided for binary compatibility only - */ - -void -Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) -{ - sv_setsv_flags(dstr, sstr, SV_GMAGIC); -} - /* =for apidoc sv_setsv @@ -3850,11 +3316,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) GvNAMELEN(dstr) = len; SvFAKE_on(dstr); /* can coerce to non-glob */ } - /* ahem, death to those who redefine active sort subs */ - else if (PL_curstackinfo->si_type == PERLSI_SORT - && GvCV(dstr) && PL_sortcop == CvSTART(GvCV(dstr))) - Perl_croak(aTHX_ "Can't redefine active sort subroutine %s", - GvNAME(dstr)); #ifdef GV_UNIQUE_CHECK if (GvUNIQUE((GV*)dstr)) { @@ -3898,7 +3359,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (sflags & SVf_ROK) { if (dtype >= SVt_PV) { if (dtype == SVt_PVGV) { - SV *sref = SvREFCNT_inc(SvRV(sstr)); + SV * const sref = SvREFCNT_inc(SvRV(sstr)); SV *dref = 0; const int intro = GvINTRO(dstr); @@ -3952,18 +3413,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) else dref = (SV*)GvCV(dstr); if (GvCV(dstr) != (CV*)sref) { - CV* cv = GvCV(dstr); + CV* const cv = GvCV(dstr); if (cv) { if (!GvCVGEN((GV*)dstr) && (CvROOT(cv) || CvXSUB(cv))) { - /* ahem, death to those who redefine - * active sort subs */ - if (PL_curstackinfo->si_type == PERLSI_SORT && - PL_sortcop == CvSTART(cv)) - Perl_croak(aTHX_ - "Can't redefine active sort subroutine %s", - GvENAME((GV*)dstr)); /* Redefining a sub - warning is mandatory if it was a const and its value changed. */ if (ckWARN(WARN_REDEFINE) @@ -4483,7 +3937,7 @@ S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, STRLEN len, SV *after) { if (len) { /* this SV was SvIsCOW_normal(sv) */ /* we need to find the SV pointing to us. */ - SV *current = SV_COW_NEXT_SV(after); + SV * const current = SV_COW_NEXT_SV(after); if (current == sv) { /* The SV we point to points back to us (there were only two of us @@ -4542,7 +3996,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) if (SvREADONLY(sv)) { /* At this point I believe I should acquire a global SV mutex. */ if (SvFAKE(sv)) { - const char *pvx = SvPVX_const(sv); + const char * const pvx = SvPVX_const(sv); const STRLEN len = SvLEN(sv); const STRLEN cur = SvCUR(sv); SV * const next = SV_COW_NEXT_SV(sv); /* next COW sv in the loop. */ @@ -4554,7 +4008,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) } SvFAKE_off(sv); SvREADONLY_off(sv); - /* This SV doesn't own the buffer, so need to New() a new one: */ + /* This SV doesn't own the buffer, so need to Newx() a new one: */ SvPV_set(sv, (char*)0); SvLEN_set(sv, 0); if (flags & SV_COW_DROP_PV) { @@ -4578,14 +4032,14 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) #else if (SvREADONLY(sv)) { if (SvFAKE(sv)) { - const char *pvx = SvPVX_const(sv); + const char * const pvx = SvPVX_const(sv); const STRLEN len = SvCUR(sv); SvFAKE_off(sv); SvREADONLY_off(sv); SvPV_set(sv, Nullch); SvLEN_set(sv, 0); SvGROW(sv, len + 1); - Move(pvx,SvPVX_const(sv),len,char); + Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } @@ -4600,23 +4054,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) } /* -=for apidoc sv_force_normal - -Undo various types of fakery on an SV: if the PV is a shared string, make -a private copy; if we're a ref, stop refing; if we're a glob, downgrade to -an xpvmg. See also C. - -=cut -*/ - -void -Perl_sv_force_normal(pTHX_ register SV *sv) -{ - sv_force_normal_flags(sv, 0); -} - -/* -=for apidoc sv_chop +=for apidoc sv_chop Efficient removal of characters from the beginning of the string buffer. SvPOK(sv) must be true and the C must be a pointer to somewhere inside @@ -4644,7 +4082,7 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) const char *pvx = SvPVX_const(sv); const STRLEN len = SvCUR(sv); SvGROW(sv, len + 1); - Move(pvx,SvPVX_const(sv),len,char); + Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; } SvIV_set(sv, 0); @@ -4660,16 +4098,6 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) SvIV_set(sv, SvIVX(sv) + delta); } -/* sv_catpvn() is now a macro using Perl_sv_catpvn_flags(); - * this function provided for binary compatibility only - */ - -void -Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen) -{ - sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC); -} - /* =for apidoc sv_catpvn @@ -4704,31 +4132,8 @@ Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register *SvEND(dsv) = '\0'; (void)SvPOK_only_UTF8(dsv); /* validate pointer */ SvTAINT(dsv); -} - -/* -=for apidoc sv_catpvn_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - -void -Perl_sv_catpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) -{ - sv_catpvn(sv,ptr,len); - SvSETMAGIC(sv); -} - -/* sv_catsv() is now a macro using Perl_sv_catsv_flags(); - * this function provided for binary compatibility only - */ - -void -Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) -{ - sv_catsv_flags(dstr, sstr, SV_GMAGIC); + if (flags & SV_SMAGIC) + SvSETMAGIC(dsv); } /* @@ -4752,51 +4157,38 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) { const char *spv; STRLEN slen; - if (!ssv) - return; - if ((spv = SvPV_const(ssv, slen))) { - /* sutf8 and dutf8 were type bool, but under USE_ITHREADS, - gcc version 2.95.2 20000220 (Debian GNU/Linux) for - Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously - get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though - dsv->sv_flags doesn't have that bit set. + if (ssv) { + if ((spv = SvPV_const(ssv, slen))) { + /* sutf8 and dutf8 were type bool, but under USE_ITHREADS, + gcc version 2.95.2 20000220 (Debian GNU/Linux) for + Linux xxx 2.2.17 on sparc64 with gcc -O2, we erroneously + get dutf8 = 0x20000000, (i.e. SVf_UTF8) even though + dsv->sv_flags doesn't have that bit set. Andy Dougherty 12 Oct 2001 - */ - const I32 sutf8 = DO_UTF8(ssv); - I32 dutf8; + */ + const I32 sutf8 = DO_UTF8(ssv); + I32 dutf8; - if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC)) - mg_get(dsv); - dutf8 = DO_UTF8(dsv); + if (SvGMAGICAL(dsv) && (flags & SV_GMAGIC)) + mg_get(dsv); + dutf8 = DO_UTF8(dsv); - if (dutf8 != sutf8) { - if (dutf8) { - /* Not modifying source SV, so taking a temporary copy. */ - SV* csv = sv_2mortal(newSVpvn(spv, slen)); + if (dutf8 != sutf8) { + if (dutf8) { + /* Not modifying source SV, so taking a temporary copy. */ + SV* csv = sv_2mortal(newSVpvn(spv, slen)); - sv_utf8_upgrade(csv); - spv = SvPV_const(csv, slen); + sv_utf8_upgrade(csv); + spv = SvPV_const(csv, slen); + } + else + sv_utf8_upgrade_nomg(dsv); } - else - sv_utf8_upgrade_nomg(dsv); + sv_catpvn_nomg(dsv, spv, slen); } - sv_catpvn_nomg(dsv, spv, slen); } -} - -/* -=for apidoc sv_catsv_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - -void -Perl_sv_catsv_mg(pTHX_ SV *dsv, register SV *ssv) -{ - sv_catsv(dsv,ssv); - SvSETMAGIC(dsv); + if (flags & SV_SMAGIC) + SvSETMAGIC(dsv); } /* @@ -4893,7 +4285,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, if (SvTYPE(sv) < SVt_PVMG) { SvUPGRADE(sv, SVt_PVMG); } - Newz(702,mg, 1, MAGIC); + Newxz(mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); SvMAGIC_set(sv, mg); @@ -4972,7 +4364,7 @@ to add more than one instance of the same 'how'. void Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 namlen) { - const MGVTBL *vtable = 0; + const MGVTBL *vtable; MAGIC* mg; #ifdef PERL_OLD_COPY_ON_WRITE @@ -4980,7 +4372,12 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam sv_force_normal_flags(sv, 0); #endif if (SvREADONLY(sv)) { - if (IN_PERL_RUNTIME + if ( + /* its okay to attach magic to shared strings; the subsequent + * upgrade to PVMG will unshare the string */ + !(SvFAKE(sv) && SvTYPE(sv) < SVt_PVMG) + + && IN_PERL_RUNTIME && how != PERL_MAGIC_regex_global && how != PERL_MAGIC_bm && how != PERL_MAGIC_fm @@ -5046,7 +4443,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam vtable = &PL_vtbl_nkeys; break; case PERL_MAGIC_dbfile: - vtable = 0; + vtable = NULL; break; case PERL_MAGIC_dbline: vtable = &PL_vtbl_dbline; @@ -5085,7 +4482,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam case PERL_MAGIC_rhash: case PERL_MAGIC_symtab: case PERL_MAGIC_vstring: - vtable = 0; + vtable = NULL; break; case PERL_MAGIC_utf8: vtable = &PL_vtbl_utf8; @@ -5113,13 +4510,14 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam /* Useful for attaching extension internal data to perl vars. */ /* Note that multiple extensions may clash if magical scalars */ /* etc holding private data from one are passed to another. */ + vtable = NULL; break; default: Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); } /* Rest of work is done else where */ - mg = sv_magicext(sv,obj,how,(MGVTBL*)vtable,name,namlen); + mg = sv_magicext(sv,obj,how,vtable,name,namlen); switch (how) { case PERL_MAGIC_taint: @@ -5381,8 +4779,10 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) { const U32 refcnt = SvREFCNT(sv); SV_CHECK_THINKFIRST_COW_DROP(sv); - if (SvREFCNT(nsv) != 1 && ckWARN_d(WARN_INTERNAL)) - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Reference miscount in sv_replace()"); + if (SvREFCNT(nsv) != 1) { + Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%" + UVuf " != 1)", (UV) SvREFCNT(nsv)); + } if (SvMAGICAL(sv)) { if (SvMAGICAL(nsv)) mg_free(nsv); @@ -5460,13 +4860,20 @@ void Perl_sv_clear(pTHX_ register SV *sv) { dVAR; - HV* stash; + const U32 type = SvTYPE(sv); + const struct body_details *const sv_type_details + = bodies_by_type + type; + assert(sv); assert(SvREFCNT(sv) == 0); + if (type <= SVt_IV) + return; + if (SvOBJECT(sv)) { if (PL_defstash) { /* Still have a symbol table? */ dSP; + HV* stash; do { CV* destructor; stash = SvSTASH(sv); @@ -5509,18 +4916,17 @@ Perl_sv_clear(pTHX_ register SV *sv) if (SvOBJECT(sv)) { SvREFCNT_dec(SvSTASH(sv)); /* possibly of changed persuasion */ SvOBJECT_off(sv); /* Curse the object. */ - if (SvTYPE(sv) != SVt_PVIO) + if (type != SVt_PVIO) --PL_sv_objcount; /* XXX Might want something more general */ } } - if (SvTYPE(sv) >= SVt_PVMG) { + if (type >= SVt_PVMG) { if (SvMAGIC(sv)) mg_free(sv); - if (SvTYPE(sv) == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED) + if (type == SVt_PVMG && SvFLAGS(sv) & SVpad_TYPED) SvREFCNT_dec(SvSTASH(sv)); } - stash = NULL; - switch (SvTYPE(sv)) { + switch (type) { case SVt_PVIO: if (IoIFP(sv) && IoIFP(sv) != PerlIO_stdin() && @@ -5535,7 +4941,7 @@ Perl_sv_clear(pTHX_ register SV *sv) Safefree(IoTOP_NAME(sv)); Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); - /* FALL THROUGH */ + goto freescalar; case SVt_PVBM: goto freescalar; case SVt_PVCV: @@ -5560,12 +4966,10 @@ Perl_sv_clear(pTHX_ register SV *sv) case SVt_PVGV: gp_free((GV*)sv); Safefree(GvNAME(sv)); - /* cannot decrease stash refcount yet, as we might recursively delete - ourselves when the refcnt drops to zero. Delay SvREFCNT_dec - of stash until current sv is completely gone. - -- JohnPC, 27 Mar 1998 */ - stash = GvSTASH(sv); - /* FALL THROUGH */ + /* If we're in a stash, we don't own a reference to it. However it does + have a back reference to us, which needs to be cleared. */ + if (GvSTASH(sv)) + sv_del_backref((SV*)GvSTASH(sv), sv); case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -5575,7 +4979,6 @@ Perl_sv_clear(pTHX_ register SV *sv) SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv)); /* Don't even bother with turning off the OOK flag. */ } - /* FALL THROUGH */ case SVt_PV: case SVt_RV: if (SvROK(sv)) { @@ -5611,69 +5014,20 @@ Perl_sv_clear(pTHX_ register SV *sv) } #endif break; -/* case SVt_NV: - case SVt_IV: - case SVt_NULL: break; -*/ } - switch (SvTYPE(sv)) { - case SVt_NULL: - break; - case SVt_IV: - break; - case SVt_NV: - del_XNV(SvANY(sv)); - break; - case SVt_RV: - break; - case SVt_PV: - del_XPV(SvANY(sv)); - break; - case SVt_PVIV: - del_XPVIV(SvANY(sv)); - break; - case SVt_PVNV: - del_XPVNV(SvANY(sv)); - break; - case SVt_PVMG: - del_XPVMG(SvANY(sv)); - break; - case SVt_PVLV: - del_XPVLV(SvANY(sv)); - break; - case SVt_PVAV: - del_XPVAV(SvANY(sv)); - break; - case SVt_PVHV: - del_XPVHV(SvANY(sv)); - break; - case SVt_PVCV: - del_XPVCV(SvANY(sv)); - break; - case SVt_PVGV: - del_XPVGV(SvANY(sv)); - /* code duplication for increased performance. */ - SvFLAGS(sv) &= SVf_BREAK; - SvFLAGS(sv) |= SVTYPEMASK; - /* decrease refcount of the stash that owns this GV, if any */ - if (stash) - sv_del_backref((SV*)stash, sv); - return; /* not break, SvFLAGS reset already happened */ - case SVt_PVBM: - del_XPVBM(SvANY(sv)); - break; - case SVt_PVFM: - del_XPVFM(SvANY(sv)); - break; - case SVt_PVIO: - del_XPVIO(SvANY(sv)); - break; - } SvFLAGS(sv) &= SVf_BREAK; SvFLAGS(sv) |= SVTYPEMASK; + + if (sv_type_details->arena) { + del_body(((char *)SvANY(sv) + sv_type_details->offset), + &PL_body_roots[type]); + } + else if (sv_type_details->size) { + my_safefree(SvANY(sv)); + } } /* @@ -5858,7 +5212,7 @@ S_utf8_mg_pos_init(pTHX_ SV *sv, MAGIC **mgp, STRLEN **cachep, I32 i, if ((*mgp)->mg_ptr) *cachep = (STRLEN *) (*mgp)->mg_ptr; else { - Newz(0, *cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); + Newxz(*cachep, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); (*mgp)->mg_ptr = (char *) *cachep; } assert(*cachep); @@ -6180,7 +5534,7 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) assert(mg); if (!mg->mg_ptr) { - Newz(0, cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); + Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); mg->mg_ptr = (char *) cache; } assert(cache); @@ -6779,7 +6133,7 @@ thats_really_all_folks: /*The big, slow, and stupid way. */ #ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */ STDCHAR *buf = 0; - New(0, buf, 8192, STDCHAR); + Newx(buf, 8192, STDCHAR); assert(buf); #else STDCHAR buf[8192]; @@ -6787,7 +6141,7 @@ thats_really_all_folks: screamer2: if (rslen) { - const register STDCHAR *bpe = buf + sizeof(buf); + register const STDCHAR *bpe = buf + sizeof(buf); bp = buf; while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) ; /* keep reading */ @@ -6868,8 +6222,7 @@ Perl_sv_inc(pTHX_ register SV *sv) if (!sv) return; - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (SvTHINKFIRST(sv)) { if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); @@ -7024,8 +6377,7 @@ Perl_sv_dec(pTHX_ register SV *sv) if (!sv) return; - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (SvTHINKFIRST(sv)) { if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); @@ -7057,7 +6409,7 @@ Perl_sv_dec(pTHX_ register SV *sv) } else { (void)SvIOK_only_UV(sv); - SvUV_set(sv, SvUVX(sv) + 1); + SvUV_set(sv, SvUVX(sv) - 1); } } else { if (SvIVX(sv) == IV_MIN) @@ -7267,8 +6619,8 @@ Perl_newSVhek(pTHX_ const HEK *hek) Andreas would like keys he put in as utf8 to come back as utf8 */ STRLEN utf8_len = HEK_LEN(hek); - U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); - SV *sv = newSVpvn ((char*)as_utf8, utf8_len); + const U8 *as_utf8 = bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); + SV * const sv = newSVpvn ((const char*)as_utf8, utf8_len); SvUTF8_on (sv); Safefree (as_utf8); /* bytes_to_utf8() allocates a new string */ @@ -7280,7 +6632,7 @@ Perl_newSVhek(pTHX_ const HEK *hek) that would contain the (wrong) hash value, and might get passed into an hv routine with a regular hash */ - SV *sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); + SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); if (HEK_UTF8(hek)) SvUTF8_on (sv); return sv; @@ -7522,7 +6874,7 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash) return; if (!*s) { /* reset ?? searches */ - MAGIC *mg = mg_find((SV *)stash, PERL_MAGIC_symtab); + MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab); if (mg) { PMOP *pm = (PMOP *) mg->mg_obj; while (pm) { @@ -7562,35 +6914,35 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash) continue; gv = (GV*)HeVAL(entry); sv = GvSV(gv); - if (SvTHINKFIRST(sv)) { - if (!SvREADONLY(sv) && SvROK(sv)) - sv_unref(sv); - continue; - } - SvOK_off(sv); - if (SvTYPE(sv) >= SVt_PV) { - SvCUR_set(sv, 0); - if (SvPVX_const(sv) != Nullch) - *SvPVX(sv) = '\0'; - SvTAINT(sv); + if (sv) { + if (SvTHINKFIRST(sv)) { + if (!SvREADONLY(sv) && SvROK(sv)) + sv_unref(sv); + /* XXX Is this continue a bug? Why should THINKFIRST + exempt us from resetting arrays and hashes? */ + continue; + } + SvOK_off(sv); + if (SvTYPE(sv) >= SVt_PV) { + SvCUR_set(sv, 0); + if (SvPVX_const(sv) != Nullch) + *SvPVX(sv) = '\0'; + SvTAINT(sv); + } } if (GvAV(gv)) { av_clear(GvAV(gv)); } if (GvHV(gv) && !HvNAME_get(GvHV(gv))) { +#if defined(VMS) + Perl_die(aTHX_ "Can't reset %%ENV on this system"); +#else /* ! VMS */ hv_clear(GvHV(gv)); -#ifndef PERL_MICRO -#ifdef USE_ENVIRON_ARRAY - if (gv == PL_envgv -# ifdef USE_ITHREADS - && PL_curinterp == aTHX -# endif - ) - { - environ[0] = Nullch; - } -#endif -#endif /* !PERL_MICRO */ +# if defined(USE_ENVIRON_ARRAY) + if (gv == PL_envgv) + my_clearenv(); +# endif /* USE_ENVIRON_ARRAY */ +#endif /* VMS */ } } } @@ -7674,10 +7026,9 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) goto fix_gv; default: - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (SvROK(sv)) { - SV **sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */ tryAMAGICunDEREF(to_cv); sv = SvRV(sv); @@ -7738,8 +7089,8 @@ Perl_sv_true(pTHX_ register SV *sv) if (!sv) return 0; if (SvPOK(sv)) { - const register XPV* tXpv; - if ((tXpv = (XPV*)SvANY(sv)) && + register const XPV* const tXpv = (XPV*)SvANY(sv); + if (tXpv && (tXpv->xpv_cur > 1 || (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0'))) return 1; @@ -7759,120 +7110,6 @@ Perl_sv_true(pTHX_ register SV *sv) } /* -=for apidoc sv_iv - -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. - -=cut -*/ - -IV -Perl_sv_iv(pTHX_ register SV *sv) -{ - if (SvIOK(sv)) { - if (SvIsUV(sv)) - return (IV)SvUVX(sv); - return SvIVX(sv); - } - return sv_2iv(sv); -} - -/* -=for apidoc sv_uv - -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. - -=cut -*/ - -UV -Perl_sv_uv(pTHX_ register SV *sv) -{ - if (SvIOK(sv)) { - if (SvIsUV(sv)) - return SvUVX(sv); - return (UV)SvIVX(sv); - } - return sv_2uv(sv); -} - -/* -=for apidoc sv_nv - -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. - -=cut -*/ - -NV -Perl_sv_nv(pTHX_ register SV *sv) -{ - if (SvNOK(sv)) - return SvNVX(sv); - return sv_2nv(sv); -} - -/* sv_pv() is now a macro using SvPV_nolen(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_pv(pTHX_ SV *sv) -{ - if (SvPOK(sv)) - return SvPVX(sv); - - return sv_2pv(sv, 0); -} - -/* -=for apidoc sv_pv - -Use the C macro instead - -=for apidoc sv_pvn - -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. - -=cut -*/ - -char * -Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) -{ - if (SvPOK(sv)) { - *lp = SvCUR(sv); - return SvPVX(sv); - } - return sv_2pv(sv, lp); -} - - -char * -Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp) -{ - if (SvPOK(sv)) { - *lp = SvCUR(sv); - return SvPVX(sv); - } - return sv_2pv_flags(sv, lp, 0); -} - -/* sv_pvn_force() is now a macro using Perl_sv_pvn_force_flags(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) -{ - return sv_pvn_force_flags(sv, lp, SV_GMAGIC); -} - -/* =for apidoc sv_pvn_force Get a sensible string out of the SV somehow. @@ -7907,19 +7144,17 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) STRLEN len; if (SvREADONLY(sv) && !(flags & SV_MUTABLE_RETURN)) { + const char * const ref = sv_reftype(sv,0); if (PL_op) Perl_croak(aTHX_ "Can't coerce readonly %s to string in %s", - sv_reftype(sv,0), OP_NAME(PL_op)); + ref, OP_NAME(PL_op)); else - Perl_croak(aTHX_ "Can't coerce readonly %s to string", - sv_reftype(sv,0)); + Perl_croak(aTHX_ "Can't coerce readonly %s to string", ref); } - if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) { + if (SvTYPE(sv) > SVt_PVLV && SvTYPE(sv) != SVt_PVFM) Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), OP_NAME(PL_op)); - } - else - s = sv_2pv_flags(sv, &len, flags); + s = sv_2pv_flags(sv, &len, flags); if (lp) *lp = len; @@ -7928,7 +7163,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) sv_unref(sv); SvUPGRADE(sv, SVt_PV); /* Never FALSE */ SvGROW(sv, len + 1); - Move(s,SvPVX_const(sv),len,char); + Move(s,SvPVX(sv),len,char); SvCUR_set(sv, len); *SvEND(sv) = '\0'; } @@ -7942,44 +7177,10 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) return SvPVX_mutable(sv); } -/* sv_pvbyte () is now a macro using Perl_sv_2pv_flags(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_pvbyte(pTHX_ SV *sv) -{ - sv_utf8_downgrade(sv,0); - return sv_pv(sv); -} - -/* -=for apidoc sv_pvbyte - -Use C instead. - -=for apidoc sv_pvbyten - -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. - -=cut -*/ - -char * -Perl_sv_pvbyten(pTHX_ SV *sv, STRLEN *lp) -{ - sv_utf8_downgrade(sv,0); - return sv_pvn(sv,lp); -} - /* =for apidoc sv_pvbyten_force -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. +The backend for the C macro. Always use the macro instead. =cut */ @@ -7993,44 +7194,10 @@ Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) return SvPVX(sv); } -/* sv_pvutf8 () is now a macro using Perl_sv_2pv_flags(); - * this function provided for binary compatibility only - */ - -char * -Perl_sv_pvutf8(pTHX_ SV *sv) -{ - sv_utf8_upgrade(sv); - return sv_pv(sv); -} - -/* -=for apidoc sv_pvutf8 - -Use the C macro instead - -=for apidoc sv_pvutf8n - -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. - -=cut -*/ - -char * -Perl_sv_pvutf8n(pTHX_ SV *sv, STRLEN *lp) -{ - sv_utf8_upgrade(sv); - return sv_pvn(sv,lp); -} - /* =for apidoc sv_pvutf8n_force -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. +The backend for the C macro. Always use the macro instead. =cut */ @@ -8110,8 +7277,7 @@ Perl_sv_isobject(pTHX_ SV *sv) { if (!sv) return 0; - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (!SvROK(sv)) return 0; sv = (SV*)SvRV(sv); @@ -8136,8 +7302,7 @@ Perl_sv_isa(pTHX_ SV *sv, const char *name) const char *hvname; if (!sv) return 0; - if (SvGMAGICAL(sv)) - mg_get(sv); + SvGETMAGIC(sv); if (!SvROK(sv)) return 0; sv = (SV*)SvRV(sv); @@ -8400,7 +7565,7 @@ See C. void Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags) { - SV* target = SvRV(ref); + SV* const target = SvRV(ref); if (SvWEAKREF(ref)) { sv_del_backref(target, ref); @@ -8419,36 +7584,6 @@ Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags) } /* -=for apidoc sv_unref - -Unsets the RV status of the SV, and decrements the reference count of -whatever was being referenced by the RV. This can almost be thought of -as a reversal of C. This is C with the C -being zero. See C. - -=cut -*/ - -void -Perl_sv_unref(pTHX_ SV *sv) -{ - sv_unref_flags(sv, 0); -} - -/* -=for apidoc sv_taint - -Taint an SV. Use C instead. -=cut -*/ - -void -Perl_sv_taint(pTHX_ SV *sv) -{ - sv_magic((sv), Nullsv, PERL_MAGIC_taint, Nullch, 0); -} - -/* =for apidoc sv_untaint Untaint an SV. Use C instead. @@ -8459,7 +7594,7 @@ void Perl_sv_untaint(pTHX_ SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - MAGIC *mg = mg_find(sv, PERL_MAGIC_taint); + MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); if (mg) mg->mg_len &= ~1; } @@ -8476,7 +7611,7 @@ bool Perl_sv_tainted(pTHX_ SV *sv) { if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); + const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); if (mg && (mg->mg_len & 1) ) return TRUE; } @@ -8497,7 +7632,7 @@ Perl_sv_setpviv(pTHX_ SV *sv, IV iv) { char buf[TYPE_CHARS(UV)]; char *ebuf; - char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); + char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); sv_setpvn(sv, ptr, ebuf - ptr); } @@ -8513,11 +7648,7 @@ Like C, but also handles 'set' magic. void Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) { - char buf[TYPE_CHARS(UV)]; - char *ebuf; - char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); - - sv_setpvn(sv, ptr, ebuf - ptr); + sv_setpviv(sv, iv); SvSETMAGIC(sv); } @@ -8805,6 +7936,11 @@ Usually used via one of its frontends C and C. =cut */ + +#define VECTORIZE_ARGS vecsv = va_arg(*args, SV*);\ + vecstr = (U8*)SvPV_const(vecsv,veclen);\ + vec_utf8 = DO_UTF8(vecsv); + /* XXX maybe_tainted is never assigned to, so the doc above is lying. */ void @@ -8832,30 +7968,24 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* no matter what, this is a string now */ (void)SvPV_force(sv, origlen); - /* special-case "", "%s", and "%-p" (SVf) */ + /* special-case "", "%s", and "%-p" (SVf - see below) */ if (patlen == 0) return; if (patlen == 2 && pat[0] == '%' && pat[1] == 's') { - if (args) { - const char * const s = va_arg(*args, char*); - sv_catpv(sv, s ? s : nullstr); - } - else if (svix < svmax) { - sv_catsv(sv, *svargs); - if (DO_UTF8(*svargs)) - SvUTF8_on(sv); - } - return; + if (args) { + const char * const s = va_arg(*args, char*); + sv_catpv(sv, s ? s : nullstr); + } + else if (svix < svmax) { + sv_catsv(sv, *svargs); + } + return; } - if (patlen == 3 && pat[0] == '%' && - pat[1] == '-' && pat[2] == 'p') { - if (args) { - argsv = va_arg(*args, SV*); - sv_catsv(sv, argsv); - if (DO_UTF8(argsv)) - SvUTF8_on(sv); - return; - } + if (args && patlen == 3 && pat[0] == '%' && + pat[1] == '-' && pat[2] == 'p') { + argsv = va_arg(*args, SV*); + sv_catsv(sv, argsv); + return; } #ifndef USE_LONG_DOUBLE @@ -8977,8 +8107,60 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV \d+|\*(\d+\$)? width using optional (optionally specified) arg \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg [hlqLV] size - [%bcdefginopsux_DFOUX] format (mandatory) + [%bcdefginopsuxDFOUX] format (mandatory) */ + + if (args) { +/* + As of perl5.9.3, printf format checking is on by default. + Internally, perl uses %p formats to provide an escape to + some extended formatting. This block deals with those + extensions: if it does not match, (char*)q is reset and + the normal format processing code is used. + + Currently defined extensions are: + %p include pointer address (standard) + %-p (SVf) include an SV (previously %_) + %-p include an SV with precision + %1p (VDf) include a v-string (as %vd) + %p reserved for future extensions + + Robin Barker 2005-07-14 +*/ + char* r = q; + bool sv = FALSE; + STRLEN n = 0; + if (*q == '-') + sv = *q++; + EXPECT_NUMBER(q, n); + if (*q++ == 'p') { + if (sv) { /* SVf */ + if (n) { + precis = n; + has_precis = TRUE; + } + argsv = va_arg(*args, SV*); + eptr = SvPVx_const(argsv, elen); + if (DO_UTF8(argsv)) + is_utf8 = TRUE; + goto string; + } +#if vdNUMBER + else if (n == vdNUMBER) { /* VDf */ + vectorize = TRUE; + VECTORIZE_ARGS + goto format_vd; + } +#endif + else if (n) { + if (ckWARN_d(WARN_INTERNAL)) + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), + "internal %%p might conflict with future printf extensions"); + } + } + q = r; + } + if (EXPECT_NUMBER(q, width)) { if (*q == '$') { ++q; @@ -9039,9 +8221,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } if (!asterisk) + { if( *q == '0' ) fill = *q++; EXPECT_NUMBER(q, width); + } if (vectorize) { if (vectorarg) { @@ -9055,9 +8239,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV is_utf8 = TRUE; } if (args) { - vecsv = va_arg(*args, SV*); - vecstr = (U8*)SvPV_const(vecsv,veclen); - vec_utf8 = DO_UTF8(vecsv); + VECTORIZE_ARGS } else if (efix ? efix <= svmax : svix < svmax) { vecsv = svargs[efix ? efix-1 : svix++]; @@ -9071,7 +8253,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV { q++; /* skip past the rest of the %vd format */ eptr = (const char *) vecstr; - elen = strlen(eptr); + elen = veclen; vectorize=FALSE; goto string; } @@ -9241,21 +8423,6 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* INTEGERS */ case 'p': - if (left && args) { /* SVf */ - left = FALSE; - if (width) { - precis = width; - has_precis = TRUE; - width = 0; - } - if (vectorize) - goto unknown; - argsv = va_arg(*args, SV*); - eptr = SvPVx_const(argsv, elen); - if (DO_UTF8(argsv)) - is_utf8 = TRUE; - goto string; - } if (alt || vectorize) goto unknown; uv = PTR2UV(args ? va_arg(*args, void*) : argsv); @@ -9271,6 +8438,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* FALL THROUGH */ case 'd': case 'i': +#if vdNUMBER + format_vd: +#endif if (vectorize) { STRLEN ulen; if (!veclen) @@ -9423,6 +8593,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV *--ptr = '0'; break; case 2: + if (!uv) + alt = FALSE; do { dig = uv & 1; *--ptr = '0' + dig; @@ -9587,7 +8759,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (PL_efloatsize < need) { Safefree(PL_efloatbuf); PL_efloatsize = need + 20; /* more fudge */ - New(906, PL_efloatbuf, PL_efloatsize, char); + Newx(PL_efloatbuf, PL_efloatsize, char); PL_efloatbuf[0] = '\0'; } @@ -9597,8 +8769,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV aka precis is 0 */ if ( c == 'g' && precis) { Gconvert((NV)nv, (int)precis, 0, PL_efloatbuf); - if (*PL_efloatbuf) /* May return an empty string for digits==0 */ + /* May return an empty string for digits==0 */ + if (*PL_efloatbuf) { + elen = strlen(PL_efloatbuf); goto float_converted; + } } else if ( c == 'f' && !precis) { if ((eptr = F0convert(nv, ebuf + sizeof ebuf, &elen))) break; @@ -9642,17 +8817,15 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV * where printf() taints but print($float) doesn't. * --jhi */ #if defined(HAS_LONG_DOUBLE) - if (intsize == 'q') - (void)sprintf(PL_efloatbuf, ptr, nv); - else - (void)sprintf(PL_efloatbuf, ptr, (double)nv); + elen = ((intsize == 'q') + ? my_sprintf(PL_efloatbuf, ptr, nv) + : my_sprintf(PL_efloatbuf, ptr, (double)nv)); #else - (void)sprintf(PL_efloatbuf, ptr, nv); + elen = my_sprintf(PL_efloatbuf, ptr, nv); #endif } float_converted: eptr = PL_efloatbuf; - elen = strlen(PL_efloatbuf); break; /* SPECIAL */ @@ -9679,9 +8852,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: unknown: - if (!args && ckWARN(WARN_PRINTF) && - (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) { - SV *msg = sv_newmortal(); + if (!args + && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF) + && ckWARN(WARN_PRINTF)) + { + SV * const msg = sv_newmortal(); Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", (PL_op->op_type == OP_PRTF) ? "" : "s"); if (c) { @@ -9716,6 +8891,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* calculate width before utf8_upgrade changes it */ have = esignlen + zeros + elen; +#ifdef PERL_MALLOC_WRAP + if (have < zeros) + Perl_croak_nocontext(PL_memory_wrap); +#endif if (is_utf8 != has_utf8) { if (is_utf8) { @@ -9736,6 +8915,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV need = (have > width ? have : width); gap = need - have; +#ifdef PERL_MALLOC_WRAP + if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1)) + Perl_croak_nocontext(PL_memory_wrap); +#endif SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); p = SvEND(sv); if (esignlen && fill == '0') { @@ -9845,15 +9028,15 @@ Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param) len = r->offsets[0]; npar = r->nparens+1; - Newc(0, ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp); + Newxc(ret, sizeof(regexp) + (len+1)*sizeof(regnode), char, regexp); Copy(r->program, ret->program, len+1, regnode); - New(0, ret->startp, npar, I32); + Newx(ret->startp, npar, I32); Copy(r->startp, ret->startp, npar, I32); - New(0, ret->endp, npar, I32); + Newx(ret->endp, npar, I32); Copy(r->startp, ret->startp, npar, I32); - New(0, ret->substrs, 1, struct reg_substr_data); + Newx(ret->substrs, 1, struct reg_substr_data); for (s = ret->substrs->data, i = 0; i < 3; i++, s++) { s->min_offset = r->substrs->data[i].min_offset; s->max_offset = r->substrs->data[i].max_offset; @@ -9867,9 +9050,9 @@ Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param) const int count = r->data->count; int i; - Newc(0, d, sizeof(struct reg_data) + count*sizeof(void *), + Newxc(d, sizeof(struct reg_data) + count*sizeof(void *), char, struct reg_data); - New(0, d->what, count, U8); + Newx(d->what, count, U8); d->count = count; for (i = 0; i < count; i++) { @@ -9885,7 +9068,7 @@ Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param) break; case 'f': /* This is cheating. */ - New(0, d->data[i], 1, struct regnode_charclass_class); + Newx(d->data[i], 1, struct regnode_charclass_class); StructCopy(r->data->data[i], d->data[i], struct regnode_charclass_class); ret->regstclass = (regnode*)d->data[i]; @@ -9916,7 +9099,7 @@ Perl_re_dup(pTHX_ const REGEXP *r, CLONE_PARAMS *param) else ret->data = NULL; - New(0, ret->offsets, 2*len+1, U32); + Newx(ret->offsets, 2*len+1, U32); Copy(r->offsets, ret->offsets, 2*len+1, U32); ret->precomp = SAVEPVN(r->precomp, r->prelen); @@ -9990,7 +9173,7 @@ Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param) return ret; /* create anew and remember what it is */ - Newz(0, ret, 1, GP); + Newxz(ret, 1, GP); ptr_table_store(PL_ptr_table, gp, ret); /* clone */ @@ -10003,7 +9186,6 @@ Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param) ret->gp_egv = gv_dup(gp->gp_egv, param);/* GvEGV is not refcounted */ ret->gp_cv = cv_dup_inc(gp->gp_cv, param); ret->gp_cvgen = gp->gp_cvgen; - ret->gp_flags = gp->gp_flags; ret->gp_line = gp->gp_line; ret->gp_file = gp->gp_file; /* points to COP.cop_file */ return ret; @@ -10025,7 +9207,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) for (; mg; mg = mg->mg_moremagic) { MAGIC *nmg; - Newz(0, nmg, 1, MAGIC); + Newxz(nmg, 1, MAGIC); if (mgprev) mgprev->mg_moremagic = nmg; else @@ -10064,8 +9246,8 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) if (mg->mg_type == PERL_MAGIC_overload_table && AMT_AMAGIC((AMT*)mg->mg_ptr)) { - AMT *amtp = (AMT*)mg->mg_ptr; - AMT *namtp = (AMT*)nmg->mg_ptr; + AMT * const amtp = (AMT*)mg->mg_ptr; + AMT * const namtp = (AMT*)nmg->mg_ptr; I32 i; for (i = 1; i < NofAMmeth; i++) { namtp->table[i] = cv_dup_inc(amtp->table[i], param); @@ -10089,10 +9271,10 @@ PTR_TBL_t * Perl_ptr_table_new(pTHX) { PTR_TBL_t *tbl; - Newz(0, tbl, 1, PTR_TBL_t); + Newxz(tbl, 1, PTR_TBL_t); tbl->tbl_max = 511; tbl->tbl_items = 0; - Newz(0, tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); + Newxz(tbl->tbl_ary, tbl->tbl_max + 1, PTR_TBL_ENT_t*); return tbl; } @@ -10102,8 +9284,13 @@ Perl_ptr_table_new(pTHX) # define PTR_TABLE_HASH(ptr) (PTR2UV(ptr) >> 2) #endif -#define new_pte() new_body(struct ptr_tbl_ent, pte) -#define del_pte(p) del_body_type(p, struct ptr_tbl_ent, pte) +/* + we use the PTE_SVSLOT 'reservation' made above, both here (in the + following define) and at call to new_body_inline made below in + Perl_ptr_table_store() + */ + +#define del_pte(p) del_body_type(p, PTE_SVSLOT) /* map an existing pointer using a table */ @@ -10124,26 +9311,26 @@ Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv) /* add a new entry to a pointer-mapping table */ void -Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldv, void *newv) +Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv) { PTR_TBL_ENT_t *tblent, **otblent; /* XXX this may be pessimal on platforms where pointers aren't good * hash values e.g. if they grow faster in the most significant * bits */ - const UV hash = PTR_TABLE_HASH(oldv); + const UV hash = PTR_TABLE_HASH(oldsv); bool empty = 1; assert(tbl); otblent = &tbl->tbl_ary[hash & tbl->tbl_max]; for (tblent = *otblent; tblent; empty=0, tblent = tblent->next) { - if (tblent->oldval == oldv) { - tblent->newval = newv; + if (tblent->oldval == oldsv) { + tblent->newval = newsv; return; } } - tblent = new_pte(); - tblent->oldval = oldv; - tblent->newval = newv; + new_body_inline(tblent, sizeof(struct ptr_tbl_ent), PTE_SVSLOT); + tblent->oldval = oldsv; + tblent->newval = newsv; tblent->next = *otblent; *otblent = tblent; tbl->tbl_items++; @@ -10299,8 +9486,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) if(SvTYPE(sstr) == SVt_PVHV && (hvname = HvNAME_get(sstr))) { /** don't clone stashes if they already exist **/ - HV* old_stash = gv_stashpv(hvname,0); - return (SV*) old_stash; + return (SV*)gv_stashpv(hvname,0); } } @@ -10358,113 +9544,55 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) default: { /* These are all the types that need complex bodies allocating. */ - size_t new_body_length; - size_t new_body_offset = 0; - void **new_body_arena; - void **new_body_arenaroot; void *new_body; + const svtype sv_type = SvTYPE(sstr); + const struct body_details *const sv_type_details + = bodies_by_type + sv_type; - switch (SvTYPE(sstr)) { + switch (sv_type) { default: Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr)); break; + case SVt_PVGV: + if (GvUNIQUE((GV*)sstr)) { + /* Do sharing here, and fall through */ + } case SVt_PVIO: - new_body = new_XPVIO(); - new_body_length = sizeof(XPVIO); - break; case SVt_PVFM: - new_body = new_XPVFM(); - new_body_length = sizeof(XPVFM); - break; - case SVt_PVHV: - new_body_arena = (void **) &PL_xpvhv_root; - new_body_arenaroot = (void **) &PL_xpvhv_arenaroot; - new_body_offset = STRUCT_OFFSET(XPVHV, xhv_fill) - - STRUCT_OFFSET(xpvhv_allocated, xhv_fill); - new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash) - + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash) - - new_body_offset; - goto new_body; case SVt_PVAV: - new_body_arena = (void **) &PL_xpvav_root; - new_body_arenaroot = (void **) &PL_xpvav_arenaroot; - new_body_offset = STRUCT_OFFSET(XPVAV, xav_fill) - - STRUCT_OFFSET(xpvav_allocated, xav_fill); - new_body_length = STRUCT_OFFSET(XPVHV, xmg_stash) - + sizeof (((XPVHV*)SvANY(sstr))->xmg_stash) - - new_body_offset; - goto new_body; case SVt_PVBM: - new_body_length = sizeof(XPVBM); - new_body_arena = (void **) &PL_xpvbm_root; - new_body_arenaroot = (void **) &PL_xpvbm_arenaroot; - goto new_body; - case SVt_PVGV: - if (GvUNIQUE((GV*)sstr)) { - /* Do sharing here. */ - } - new_body_length = sizeof(XPVGV); - new_body_arena = (void **) &PL_xpvgv_root; - new_body_arenaroot = (void **) &PL_xpvgv_arenaroot; - goto new_body; case SVt_PVCV: - new_body_length = sizeof(XPVCV); - new_body_arena = (void **) &PL_xpvcv_root; - new_body_arenaroot = (void **) &PL_xpvcv_arenaroot; - goto new_body; case SVt_PVLV: - new_body_length = sizeof(XPVLV); - new_body_arena = (void **) &PL_xpvlv_root; - new_body_arenaroot = (void **) &PL_xpvlv_arenaroot; - goto new_body; case SVt_PVMG: - new_body_length = sizeof(XPVMG); - new_body_arena = (void **) &PL_xpvmg_root; - new_body_arenaroot = (void **) &PL_xpvmg_arenaroot; - goto new_body; case SVt_PVNV: - new_body_length = sizeof(XPVNV); - new_body_arena = (void **) &PL_xpvnv_root; - new_body_arenaroot = (void **) &PL_xpvnv_arenaroot; - goto new_body; case SVt_PVIV: - new_body_offset = STRUCT_OFFSET(XPVIV, xpv_cur) - - STRUCT_OFFSET(xpviv_allocated, xpv_cur); - new_body_length = sizeof(XPVIV) - new_body_offset; - new_body_arena = (void **) &PL_xpviv_root; - new_body_arenaroot = (void **) &PL_xpviv_arenaroot; - goto new_body; case SVt_PV: - new_body_offset = STRUCT_OFFSET(XPV, xpv_cur) - - STRUCT_OFFSET(xpv_allocated, xpv_cur); - new_body_length = sizeof(XPV) - new_body_offset; - new_body_arena = (void **) &PL_xpv_root; - new_body_arenaroot = (void **) &PL_xpv_arenaroot; - new_body: - assert(new_body_length); -#ifndef PURIFY - new_body = (void*)((char*)S_new_body(aTHX_ new_body_arenaroot, - new_body_arena, - new_body_length) - - new_body_offset); -#else - /* We always allocated the full length item with PURIFY */ - new_body_length += new_body_offset; - new_body_offset = 0; - new_body = my_safemalloc(new_body_length); -#endif + assert(sv_type_details->copy); + if (sv_type_details->arena) { + new_body_inline(new_body, sv_type_details->copy, sv_type); + new_body + = (void*)((char*)new_body - sv_type_details->offset); + } else { + new_body = new_NOARENA(sv_type_details); + } } assert(new_body); SvANY(dstr) = new_body; - Copy(((char*)SvANY(sstr)) + new_body_offset, - ((char*)SvANY(dstr)) + new_body_offset, - new_body_length, char); +#ifndef PURIFY + Copy(((char*)SvANY(sstr)) + sv_type_details->offset, + ((char*)SvANY(dstr)) + sv_type_details->offset, + sv_type_details->copy, char); +#else + Copy(((char*)SvANY(sstr)), + ((char*)SvANY(dstr)), + sv_type_details->size + sv_type_details->offset, char); +#endif - if (SvTYPE(sstr) != SVt_PVAV && SvTYPE(sstr) != SVt_PVHV) + if (sv_type != SVt_PVAV && sv_type != SVt_PVHV) Perl_rvpv_dup(aTHX_ dstr, sstr, param); /* The Copy above means that all the source (unduplicated) pointers @@ -10472,14 +9600,15 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) pointers in either, but it's possible that there's less cache missing by always going for the destination. FIXME - instrument and check that assumption */ - if (SvTYPE(sstr) >= SVt_PVMG) { + if (sv_type >= SVt_PVMG) { if (SvMAGIC(dstr)) SvMAGIC_set(dstr, mg_dup(SvMAGIC(dstr), param)); if (SvSTASH(dstr)) SvSTASH_set(dstr, hv_dup_inc(SvSTASH(dstr), param)); } - switch (SvTYPE(sstr)) { + /* The cast silences a GCC warning about unhandled types. */ + switch ((int)sv_type) { case SVt_PV: break; case SVt_PVIV: @@ -10538,7 +9667,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) SSize_t items = AvFILLp((AV*)sstr) + 1; src_ary = AvARRAY((AV*)sstr); - Newz(0, dst_ary, AvMAX((AV*)sstr)+1, SV*); + Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*); ptr_table_store(PL_ptr_table, src_ary, dst_ary); SvPV_set(dstr, (char*)dst_ary); AvALLOC((AV*)dstr) = dst_ary; @@ -10570,13 +9699,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) XPVHV * const dxhv = (XPVHV*)SvANY(dstr); XPVHV * const sxhv = (XPVHV*)SvANY(sstr); char *darray; - New(0, darray, - PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) + Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) + (SvOOK(sstr) ? sizeof(struct xpvhv_aux) : 0), char); HvARRAY(dstr) = (HE**)darray; while (i <= sxhv->xhv_max) { - HE *source = HvARRAY(sstr)[i]; + const HE *source = HvARRAY(sstr)[i]; HvARRAY(dstr)[i] = source ? he_dup(source, sharekeys, param) : 0; ++i; @@ -10659,7 +9787,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) return ncxs; /* create anew and remember what it is */ - Newz(56, ncxs, max + 1, PERL_CONTEXT); + Newxz(ncxs, max + 1, PERL_CONTEXT); ptr_table_store(PL_ptr_table, cxs, ncxs); while (ix >= 0) { @@ -10749,7 +9877,7 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) return nsi; /* create anew and remember what it is */ - Newz(56, nsi, 1, PERL_SI); + Newxz(nsi, 1, PERL_SI); ptr_table_store(PL_ptr_table, si, nsi); nsi->si_stack = av_dup_inc(si->si_stack, param); @@ -10833,7 +9961,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) void (*dptr) (void*); void (*dxptr) (pTHX_ void*); - Newz(54, nss, max, ANY); + Newxz(nss, max, ANY); while (ix > 0) { I32 i = POPINT(ss,ix); @@ -11257,35 +10385,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, param->flags = flags; param->proto_perl = proto_perl; - /* arena roots */ - PL_xnv_arenaroot = NULL; - PL_xnv_root = NULL; - PL_xpv_arenaroot = NULL; - PL_xpv_root = NULL; - PL_xpviv_arenaroot = NULL; - PL_xpviv_root = NULL; - PL_xpvnv_arenaroot = NULL; - PL_xpvnv_root = NULL; - PL_xpvcv_arenaroot = NULL; - PL_xpvcv_root = NULL; - PL_xpvav_arenaroot = NULL; - PL_xpvav_root = NULL; - PL_xpvhv_arenaroot = NULL; - PL_xpvhv_root = NULL; - PL_xpvmg_arenaroot = NULL; - PL_xpvmg_root = NULL; - PL_xpvgv_arenaroot = NULL; - PL_xpvgv_root = NULL; - PL_xpvlv_arenaroot = NULL; - PL_xpvlv_root = NULL; - PL_xpvbm_arenaroot = NULL; - PL_xpvbm_root = NULL; - PL_he_arenaroot = NULL; - PL_he_root = NULL; -#if defined(USE_ITHREADS) - PL_pte_arenaroot = NULL; - PL_pte_root = NULL; -#endif + Zero(&PL_body_arenaroots, 1, PL_body_arenaroots); + Zero(&PL_body_roots, 1, PL_body_roots); + PL_nice_chunk = NULL; PL_nice_chunk_size = 0; PL_sv_count = 0; @@ -11365,6 +10467,10 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, param->stashes = newAV(); /* Setup array of objects to call clone on */ + /* Set tainting stuff before PerlIO_debug can possibly get called */ + PL_tainting = proto_perl->Itainting; + PL_taint_warn = proto_perl->Itaint_warn; + #ifdef PERLIO_LAYERS /* Clone PerlIO tables as soon as we can handle general xx_dup() */ PerlIO_clone(aTHX_ proto_perl, param); @@ -11409,6 +10515,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_statusvalue = proto_perl->Istatusvalue; #ifdef VMS PL_statusvalue_vms = proto_perl->Istatusvalue_vms; +#else + PL_statusvalue_posix = proto_perl->Istatusvalue_posix; #endif PL_encoding = sv_dup(proto_perl->Iencoding, param); @@ -11486,8 +10594,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); /* internal state */ - PL_tainting = proto_perl->Itainting; - PL_taint_warn = proto_perl->Itaint_warn; PL_maxo = proto_perl->Imaxo; if (proto_perl->Iop_mask) PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); @@ -11523,7 +10629,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* interpreter atexit processing */ PL_exitlistlen = proto_perl->Iexitlistlen; if (PL_exitlistlen) { - New(0, PL_exitlist, PL_exitlistlen, PerlExitListEntry); + Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry); Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); } else @@ -11561,7 +10667,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_evalseq = proto_perl->Ievalseq; PL_origenviron = proto_perl->Iorigenviron; /* XXX not quite right */ PL_origalen = proto_perl->Iorigalen; +#ifdef PERL_USES_PL_PIDSTATUS PL_pidstatus = newHV(); /* XXX flag for cloning? */ +#endif PL_osname = SAVEPV(proto_perl->Iosname); PL_sighandlerp = proto_perl->Isighandlerp; @@ -11740,15 +10848,15 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_bitcount = Nullch; /* reinits on demand */ if (proto_perl->Ipsig_pend) { - Newz(0, PL_psig_pend, SIG_SIZE, int); + Newxz(PL_psig_pend, SIG_SIZE, int); } else { PL_psig_pend = (int*)NULL; } if (proto_perl->Ipsig_ptr) { - Newz(0, PL_psig_ptr, SIG_SIZE, SV*); - Newz(0, PL_psig_name, SIG_SIZE, SV*); + Newxz(PL_psig_ptr, SIG_SIZE, SV*); + Newxz(PL_psig_name, SIG_SIZE, SV*); for (i = 1; i < SIG_SIZE; i++) { PL_psig_ptr[i] = sv_dup_inc(proto_perl->Ipsig_ptr[i], param); PL_psig_name[i] = sv_dup_inc(proto_perl->Ipsig_name[i], param); @@ -11766,7 +10874,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_tmps_ix = proto_perl->Ttmps_ix; PL_tmps_max = proto_perl->Ttmps_max; PL_tmps_floor = proto_perl->Ttmps_floor; - Newz(50, PL_tmps_stack, PL_tmps_max, SV*); + Newxz(PL_tmps_stack, PL_tmps_max, SV*); i = 0; while (i <= PL_tmps_ix) { PL_tmps_stack[i] = sv_dup_inc(proto_perl->Ttmps_stack[i], param); @@ -11775,7 +10883,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ i = proto_perl->Tmarkstack_max - proto_perl->Tmarkstack; - Newz(54, PL_markstack, i, I32); + Newxz(PL_markstack, i, I32); PL_markstack_max = PL_markstack + (proto_perl->Tmarkstack_max - proto_perl->Tmarkstack); PL_markstack_ptr = PL_markstack + (proto_perl->Tmarkstack_ptr @@ -11787,7 +10895,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * NOTE: unlike the others! */ PL_scopestack_ix = proto_perl->Tscopestack_ix; PL_scopestack_max = proto_perl->Tscopestack_max; - Newz(54, PL_scopestack, PL_scopestack_max, I32); + Newxz(PL_scopestack, PL_scopestack_max, I32); Copy(proto_perl->Tscopestack, PL_scopestack, PL_scopestack_ix, I32); /* NOTE: si_dup() looks at PL_markstack */ @@ -11807,7 +10915,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * NOTE: unlike the others! */ PL_savestack_ix = proto_perl->Tsavestack_ix; PL_savestack_max = proto_perl->Tsavestack_max; - /*Newz(54, PL_savestack, PL_savestack_max, ANY);*/ + /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ PL_savestack = ss_dup(proto_perl, param); } else { @@ -11859,7 +10967,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_sortstash = hv_dup(proto_perl->Tsortstash, param); PL_firstgv = gv_dup(proto_perl->Tfirstgv, param); PL_secondgv = gv_dup(proto_perl->Tsecondgv, param); - PL_sortcxix = proto_perl->Tsortcxix; PL_efloatbuf = Nullch; /* reinits on demand */ PL_efloatsize = 0; /* reinits on demand */ @@ -12077,6 +11184,480 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, else Perl_croak(aTHX_ "Invalid argument to sv_cat_decode"); return ret; + +} + +/* --------------------------------------------------------------------- + * + * support functions for report_uninit() + */ + +/* the maxiumum size of array or hash where we will scan looking + * for the undefined element that triggered the warning */ + +#define FUV_MAX_SEARCH_SIZE 1000 + +/* Look for an entry in the hash whose value has the same SV as val; + * If so, return a mortal copy of the key. */ + +STATIC SV* +S_find_hash_subscript(pTHX_ HV *hv, SV* val) +{ + dVAR; + register HE **array; + I32 i; + + if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) || + (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) + return Nullsv; + + array = HvARRAY(hv); + + for (i=HvMAX(hv); i>0; i--) { + register HE *entry; + for (entry = array[i]; entry; entry = HeNEXT(entry)) { + if (HeVAL(entry) != val) + continue; + if ( HeVAL(entry) == &PL_sv_undef || + HeVAL(entry) == &PL_sv_placeholder) + continue; + if (!HeKEY(entry)) + return Nullsv; + if (HeKLEN(entry) == HEf_SVKEY) + return sv_mortalcopy(HeKEY_sv(entry)); + return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry))); + } + } + return Nullsv; +} + +/* Look for an entry in the array whose value has the same SV as val; + * If so, return the index, otherwise return -1. */ + +STATIC I32 +S_find_array_subscript(pTHX_ AV *av, SV* val) +{ + SV** svp; + I32 i; + if (!av || SvMAGICAL(av) || !AvARRAY(av) || + (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) + return -1; + + svp = AvARRAY(av); + for (i=AvFILLp(av); i>=0; i--) { + if (svp[i] == val && svp[i] != &PL_sv_undef) + return i; + } + return -1; +} + +/* S_varname(): return the name of a variable, optionally with a subscript. + * If gv is non-zero, use the name of that global, along with gvtype (one + * of "$", "@", "%"); otherwise use the name of the lexical at pad offset + * targ. Depending on the value of the subscript_type flag, return: + */ + +#define FUV_SUBSCRIPT_NONE 1 /* "@foo" */ +#define FUV_SUBSCRIPT_ARRAY 2 /* "$foo[aindex]" */ +#define FUV_SUBSCRIPT_HASH 3 /* "$foo{keyname}" */ +#define FUV_SUBSCRIPT_WITHIN 4 /* "within @foo" */ + +STATIC SV* +S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, + SV* keyname, I32 aindex, int subscript_type) +{ + + SV * const name = sv_newmortal(); + if (gv) { + char buffer[2]; + buffer[0] = gvtype; + buffer[1] = 0; + + /* as gv_fullname4(), but add literal '^' for $^FOO names */ + + gv_fullname4(name, gv, buffer, 0); + + if ((unsigned int)SvPVX(name)[1] <= 26) { + buffer[0] = '^'; + buffer[1] = SvPVX(name)[1] + 'A' - 1; + + /* Swap the 1 unprintable control character for the 2 byte pretty + version - ie substr($name, 1, 1) = $buffer; */ + sv_insert(name, 1, 1, buffer, 2); + } + } + else { + U32 unused; + CV * const cv = find_runcv(&unused); + SV *sv; + AV *av; + + if (!cv || !CvPADLIST(cv)) + return Nullsv; + av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE)); + sv = *av_fetch(av, targ, FALSE); + /* SvLEN in a pad name is not to be trusted */ + sv_setpv(name, SvPV_nolen_const(sv)); + } + + if (subscript_type == FUV_SUBSCRIPT_HASH) { + SV * const sv = NEWSV(0,0); + *SvPVX(name) = '$'; + Perl_sv_catpvf(aTHX_ name, "{%s}", + pv_display(sv,SvPVX_const(keyname), SvCUR(keyname), 0, 32)); + SvREFCNT_dec(sv); + } + else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { + *SvPVX(name) = '$'; + Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex); + } + else if (subscript_type == FUV_SUBSCRIPT_WITHIN) + sv_insert(name, 0, 0, "within ", 7); + + return name; +} + + +/* +=for apidoc find_uninit_var + +Find the name of the undefined variable (if any) that caused the operator o +to issue a "Use of uninitialized value" warning. +If match is true, only return a name if it's value matches uninit_sv. +So roughly speaking, if a unary operator (such as OP_COS) generates a +warning, then following the direct child of the op may yield an +OP_PADSV or OP_GV that gives the name of the undefined variable. On the +other hand, with OP_ADD there are two branches to follow, so we only print +the variable name if we get an exact match. + +The name is returned as a mortal SV. + +Assumes that PL_op is the op that originally triggered the error, and that +PL_comppad/PL_curpad points to the currently executing pad. + +=cut +*/ + +STATIC SV * +S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) +{ + dVAR; + SV *sv; + AV *av; + GV *gv; + OP *o, *o2, *kid; + + if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || + uninit_sv == &PL_sv_placeholder))) + return Nullsv; + + switch (obase->op_type) { + + case OP_RV2AV: + case OP_RV2HV: + case OP_PADAV: + case OP_PADHV: + { + const bool pad = (obase->op_type == OP_PADAV || obase->op_type == OP_PADHV); + const bool hash = (obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV); + I32 index = 0; + SV *keysv = Nullsv; + int subscript_type = FUV_SUBSCRIPT_WITHIN; + + if (pad) { /* @lex, %lex */ + sv = PAD_SVl(obase->op_targ); + gv = Nullgv; + } + else { + if (cUNOPx(obase)->op_first->op_type == OP_GV) { + /* @global, %global */ + gv = cGVOPx_gv(cUNOPx(obase)->op_first); + if (!gv) + break; + sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv); + } + else /* @{expr}, %{expr} */ + return find_uninit_var(cUNOPx(obase)->op_first, + uninit_sv, match); + } + + /* attempt to find a match within the aggregate */ + if (hash) { + keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv); + if (keysv) + subscript_type = FUV_SUBSCRIPT_HASH; + } + else { + index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); + if (index >= 0) + subscript_type = FUV_SUBSCRIPT_ARRAY; + } + + if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) + break; + + return varname(gv, hash ? '%' : '@', obase->op_targ, + keysv, index, subscript_type); + } + + case OP_PADSV: + if (match && PAD_SVl(obase->op_targ) != uninit_sv) + break; + return varname(Nullgv, '$', obase->op_targ, + Nullsv, 0, FUV_SUBSCRIPT_NONE); + + case OP_GVSV: + gv = cGVOPx_gv(obase); + if (!gv || (match && GvSV(gv) != uninit_sv)) + break; + return varname(gv, '$', 0, Nullsv, 0, FUV_SUBSCRIPT_NONE); + + case OP_AELEMFAST: + if (obase->op_flags & OPf_SPECIAL) { /* lexical array */ + if (match) { + SV **svp; + av = (AV*)PAD_SV(obase->op_targ); + if (!av || SvRMAGICAL(av)) + break; + svp = av_fetch(av, (I32)obase->op_private, FALSE); + if (!svp || *svp != uninit_sv) + break; + } + return varname(Nullgv, '$', obase->op_targ, + Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); + } + else { + gv = cGVOPx_gv(obase); + if (!gv) + break; + if (match) { + SV **svp; + av = GvAV(gv); + if (!av || SvRMAGICAL(av)) + break; + svp = av_fetch(av, (I32)obase->op_private, FALSE); + if (!svp || *svp != uninit_sv) + break; + } + return varname(gv, '$', 0, + Nullsv, (I32)obase->op_private, FUV_SUBSCRIPT_ARRAY); + } + break; + + case OP_EXISTS: + o = cUNOPx(obase)->op_first; + if (!o || o->op_type != OP_NULL || + ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM)) + break; + return find_uninit_var(cBINOPo->op_last, uninit_sv, match); + + case OP_AELEM: + case OP_HELEM: + if (PL_op == obase) + /* $a[uninit_expr] or $h{uninit_expr} */ + return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match); + + gv = Nullgv; + o = cBINOPx(obase)->op_first; + kid = cBINOPx(obase)->op_last; + + /* get the av or hv, and optionally the gv */ + sv = Nullsv; + if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) { + sv = PAD_SV(o->op_targ); + } + else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) + && cUNOPo->op_first->op_type == OP_GV) + { + gv = cGVOPx_gv(cUNOPo->op_first); + if (!gv) + break; + sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv); + } + if (!sv) + break; + + if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) { + /* index is constant */ + if (match) { + if (SvMAGICAL(sv)) + break; + if (obase->op_type == OP_HELEM) { + HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0); + if (!he || HeVAL(he) != uninit_sv) + break; + } + else { + SV ** const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE); + if (!svp || *svp != uninit_sv) + break; + } + } + if (obase->op_type == OP_HELEM) + return varname(gv, '%', o->op_targ, + cSVOPx_sv(kid), 0, FUV_SUBSCRIPT_HASH); + else + return varname(gv, '@', o->op_targ, Nullsv, + SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY); + ; + } + else { + /* index is an expression; + * attempt to find a match within the aggregate */ + if (obase->op_type == OP_HELEM) { + SV * const keysv = S_find_hash_subscript(aTHX_ (HV*)sv, uninit_sv); + if (keysv) + return varname(gv, '%', o->op_targ, + keysv, 0, FUV_SUBSCRIPT_HASH); + } + else { + const I32 index = S_find_array_subscript(aTHX_ (AV*)sv, uninit_sv); + if (index >= 0) + return varname(gv, '@', o->op_targ, + Nullsv, index, FUV_SUBSCRIPT_ARRAY); + } + if (match) + break; + return varname(gv, + (o->op_type == OP_PADAV || o->op_type == OP_RV2AV) + ? '@' : '%', + o->op_targ, Nullsv, 0, FUV_SUBSCRIPT_WITHIN); + } + + break; + + case OP_AASSIGN: + /* only examine RHS */ + return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match); + + case OP_OPEN: + o = cUNOPx(obase)->op_first; + if (o->op_type == OP_PUSHMARK) + o = o->op_sibling; + + if (!o->op_sibling) { + /* one-arg version of open is highly magical */ + + if (o->op_type == OP_GV) { /* open FOO; */ + gv = cGVOPx_gv(o); + if (match && GvSV(gv) != uninit_sv) + break; + return varname(gv, '$', 0, + Nullsv, 0, FUV_SUBSCRIPT_NONE); + } + /* other possibilities not handled are: + * open $x; or open my $x; should return '${*$x}' + * open expr; should return '$'.expr ideally + */ + break; + } + goto do_op; + + /* ops where $_ may be an implicit arg */ + case OP_TRANS: + case OP_SUBST: + case OP_MATCH: + if ( !(obase->op_flags & OPf_STACKED)) { + if (uninit_sv == ((obase->op_private & OPpTARGET_MY) + ? PAD_SVl(obase->op_targ) + : DEFSV)) + { + sv = sv_newmortal(); + sv_setpvn(sv, "$_", 2); + return sv; + } + } + goto do_op; + + case OP_PRTF: + case OP_PRINT: + /* skip filehandle as it can't produce 'undef' warning */ + o = cUNOPx(obase)->op_first; + if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK) + o = o->op_sibling->op_sibling; + goto do_op2; + + + case OP_RV2SV: + case OP_CUSTOM: + case OP_ENTERSUB: + match = 1; /* XS or custom code could trigger random warnings */ + goto do_op; + + case OP_SCHOMP: + case OP_CHOMP: + if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) + return sv_2mortal(newSVpvn("${$/}", 5)); + /* FALL THROUGH */ + + default: + do_op: + if (!(obase->op_flags & OPf_KIDS)) + break; + o = cUNOPx(obase)->op_first; + + do_op2: + if (!o) + break; + + /* if all except one arg are constant, or have no side-effects, + * or are optimized away, then it's unambiguous */ + o2 = Nullop; + for (kid=o; kid; kid = kid->op_sibling) { + if (kid && + ( (kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) + || (kid->op_type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) + || (kid->op_type == OP_PUSHMARK) + ) + ) + continue; + if (o2) { /* more than one found */ + o2 = Nullop; + break; + } + o2 = kid; + } + if (o2) + return find_uninit_var(o2, uninit_sv, match); + + /* scan all args */ + while (o) { + sv = find_uninit_var(o, uninit_sv, 1); + if (sv) + return sv; + o = o->op_sibling; + } + break; + } + return Nullsv; +} + + +/* +=for apidoc report_uninit + +Print appropriate "Use of uninitialized variable" warning + +=cut +*/ + +void +Perl_report_uninit(pTHX_ SV* uninit_sv) +{ + if (PL_op) { + SV* varname = Nullsv; + if (uninit_sv) { + varname = find_uninit_var(PL_op, uninit_sv,0); + if (varname) + sv_insert(varname, 0, 0, " ", 1); + } + Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, + varname ? SvPV_nolen_const(varname) : "", + " in ", OP_DESC(PL_op)); + } + else + Perl_warner(aTHX_ packWARN(WARN_UNINITIALIZED), PL_warn_uninit, + "", "", ""); } /*