X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/fe5bfecd71ca735f83568f7bc2b9f22cc82e3d61..2547c837a73d50421f898a78d070bf820ac97f12:/sv.c diff --git a/sv.c b/sv.c index e431cff..0d6939f 100644 --- a/sv.c +++ b/sv.c @@ -1,12 +1,22 @@ /* sv.c * - * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, - * 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2007, by Larry Wall and others + * Copyright (C) 1991, 1992, 1993, 1994, 1995, 1996, 1997, 1998, 1999, 2000, + * 2001, 2002, 2003, 2004, 2005, 2006, 2007, 2008, 2009 by Larry Wall + * and others * * You may distribute under the terms of either the GNU General Public * License or the Artistic License, as specified in the README file. * - * "I wonder what the Entish is for 'yes' and 'no'," he thought. + */ + +/* + * 'I wonder what the Entish is for "yes" and "no",' he thought. + * --Pippin + * + * [p.480 of _The Lord of the Rings_, III/iv: "Treebeard"] + */ + +/* * * * This file contains the code that creates, manipulates and destroys @@ -154,11 +164,14 @@ Public API: */ void -Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) +Perl_offer_nice_chunk(pTHX_ void *const chunk, const U32 chunk_size) { dVAR; void *new_chunk; U32 new_chunk_size; + + PERL_ARGS_ASSERT_OFFER_NICE_CHUNK; + new_chunk = (void *)(chunk); new_chunk_size = (chunk_size); if (new_chunk_size > PL_nice_chunk_size) { @@ -170,14 +183,29 @@ Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) } } +#ifdef PERL_MEM_LOG +# define MEM_LOG_NEW_SV(sv, file, line, func) \ + Perl_mem_log_new_sv(sv, file, line, func) +# define MEM_LOG_DEL_SV(sv, file, line, func) \ + Perl_mem_log_del_sv(sv, file, line, func) +#else +# define MEM_LOG_NEW_SV(sv, file, line, func) NOOP +# define MEM_LOG_DEL_SV(sv, file, line, func) NOOP +#endif + #ifdef DEBUG_LEAKING_SCALARS # define FREE_SV_DEBUG_FILE(sv) Safefree((sv)->sv_debug_file) +# define DEBUG_SV_SERIAL(sv) \ + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) del_SV\n", \ + PTR2UV(sv), (long)(sv)->sv_debug_serial)) #else # define FREE_SV_DEBUG_FILE(sv) +# define DEBUG_SV_SERIAL(sv) NOOP #endif #ifdef PERL_POISON # define SvARENA_CHAIN(sv) ((sv)->sv_u.svu_rv) +# define SvARENA_CHAIN_SET(sv,val) (sv)->sv_u.svu_rv = MUTABLE_SV((val)) /* Whilst I'd love to do this, it seems that things like to check on unreferenced scalars # define POSION_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) @@ -186,23 +214,36 @@ Perl_offer_nice_chunk(pTHX_ void *chunk, U32 chunk_size) PoisonNew(&SvREFCNT(sv), 1, U32) #else # define SvARENA_CHAIN(sv) SvANY(sv) +# define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val) # define POSION_SV_HEAD(sv) #endif +/* Mark an SV head as unused, and add to free list. + * + * If SVf_BREAK is set, skip adding it to the free list, as this SV had + * its refcount artificially decremented during global destruction, so + * there may be dangling pointers to it. The last thing we want in that + * case is for it to be reused. */ + #define plant_SV(p) \ STMT_START { \ + const U32 old_flags = SvFLAGS(p); \ + MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \ + DEBUG_SV_SERIAL(p); \ FREE_SV_DEBUG_FILE(p); \ POSION_SV_HEAD(p); \ - SvARENA_CHAIN(p) = (void *)PL_sv_root; \ SvFLAGS(p) = SVTYPEMASK; \ - PL_sv_root = (p); \ + if (!(old_flags & SVf_BREAK)) { \ + SvARENA_CHAIN_SET(p, PL_sv_root); \ + PL_sv_root = (p); \ + } \ --PL_sv_count; \ } STMT_END #define uproot_SV(p) \ STMT_START { \ (p) = PL_sv_root; \ - PL_sv_root = (SV*)SvARENA_CHAIN(p); \ + PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ ++PL_sv_count; \ } STMT_END @@ -234,7 +275,7 @@ S_more_sv(pTHX) #ifdef DEBUG_LEAKING_SCALARS /* provide a real function for a debugger to play with */ STATIC SV* -S_new_SV(pTHX) +S_new_SV(pTHX_ const char *file, int line, const char *func) { SV* sv; @@ -246,20 +287,25 @@ S_new_SV(pTHX) SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; - sv->sv_debug_line = (U16) (PL_parser - ? PL_parser->copline == NOLINE - ? PL_curcop + sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE + ? PL_parser->copline + : PL_curcop ? CopLINE(PL_curcop) : 0 - : PL_parser->copline - : 0); + ); sv->sv_debug_inpad = 0; sv->sv_debug_cloned = 0; sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; - + + sv->sv_debug_serial = PL_sv_serial++; + + MEM_LOG_NEW_SV(sv, file, line, func); + DEBUG_m(PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) new_SV (from %s:%d [%s])\n", + PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); + return sv; } -# define new_SV(p) (p)=S_new_SV(aTHX) +# define new_SV(p) (p)=S_new_SV(aTHX_ __FILE__, __LINE__, FUNCTION__) #else # define new_SV(p) \ @@ -271,6 +317,7 @@ S_new_SV(pTHX) SvANY(p) = 0; \ SvREFCNT(p) = 1; \ SvFLAGS(p) = 0; \ + MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ } STMT_END #endif @@ -291,10 +338,13 @@ STATIC void S_del_sv(pTHX_ SV *p) { dVAR; + + PERL_ARGS_ASSERT_DEL_SV; + if (DEBUG_D_TEST) { SV* sva; bool ok = 0; - for (sva = PL_sv_arenaroot; sva; sva = (SV *) SvANY(sva)) { + for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { const SV * const sv = sva + 1; const SV * const svend = &sva[SvREFCNT(sva)]; if (p >= sv && p < svend) { @@ -331,14 +381,16 @@ and split it into a list of free SVs. =cut */ -void -Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) +static void +S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) { dVAR; - SV* const sva = (SV*)ptr; + SV *const sva = MUTABLE_SV(ptr); register SV* sv; register SV* svend; + PERL_ARGS_ASSERT_SV_ADD_ARENA; + /* The first SV in an arena isn't an SV. */ SvANY(sva) = (void *) PL_sv_arenaroot; /* ptr to next arena */ SvREFCNT(sva) = size / sizeof(SV); /* number of SV slots */ @@ -350,16 +402,16 @@ Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) svend = &sva[SvREFCNT(sva) - 1]; sv = sva + 1; while (sv < svend) { - SvARENA_CHAIN(sv) = (void *)(SV*)(sv + 1); + SvARENA_CHAIN_SET(sv, (sv + 1)); #ifdef DEBUGGING SvREFCNT(sv) = 0; #endif - /* Must always set typemask because it's awlays checked in on cleanup + /* Must always set typemask because it's always checked in on cleanup when the arenas are walked looking for objects. */ SvFLAGS(sv) = SVTYPEMASK; sv++; } - SvARENA_CHAIN(sv) = 0; + SvARENA_CHAIN_SET(sv, 0); #ifdef DEBUGGING SvREFCNT(sv) = 0; #endif @@ -370,13 +422,15 @@ Perl_sv_add_arena(pTHX_ char *ptr, U32 size, U32 flags) * whose flags field matches the flags/mask args. */ STATIC I32 -S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask) +S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) { dVAR; SV* sva; I32 visited = 0; - for (sva = PL_sv_arenaroot; sva; sva = (SV*)SvANY(sva)) { + PERL_ARGS_ASSERT_VISIT; + + for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { register const SV * const svend = &sva[SvREFCNT(sva)]; register SV* sv; for (sv = sva + 1; sv < svend; ++sv) { @@ -397,7 +451,7 @@ S_visit(pTHX_ SVFUNC_t f, U32 flags, U32 mask) /* called by sv_report_used() for each live SV */ static void -do_report_used(pTHX_ SV *sv) +do_report_used(pTHX_ SV *const sv) { if (SvTYPE(sv) != SVTYPEMASK) { PerlIO_printf(Perl_debug_log, "****\n"); @@ -427,7 +481,7 @@ Perl_sv_report_used(pTHX) /* called by sv_clean_objs() for each live SV */ static void -do_clean_objs(pTHX_ SV *ref) +do_clean_objs(pTHX_ SV *const ref) { dVAR; assert (SvROK(ref)); @@ -454,7 +508,7 @@ do_clean_objs(pTHX_ SV *ref) #ifndef DISABLE_DESTRUCTOR_KLUDGE static void -do_clean_named_objs(pTHX_ SV *sv) +do_clean_named_objs(pTHX_ SV *const sv) { dVAR; assert(SvTYPE(sv) == SVt_PVGV); @@ -503,9 +557,13 @@ Perl_sv_clean_objs(pTHX) /* called by sv_clean_all() for each live SV */ static void -do_clean_all(pTHX_ SV *sv) +do_clean_all(pTHX_ SV *const sv) { dVAR; + if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) { + /* don't clean pid table and strtab */ + return; + } DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%"UVxf"\n", PTR2UV(sv)) )); SvFLAGS(sv) |= SVf_BREAK; SvREFCNT_dec(sv); @@ -544,7 +602,8 @@ Perl_sv_clean_all(pTHX) memory in the last arena-set (1/2 on average). In trade, we get back the 1st slot in each arena (ie 1.7% of a CV-arena, less for smaller types). The recovery of the wasted space allows use of - small arenas for large, rare body types, + small arenas for large, rare body types, by changing array* fields + in body_details_by_type[] below. */ struct arena_desc { char *arena; /* the raw storage, allocated aligned */ @@ -555,7 +614,7 @@ struct arena_desc { struct arena_set; /* Get the maximum number of elements in set[] such that struct arena_set - will fit within PERL_ARENA_SIZE, which is probabably just under 4K, and + will fit within PERL_ARENA_SIZE, which is probably just under 4K, and therefore likely to be 1 aligned memory page. */ #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \ @@ -588,9 +647,9 @@ Perl_sv_free_arenas(pTHX) contiguity of the fake ones with the corresponding real ones.) */ for (sva = PL_sv_arenaroot; sva; sva = svanext) { - svanext = (SV*) SvANY(sva); + svanext = MUTABLE_SV(SvANY(sva)); while (svanext && SvFAKE(svanext)) - svanext = (SV*) SvANY(svanext); + svanext = MUTABLE_SV(SvANY(svanext)); if (!SvFAKE(sva)) Safefree(sva); @@ -662,7 +721,7 @@ Perl_sv_free_arenas(pTHX) TBD: export properly for hv.c: S_more_he(). */ void* -Perl_get_arena(pTHX_ size_t arena_size, U32 misc) +Perl_get_arena(pTHX_ const size_t arena_size, const U32 misc) { dVAR; struct arena_desc* adesc; @@ -868,7 +927,7 @@ struct xpv { #define copy_length(type, last_member) \ STRUCT_OFFSET(type, last_member) \ - + sizeof (((type*)SvANY((SV*)0))->last_member) + + sizeof (((type*)SvANY((const SV *)0))->last_member) static const struct body_details bodies_by_type[] = { { sizeof(HE), 0, 0, SVt_NULL, @@ -893,9 +952,6 @@ static const struct body_details bodies_by_type[] = { { sizeof(NV), sizeof(NV), 0, SVt_NV, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(NV)) }, - /* RVs are in the head now. */ - { 0, 0, 0, SVt_RV, FALSE, NONV, NOARENA, 0 }, - /* 8 bytes on most ILP32 with IEEE doubles */ { sizeof(xpv_allocated), copy_length(XPV, xpv_len) @@ -917,7 +973,14 @@ static const struct body_details bodies_by_type[] = { /* 28 */ { sizeof(XPVMG), copy_length(XPVMG, xmg_stash), 0, SVt_PVMG, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, - + + /* something big */ + { sizeof(struct regexp_allocated), sizeof(struct regexp_allocated), + + relative_STRUCT_OFFSET(struct regexp_allocated, regexp, xpv_cur), + SVt_REGEXP, FALSE, NONV, HASARENA, + FIT_ARENA(0, sizeof(struct regexp_allocated)) + }, + /* 48 */ { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, @@ -948,8 +1011,9 @@ static const struct body_details bodies_by_type[] = { SVt_PVFM, TRUE, NONV, NOARENA, FIT_ARENA(20, sizeof(xpvfm_allocated)) }, /* XPVIO is 84 bytes, fits 48x */ - { sizeof(XPVIO), sizeof(XPVIO), 0, SVt_PVIO, TRUE, HADNV, - HASARENA, FIT_ARENA(24, sizeof(XPVIO)) }, + { sizeof(xpvio_allocated), sizeof(xpvio_allocated), + + relative_STRUCT_OFFSET(xpvio_allocated, XPVIO, xpv_cur), + SVt_PVIO, TRUE, NONV, HASARENA, FIT_ARENA(24, sizeof(xpvio_allocated)) }, }; #define new_body_type(sv_type) \ @@ -1021,7 +1085,7 @@ static const struct body_details bodies_by_type[] = { my_safecalloc((details)->body_size + (details)->offset) STATIC void * -S_more_bodies (pTHX_ svtype sv_type) +S_more_bodies (pTHX_ const svtype sv_type) { dVAR; void ** const root = &PL_body_roots[sv_type]; @@ -1029,6 +1093,7 @@ S_more_bodies (pTHX_ svtype sv_type) const size_t body_size = bdp->body_size; char *start; const char *end; + const size_t arena_size = Perl_malloc_good_size(bdp->arena_size); #if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT_PRIVATE) static bool done_sanity_check; @@ -1046,20 +1111,28 @@ S_more_bodies (pTHX_ svtype sv_type) assert(bdp->arena_size); - start = (char*) Perl_get_arena(aTHX_ bdp->arena_size, sv_type); + start = (char*) Perl_get_arena(aTHX_ arena_size, sv_type); - end = start + bdp->arena_size - body_size; + end = start + arena_size - 2 * body_size; /* computed count doesnt reflect the 1st slot reservation */ +#if defined(MYMALLOC) || defined(HAS_MALLOC_GOOD_SIZE) + DEBUG_m(PerlIO_printf(Perl_debug_log, + "arena %p end %p arena-size %d (from %d) type %d " + "size %d ct %d\n", + (void*)start, (void*)end, (int)arena_size, + (int)bdp->arena_size, sv_type, (int)body_size, + (int)arena_size / (int)body_size)); +#else DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %p end %p arena-size %d type %d size %d ct %d\n", (void*)start, (void*)end, (int)bdp->arena_size, sv_type, (int)body_size, (int)bdp->arena_size / (int)body_size)); - +#endif *root = (void *)start; - while (start < end) { + while (start <= end) { char * const next = start + body_size; *(void**) start = (void *)next; start = next; @@ -1084,7 +1157,7 @@ S_more_bodies (pTHX_ svtype sv_type) #ifndef PURIFY STATIC void * -S_new_body(pTHX_ svtype sv_type) +S_new_body(pTHX_ const svtype sv_type) { dVAR; void *xpv; @@ -1094,6 +1167,9 @@ S_new_body(pTHX_ svtype sv_type) #endif +static const struct body_details fake_rv = + { 0, 0, 0, SVt_IV, FALSE, NONV, NOARENA, 0 }; + /* =for apidoc sv_upgrade @@ -1105,15 +1181,18 @@ You generally want to use the C macro wrapper. See also C. */ void -Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) +Perl_sv_upgrade(pTHX_ register SV *const sv, svtype new_type) { dVAR; void* old_body; void* new_body; const svtype old_type = SvTYPE(sv); const struct body_details *new_type_details; - const struct body_details *const old_type_details + const struct body_details *old_type_details = bodies_by_type + old_type; + SV *referant = NULL; + + PERL_ARGS_ASSERT_SV_UPGRADE; if (new_type != SVt_PV && SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); @@ -1122,11 +1201,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) if (old_type == new_type) return; - if (old_type > new_type) - Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", - (int)old_type, (int)new_type); - - old_body = SvANY(sv); /* Copying structures onto other structures that have been neatly zeroed @@ -1171,9 +1245,16 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) case SVt_NULL: break; case SVt_IV: - if (new_type < SVt_PVIV) { - new_type = (new_type == SVt_NV) - ? SVt_PVNV : SVt_PVIV; + if (SvROK(sv)) { + referant = SvRV(sv); + old_type_details = &fake_rv; + if (new_type == SVt_NV) + new_type = SVt_PVNV; + } else { + if (new_type < SVt_PVIV) { + new_type = (new_type == SVt_NV) + ? SVt_PVNV : SVt_PVIV; + } } break; case SVt_NV: @@ -1181,8 +1262,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) new_type = SVt_PVNV; } break; - case SVt_RV: - break; case SVt_PV: assert(new_type > SVt_PV); assert(SVt_IV < SVt_PV); @@ -1207,6 +1286,11 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf, sv_reftype(sv, 0), (UV) old_type, (UV) new_type); } + + if (old_type > new_type) + Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", + (int)old_type, (int)new_type); + new_type_details = bodies_by_type + new_type; SvFLAGS(sv) &= ~SVTYPEMASK; @@ -1226,11 +1310,6 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) SvANY(sv) = new_XNV(); SvNV_set(sv, 0); return; - case SVt_RV: - assert(old_type == SVt_NULL); - SvANY(sv) = &sv->sv_u.svu_rv; - SvRV_set(sv, 0); - return; case SVt_PVHV: case SVt_PVAV: assert(new_type_details->body_size); @@ -1252,13 +1331,36 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) AvMAX(sv) = -1; AvFILLp(sv) = -1; AvREAL_only(sv); + if (old_type_details->body_size) { + AvALLOC(sv) = 0; + } else { + /* It will have been zeroed when the new body was allocated. + Lets not write to it, in case it confuses a write-back + cache. */ + } + } else { + assert(!SvOK(sv)); + SvOK_off(sv); +#ifndef NODEFAULT_SHAREKEYS + HvSHAREKEYS_on(sv); /* key-sharing on by default */ +#endif + HvMAX(sv) = 7; /* (start with 8 buckets) */ + if (old_type_details->body_size) { + HvFILL(sv) = 0; + } else { + /* It will have been zeroed when the new body was allocated. + Lets not write to it, in case it confuses a write-back + cache. */ + } } /* SVt_NULL isn't the only thing upgraded to AV or HV. The target created by newSVrv also is, and it can have magic. However, it never has SvPVX set. */ - if (old_type >= SVt_RV) { + if (old_type == SVt_IV) { + assert(!SvROK(sv)); + } else if (old_type >= SVt_PV) { assert(SvPVX_const(sv) == 0); } @@ -1281,6 +1383,7 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) case SVt_PVGV: case SVt_PVCV: case SVt_PVLV: + case SVt_REGEXP: case SVt_PVMG: case SVt_PVNV: case SVt_PV: @@ -1329,8 +1432,11 @@ Perl_sv_upgrade(pTHX_ register SV *sv, svtype new_type) if (new_type == SVt_PVIO) IoPAGE_LEN(sv) = 60; - if (old_type < SVt_RV) - SvPV_set(sv, NULL); + if (old_type < SVt_PV) { + /* referant will be NULL unless the old type was SVt_IV emulating + SVt_RV */ + sv->sv_u.svu_rv = referant; + } break; default: Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", @@ -1361,19 +1467,23 @@ wrapper instead. */ int -Perl_sv_backoff(pTHX_ register SV *sv) +Perl_sv_backoff(pTHX_ register SV *const sv) { + STRLEN delta; + const char * const s = SvPVX_const(sv); + + PERL_ARGS_ASSERT_SV_BACKOFF; PERL_UNUSED_CONTEXT; + assert(SvOOK(sv)); assert(SvTYPE(sv) != SVt_PVHV); assert(SvTYPE(sv) != SVt_PVAV); - if (SvIVX(sv)) { - const char * const s = SvPVX_const(sv); - SvLEN_set(sv, SvLEN(sv) + SvIVX(sv)); - SvPV_set(sv, SvPVX(sv) - SvIVX(sv)); - SvIV_set(sv, 0); - Move(s, SvPVX(sv), SvCUR(sv)+1, char); - } + + SvOOK_offset(sv, delta); + + SvLEN_set(sv, SvLEN(sv) + delta); + SvPV_set(sv, SvPVX(sv) - delta); + Move(s, SvPVX(sv), SvCUR(sv)+1, char); SvFLAGS(sv) &= ~SVf_OOK; return 0; } @@ -1389,10 +1499,12 @@ Use the C wrapper instead. */ char * -Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) +Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen) { register char *s; + PERL_ARGS_ASSERT_SV_GROW; + if (PL_madskills && newlen >= 0x100000) { PerlIO_printf(Perl_debug_log, "Allocation too large: %"UVxf"\n", (UV)newlen); @@ -1424,15 +1536,10 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) s = SvPVX_mutable(sv); if (newlen > SvLEN(sv)) { /* need more room? */ +#ifndef Perl_safesysmalloc_size newlen = PERL_STRLEN_ROUNDUP(newlen); - if (SvLEN(sv) && s) { -#ifdef MYMALLOC - const STRLEN l = malloced_size((void*)SvPVX_const(sv)); - if (newlen <= l) { - SvLEN_set(sv, l); - return s; - } else #endif + if (SvLEN(sv) && s) { s = (char*)saferealloc(s, newlen); } else { @@ -1442,7 +1549,14 @@ Perl_sv_grow(pTHX_ register SV *sv, register STRLEN newlen) } } SvPV_set(sv, s); +#ifdef Perl_safesysmalloc_size + /* Do this here, do it once, do it right, and then we will never get + called back into sv_grow() unless there really is some growing + needed. */ + SvLEN_set(sv, Perl_safesysmalloc_size(s)); +#else SvLEN_set(sv, newlen); +#endif } return s; } @@ -1457,23 +1571,25 @@ Does not handle 'set' magic. See also C. */ void -Perl_sv_setiv(pTHX_ register SV *sv, IV i) +Perl_sv_setiv(pTHX_ register SV *const sv, const IV i) { dVAR; + + PERL_ARGS_ASSERT_SV_SETIV; + SV_CHECK_THINKFIRST_COW_DROP(sv); switch (SvTYPE(sv)) { case SVt_NULL: - sv_upgrade(sv, SVt_IV); - break; case SVt_NV: - sv_upgrade(sv, SVt_PVNV); + sv_upgrade(sv, SVt_IV); break; - case SVt_RV: case SVt_PV: sv_upgrade(sv, SVt_PVIV); break; case SVt_PVGV: + if (!isGV_with_GP(sv)) + break; case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -1497,8 +1613,10 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_setiv_mg(pTHX_ register SV *sv, IV i) +Perl_sv_setiv_mg(pTHX_ register SV *const sv, const IV i) { + PERL_ARGS_ASSERT_SV_SETIV_MG; + sv_setiv(sv,i); SvSETMAGIC(sv); } @@ -1513,8 +1631,10 @@ Does not handle 'set' magic. See also C. */ void -Perl_sv_setuv(pTHX_ register SV *sv, UV u) +Perl_sv_setuv(pTHX_ register SV *const sv, const UV u) { + PERL_ARGS_ASSERT_SV_SETUV; + /* With these two if statements: u=1.49 s=0.52 cu=72.49 cs=10.64 scripts=270 tests=20865 @@ -1541,8 +1661,10 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_setuv_mg(pTHX_ register SV *sv, UV u) +Perl_sv_setuv_mg(pTHX_ register SV *const sv, const UV u) { + PERL_ARGS_ASSERT_SV_SETUV_MG; + sv_setuv(sv,u); SvSETMAGIC(sv); } @@ -1557,22 +1679,26 @@ Does not handle 'set' magic. See also C. */ void -Perl_sv_setnv(pTHX_ register SV *sv, NV num) +Perl_sv_setnv(pTHX_ register SV *const sv, const NV num) { dVAR; + + PERL_ARGS_ASSERT_SV_SETNV; + SV_CHECK_THINKFIRST_COW_DROP(sv); switch (SvTYPE(sv)) { case SVt_NULL: case SVt_IV: sv_upgrade(sv, SVt_NV); break; - case SVt_RV: case SVt_PV: case SVt_PVIV: sv_upgrade(sv, SVt_PVNV); break; case SVt_PVGV: + if (!isGV_with_GP(sv)) + break; case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -1596,8 +1722,10 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) +Perl_sv_setnv_mg(pTHX_ register SV *const sv, const NV num) { + PERL_ARGS_ASSERT_SV_SETNV_MG; + sv_setnv(sv,num); SvSETMAGIC(sv); } @@ -1607,15 +1735,17 @@ Perl_sv_setnv_mg(pTHX_ register SV *sv, NV num) */ STATIC void -S_not_a_number(pTHX_ SV *sv) +S_not_a_number(pTHX_ SV *const sv) { dVAR; SV *dsv; char tmpbuf[64]; const char *pv; + PERL_ARGS_ASSERT_NOT_A_NUMBER; + if (DO_UTF8(sv)) { - dsv = sv_2mortal(newSVpvs("")); + dsv = newSVpvs_flags("", SVs_TEMP); pv = sv_uni_display(dsv, sv, 10, 0); } else { char *d = tmpbuf; @@ -1688,11 +1818,13 @@ non-numeric warning), even if your atof() doesn't grok them. */ I32 -Perl_looks_like_number(pTHX_ SV *sv) +Perl_looks_like_number(pTHX_ SV *const sv) { register const char *sbegin; STRLEN len; + PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER; + if (SvPOK(sv)) { sbegin = SvPVX_const(sv); len = SvCUR(sv); @@ -1710,6 +1842,8 @@ S_glob_2number(pTHX_ GV * const gv) const U32 wasfake = SvFLAGS(gv) & SVf_FAKE; SV *const buffer = sv_newmortal(); + PERL_ARGS_ASSERT_GLOB_2NUMBER; + /* FAKE globs can get coerced, so need to turn this off temporarily if it is on. */ SvFAKE_off(gv); @@ -1731,6 +1865,8 @@ S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len) const U32 wasfake = SvFLAGS(gv) & SVf_FAKE; SV *const buffer = sv_newmortal(); + PERL_ARGS_ASSERT_GLOB_2PV; + /* FAKE globs can get coerced, so need to turn this off temporarily if it is on. */ SvFAKE_off(gv); @@ -1829,10 +1965,16 @@ S_glob_2pv(pTHX_ GV * const gv, STRLEN * const len) /* For sv_2nv these three cases are "SvNOK and don't bother casting" */ STATIC int -S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) +S_sv_2iuv_non_preserve(pTHX_ register SV *const sv +# ifdef DEBUGGING + , I32 numtype +# endif + ) { dVAR; - PERL_UNUSED_ARG(numtype); /* Used only under DEBUGGING? */ + + PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE; + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_2iuv_non '%s', IV=0x%"UVxf" NV=%"NVgf" inttype=%"UVXf"\n", SvPVX_const(sv), SvIVX(sv), SvNVX(sv), (UV)numtype)); if (SvNVX(sv) < (NV)IV_MIN) { (void)SvIOKp_on(sv); @@ -1878,8 +2020,12 @@ S_sv_2iuv_non_preserve(pTHX_ register SV *sv, I32 numtype) #endif /* !NV_PRESERVES_UV*/ STATIC bool -S_sv_2iuv_common(pTHX_ SV *sv) { +S_sv_2iuv_common(pTHX_ SV *const sv) +{ dVAR; + + PERL_ARGS_ASSERT_SV_2IUV_COMMON; + if (SvNOKp(sv)) { /* erm. not sure. *should* never get NOKp (without NOK) from sv_2nv * without also getting a cached IV/UV from it at the same time @@ -1913,7 +2059,11 @@ S_sv_2iuv_common(pTHX_ SV *sv) { we're outside the range of NV integer precision */ #endif ) { - SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ + if (SvNOK(sv)) + SvIOK_on(sv); /* Can this go wrong with rounding? NWC */ + else { + /* scalar has trailing garbage, eg "42a" */ + } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%"UVxf" iv(%"NVgf" => %"IVdf") (precise)\n", PTR2UV(sv), @@ -1952,6 +2102,7 @@ S_sv_2iuv_common(pTHX_ SV *sv) { came from a (by definition imprecise) NV operation, and we're outside the range of NV integer precision */ #endif + && SvNOK(sv) ) SvIOK_on(sv); SvIsUV_on(sv); @@ -2105,15 +2256,25 @@ S_sv_2iuv_common(pTHX_ SV *sv) { 1 1 already read UV. so there's no point in sv_2iuv_non_preserve() attempting to use atol, strtol, strtoul etc. */ +# ifdef DEBUGGING sv_2iuv_non_preserve (sv, numtype); +# else + sv_2iuv_non_preserve (sv); +# endif } } #endif /* NV_PRESERVES_UV */ + /* It might be more code efficient to go through the entire logic above + and conditionally set with SvIOKp_on() rather than SvIOK(), but it + gets complex and potentially buggy, so more programmer efficient + to do it this way, by turning off the public flags: */ + if (!numtype) + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); } } else { if (isGV_with_GP(sv)) - return glob_2number((GV *)sv); + return glob_2number(MUTABLE_GV(sv)); if (!(SvFLAGS(sv) & SVs_PADTMP)) { if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) @@ -2139,7 +2300,7 @@ Normally used via the C and C macros. */ IV -Perl_sv_2iv_flags(pTHX_ register SV *sv, I32 flags) +Perl_sv_2iv_flags(pTHX_ register SV *const sv, const I32 flags) { dVAR; if (!sv) @@ -2223,7 +2384,7 @@ Normally used via the C and C macros. */ UV -Perl_sv_2uv_flags(pTHX_ register SV *sv, I32 flags) +Perl_sv_2uv_flags(pTHX_ register SV *const sv, const I32 flags) { dVAR; if (!sv) @@ -2300,7 +2461,7 @@ macros. */ NV -Perl_sv_2nv(pTHX_ register SV *sv) +Perl_sv_2nv(pTHX_ register SV *const sv) { dVAR; if (!sv) @@ -2377,11 +2538,15 @@ Perl_sv_2nv(pTHX_ register SV *sv) if (SvIOKp(sv)) { SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); #ifdef NV_PRESERVES_UV - SvNOK_on(sv); + if (SvIOK(sv)) + SvNOK_on(sv); + else + SvNOKp_on(sv); #else /* Only set the public NV OK flag if this NV preserves the IV */ /* Check it's not 0xFFFFFFFFFFFFFFFF */ - if (SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) + if (SvIOK(sv) && + SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) : (SvIVX(sv) == I_V(SvNVX(sv)))) SvNOK_on(sv); else @@ -2400,7 +2565,10 @@ Perl_sv_2nv(pTHX_ register SV *sv) SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); } else SvNV_set(sv, Atof(SvPVX_const(sv))); - SvNOK_on(sv); + if (numtype) + SvNOK_on(sv); + else + SvNOKp_on(sv); #else SvNV_set(sv, Atof(SvPVX_const(sv))); /* Only set the public NV OK flag if this NV preserves the value in @@ -2467,11 +2635,17 @@ Perl_sv_2nv(pTHX_ register SV *sv) } } } + /* It might be more code efficient to go through the entire logic above + and conditionally set with SvNOKp_on() rather than SvNOK(), but it + gets complex and potentially buggy, so more programmer efficient + to do it this way, by turning off the public flags: */ + if (!numtype) + SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); #endif /* NV_PRESERVES_UV */ } else { if (isGV_with_GP(sv)) { - glob_2number((GV *)sv); + glob_2number(MUTABLE_GV(sv)); return 0.0; } @@ -2501,6 +2675,31 @@ Perl_sv_2nv(pTHX_ register SV *sv) return SvNVX(sv); } +/* +=for apidoc sv_2num + +Return an SV with the numeric value of the source SV, doing any necessary +reference or overload conversion. You must use the C macro to +access this function. + +=cut +*/ + +SV * +Perl_sv_2num(pTHX_ register SV *const sv) +{ + PERL_ARGS_ASSERT_SV_2NUM; + + if (!SvROK(sv)) + return sv; + if (SvAMAGIC(sv)) { + SV * const tmpsv = AMG_CALLun(sv,numer); + if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) + return sv_2num(tmpsv); + } + return sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))); +} + /* 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. @@ -2509,12 +2708,14 @@ Perl_sv_2nv(pTHX_ register SV *sv) */ static char * -S_uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) +S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const peob) { char *ptr = buf + TYPE_CHARS(UV); char * const ebuf = ptr; int sign; + PERL_ARGS_ASSERT_UIV_2BUF; + if (is_uv) sign = 0; else if (iv >= 0) { @@ -2546,7 +2747,7 @@ usually end up here too. */ char * -Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) +Perl_sv_2pv_flags(pTHX_ register SV *const sv, STRLEN *const lp, const I32 flags) { dVAR; register char *s; @@ -2640,28 +2841,31 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) STRLEN len; char *retval; char *buffer; - MAGIC *mg; - const SV *const referent = (SV*)SvRV(sv); + SV *const referent = SvRV(sv); if (!referent) { len = 7; retval = buffer = savepvn("NULLREF", len); - } else if (SvTYPE(referent) == SVt_PVMG - && ((SvFLAGS(referent) & - (SVs_OBJECT|SVf_OK|SVs_GMG|SVs_SMG|SVs_RMG)) - == (SVs_OBJECT|SVs_SMG)) - && (mg = mg_find(referent, PERL_MAGIC_qr))) - { - char *str = NULL; - I32 haseval = 0; - U32 flags = 0; - (str) = CALLREG_AS_STR(mg,lp,&flags,&haseval); - if (flags & 1) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - PL_reginterp_cnt += haseval; - return str; + } else if (SvTYPE(referent) == SVt_REGEXP) { + REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); + I32 seen_evals = 0; + + assert(re); + + /* If the regex is UTF-8 we want the containing scalar to + have an UTF-8 flag too */ + if (RX_UTF8(re)) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + + if ((seen_evals = RX_SEEN_EVALS(re))) + PL_reginterp_cnt += seen_evals; + + if (lp) + *lp = RX_WRAPLEN(re); + + return RX_WRAPPED(re); } else { const char *const typestr = sv_reftype(referent, 0); const STRLEN typelen = strlen(typestr); @@ -2727,10 +2931,12 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } } if (SvREADONLY(sv) && !SvOK(sv)) { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); if (lp) *lp = 0; + if (flags & SV_UNDEF_RETURNS_NULL) + return NULL; + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); return (char *)""; } } @@ -2753,7 +2959,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) *s = '\0'; } else if (SvNOKp(sv)) { - const int olderrno = errno; + dSAVE_ERRNO; if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); /* The +20 is pure guesswork. Configure test needed. --jhi */ @@ -2767,10 +2973,12 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) { Gconvert(SvNVX(sv), NV_DIG, 0, s); } - errno = olderrno; + RESTORE_ERRNO; #ifdef FIXNEGATIVEZERO - if (*s == '-' && s[1] == '0' && !s[2]) - my_strlcpy(s, "0", SvLEN(s)); + if (*s == '-' && s[1] == '0' && !s[2]) { + s[0] = '0'; + s[1] = 0; + } #endif while (*s) s++; #ifdef hcx @@ -2780,12 +2988,14 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } else { if (isGV_with_GP(sv)) - return glob_2pv((GV *)sv, lp); + return glob_2pv(MUTABLE_GV(sv), lp); - if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); if (lp) *lp = 0; + if (flags & SV_UNDEF_RETURNS_NULL) + return NULL; + if (!PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP) && ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); if (SvTYPE(sv) < SVt_PV) /* Typically the caller expects that sv_any is not NULL now. */ sv_upgrade(sv, SVt_PV); @@ -2822,10 +3032,13 @@ would lose the UTF-8'ness of the PV. */ void -Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) +Perl_sv_copypv(pTHX_ SV *const dsv, register SV *const ssv) { STRLEN len; const char * const s = SvPV_const(ssv,len); + + PERL_ARGS_ASSERT_SV_COPYPV; + sv_setpvn(dsv,s,len); if (SvUTF8(ssv)) SvUTF8_on(dsv); @@ -2846,8 +3059,10 @@ Usually accessed via the C macro. */ char * -Perl_sv_2pvbyte(pTHX_ register SV *sv, STRLEN *lp) +Perl_sv_2pvbyte(pTHX_ register SV *const sv, STRLEN *const lp) { + PERL_ARGS_ASSERT_SV_2PVBYTE; + sv_utf8_downgrade(sv,0); return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); } @@ -2864,8 +3079,10 @@ Usually accessed via the C macro. */ char * -Perl_sv_2pvutf8(pTHX_ register SV *sv, STRLEN *lp) +Perl_sv_2pvutf8(pTHX_ register SV *const sv, STRLEN *const lp) { + PERL_ARGS_ASSERT_SV_2PVUTF8; + sv_utf8_upgrade(sv); return lp ? SvPV(sv,*lp) : SvPV_nolen(sv); } @@ -2881,9 +3098,12 @@ sv_true() or its macro equivalent. */ bool -Perl_sv_2bool(pTHX_ register SV *sv) +Perl_sv_2bool(pTHX_ register SV *const sv) { dVAR; + + PERL_ARGS_ASSERT_SV_2BOOL; + SvGETMAGIC(sv); if (!SvOK(sv)) @@ -2927,45 +3147,89 @@ Perl_sv_2bool(pTHX_ register SV *sv) Converts the PV of an SV to its UTF-8-encoded form. Forces the SV to string form if it is not already. +Will C on C if appropriate. Always sets the SvUTF8 flag to avoid future validity checks even -if all the bytes have hibit clear. +if the whole string is the same in UTF-8 as not. +Returns the number of bytes in the converted string This is not as a general purpose byte encoding to Unicode interface: use the Encode extension for that. +=for apidoc sv_utf8_upgrade_nomg + +Like sv_utf8_upgrade, but doesn't do magic on C + =for apidoc sv_utf8_upgrade_flags Converts the PV of an SV to its UTF-8-encoded form. Forces the SV to string form if it is not already. Always sets the SvUTF8 flag to avoid future validity checks even -if all the bytes have hibit clear. If C has C bit set, -will C on C if appropriate, else not. C and +if all the bytes are invariant in UTF-8. If C has C bit set, +will C on C if appropriate, else not. +Returns the number of bytes in the converted string +C and C are implemented in terms of this function. This is not as a general purpose byte encoding to Unicode interface: use the Encode extension for that. =cut + +The grow version is currently not externally documented. It adds a parameter, +extra, which is the number of unused bytes the string of 'sv' is guaranteed to +have free after it upon return. This allows the caller to reserve extra space +that it intends to fill, to avoid extra grows. + +Also externally undocumented for the moment is the flag SV_FORCE_UTF8_UPGRADE, +which can be used to tell this function to not first check to see if there are +any characters that are different in UTF-8 (variant characters) which would +force it to allocate a new string to sv, but to assume there are. Typically +this flag is used by a routine that has already parsed the string to find that +there are such characters, and passes this information on so that the work +doesn't have to be repeated. + +(One might think that the calling routine could pass in the position of the +first such variant, so it wouldn't have to be found again. But that is not the +case, because typically when the caller is likely to use this flag, it won't be +calling this routine unless it finds something that won't fit into a byte. +Otherwise it tries to not upgrade and just use bytes. But some things that +do fit into a byte are variants in utf8, and the caller may not have been +keeping track of these.) + +If the routine itself changes the string, it adds a trailing NUL. Such a NUL +isn't guaranteed due to having other routines do the work in some input cases, +or if the input is already flagged as being in utf8. + +The speed of this could perhaps be improved for many cases if someone wanted to +write a fast function that counts the number of variant characters in a string, +especially if it could return the position of the first one. + */ STRLEN -Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) +Perl_sv_utf8_upgrade_flags_grow(pTHX_ register SV *const sv, const I32 flags, STRLEN extra) { dVAR; + + PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW; + if (sv == &PL_sv_undef) return 0; if (!SvPOK(sv)) { STRLEN len = 0; if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { (void) sv_2pv_flags(sv,&len, flags); - if (SvUTF8(sv)) + if (SvUTF8(sv)) { + if (extra) SvGROW(sv, SvCUR(sv) + extra); return len; + } } else { (void) SvPV_force(sv,len); } } if (SvUTF8(sv)) { + if (extra) SvGROW(sv, SvCUR(sv) + extra); return SvCUR(sv); } @@ -2973,34 +3237,204 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) sv_force_normal_flags(sv, 0); } - if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) + if (PL_encoding && !(flags & SV_UTF8_NO_ENCODING)) { sv_recode_to_utf8(sv, PL_encoding); - else { /* Assume Latin-1/EBCDIC */ + if (extra) SvGROW(sv, SvCUR(sv) + extra); + return SvCUR(sv); + } + + if (SvCUR(sv) > 0) { /* Assume Latin-1/EBCDIC */ /* This function could be much more efficient if we - * had a FLAG in SVs to signal if there are any hibit + * had a FLAG in SVs to signal if there are any variant * chars in the PV. Given that there isn't such a flag - * make the loop as fast as possible. */ - const U8 * const s = (U8 *) SvPVX_const(sv); - const U8 * const e = (U8 *) SvEND(sv); - const U8 *t = s; + * make the loop as fast as possible (although there are certainly ways + * to speed this up, eg. through vectorization) */ + U8 * s = (U8 *) SvPVX_const(sv); + U8 * e = (U8 *) SvEND(sv); + U8 *t = s; + STRLEN two_byte_count = 0; + if (flags & SV_FORCE_UTF8_UPGRADE) goto must_be_utf8; + + /* See if really will need to convert to utf8. We mustn't rely on our + * incoming SV being well formed and having a trailing '\0', as certain + * code in pp_formline can send us partially built SVs. */ + while (t < e) { const U8 ch = *t++; - /* Check for hi bit */ - if (!NATIVE_IS_INVARIANT(ch)) { - STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */ - U8 * const recoded = bytes_to_utf8((U8*)s, &len); - - SvPV_free(sv); /* No longer using what was there before. */ - SvPV_set(sv, (char*)recoded); - SvCUR_set(sv, len - 1); - SvLEN_set(sv, len); /* No longer know the real size. */ - break; - } + if (NATIVE_IS_INVARIANT(ch)) continue; + + t--; /* t already incremented; re-point to first variant */ + two_byte_count = 1; + goto must_be_utf8; } - /* Mark as UTF-8 even if no hibit - saves scanning loop */ + + /* utf8 conversion not needed because all are invariants. Mark as + * UTF-8 even if no variant - saves scanning loop */ SvUTF8_on(sv); + return SvCUR(sv); + +must_be_utf8: + + /* Here, the string should be converted to utf8, either because of an + * input flag (two_byte_count = 0), or because a character that + * requires 2 bytes was found (two_byte_count = 1). t points either to + * the beginning of the string (if we didn't examine anything), or to + * the first variant. In either case, everything from s to t - 1 will + * occupy only 1 byte each on output. + * + * There are two main ways to convert. One is to create a new string + * and go through the input starting from the beginning, appending each + * converted value onto the new string as we go along. It's probably + * best to allocate enough space in the string for the worst possible + * case rather than possibly running out of space and having to + * reallocate and then copy what we've done so far. Since everything + * from s to t - 1 is invariant, the destination can be initialized + * with these using a fast memory copy + * + * The other way is to figure out exactly how big the string should be + * by parsing the entire input. Then you don't have to make it big + * enough to handle the worst possible case, and more importantly, if + * the string you already have is large enough, you don't have to + * allocate a new string, you can copy the last character in the input + * string to the final position(s) that will be occupied by the + * converted string and go backwards, stopping at t, since everything + * before that is invariant. + * + * There are advantages and disadvantages to each method. + * + * In the first method, we can allocate a new string, do the memory + * copy from the s to t - 1, and then proceed through the rest of the + * string byte-by-byte. + * + * In the second method, we proceed through the rest of the input + * string just calculating how big the converted string will be. Then + * there are two cases: + * 1) if the string has enough extra space to handle the converted + * value. We go backwards through the string, converting until we + * get to the position we are at now, and then stop. If this + * position is far enough along in the string, this method is + * faster than the other method. If the memory copy were the same + * speed as the byte-by-byte loop, that position would be about + * half-way, as at the half-way mark, parsing to the end and back + * is one complete string's parse, the same amount as starting + * over and going all the way through. Actually, it would be + * somewhat less than half-way, as it's faster to just count bytes + * than to also copy, and we don't have the overhead of allocating + * a new string, changing the scalar to use it, and freeing the + * existing one. But if the memory copy is fast, the break-even + * point is somewhere after half way. The counting loop could be + * sped up by vectorization, etc, to move the break-even point + * further towards the beginning. + * 2) if the string doesn't have enough space to handle the converted + * value. A new string will have to be allocated, and one might + * as well, given that, start from the beginning doing the first + * method. We've spent extra time parsing the string and in + * exchange all we've gotten is that we know precisely how big to + * make the new one. Perl is more optimized for time than space, + * so this case is a loser. + * So what I've decided to do is not use the 2nd method unless it is + * guaranteed that a new string won't have to be allocated, assuming + * the worst case. I also decided not to put any more conditions on it + * than this, for now. It seems likely that, since the worst case is + * twice as big as the unknown portion of the string (plus 1), we won't + * be guaranteed enough space, causing us to go to the first method, + * unless the string is short, or the first variant character is near + * the end of it. In either of these cases, it seems best to use the + * 2nd method. The only circumstance I can think of where this would + * be really slower is if the string had once had much more data in it + * than it does now, but there is still a substantial amount in it */ + + { + STRLEN invariant_head = t - s; + STRLEN size = invariant_head + (e - t) * 2 + 1 + extra; + if (SvLEN(sv) < size) { + + /* Here, have decided to allocate a new string */ + + U8 *dst; + U8 *d; + + Newx(dst, size, U8); + + /* If no known invariants at the beginning of the input string, + * set so starts from there. Otherwise, can use memory copy to + * get up to where we are now, and then start from here */ + + if (invariant_head <= 0) { + d = dst; + } else { + Copy(s, dst, invariant_head, char); + d = dst + invariant_head; + } + + while (t < e) { + const UV uv = NATIVE8_TO_UNI(*t++); + if (UNI_IS_INVARIANT(uv)) + *d++ = (U8)UNI_TO_NATIVE(uv); + else { + *d++ = (U8)UTF8_EIGHT_BIT_HI(uv); + *d++ = (U8)UTF8_EIGHT_BIT_LO(uv); + } + } + *d = '\0'; + SvPV_free(sv); /* No longer using pre-existing string */ + SvPV_set(sv, (char*)dst); + SvCUR_set(sv, d - dst); + SvLEN_set(sv, size); + } else { + + /* Here, have decided to get the exact size of the string. + * Currently this happens only when we know that there is + * guaranteed enough space to fit the converted string, so + * don't have to worry about growing. If two_byte_count is 0, + * then t points to the first byte of the string which hasn't + * been examined yet. Otherwise two_byte_count is 1, and t + * points to the first byte in the string that will expand to + * two. Depending on this, start examining at t or 1 after t. + * */ + + U8 *d = t + two_byte_count; + + + /* Count up the remaining bytes that expand to two */ + + while (d < e) { + const U8 chr = *d++; + if (! NATIVE_IS_INVARIANT(chr)) two_byte_count++; + } + + /* The string will expand by just the number of bytes that + * occupy two positions. But we are one afterwards because of + * the increment just above. This is the place to put the + * trailing NUL, and to set the length before we decrement */ + + d += two_byte_count; + SvCUR_set(sv, d - s); + *d-- = '\0'; + + + /* Having decremented d, it points to the position to put the + * very last byte of the expanded string. Go backwards through + * the string, copying and expanding as we go, stopping when we + * get to the part that is invariant the rest of the way down */ + + e--; + while (e >= t) { + const U8 ch = NATIVE8_TO_UNI(*e--); + if (UNI_IS_INVARIANT(ch)) { + *d-- = UNI_TO_NATIVE(ch); + } else { + *d-- = (U8)UTF8_EIGHT_BIT_LO(ch); + *d-- = (U8)UTF8_EIGHT_BIT_HI(ch); + } + } + } + } } + + /* Mark as UTF-8 even if no variant - saves scanning loop */ + SvUTF8_on(sv); return SvCUR(sv); } @@ -3008,7 +3442,8 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *sv, I32 flags) =for apidoc sv_utf8_downgrade Attempts to convert the PV of an SV from characters to bytes. -If the PV contains a character beyond byte, this conversion will fail; +If the PV contains a character that cannot fit +in a byte, this conversion will fail; in this case, either returns false or, if C is not true, croaks. @@ -3019,9 +3454,12 @@ use the Encode extension for that. */ bool -Perl_sv_utf8_downgrade(pTHX_ register SV* sv, bool fail_ok) +Perl_sv_utf8_downgrade(pTHX_ register SV *const sv, const bool fail_ok) { dVAR; + + PERL_ARGS_ASSERT_SV_UTF8_DOWNGRADE; + if (SvPOKp(sv) && SvUTF8(sv)) { if (SvCUR(sv)) { U8 *s; @@ -3059,13 +3497,15 @@ flag off so that it looks like octets again. */ void -Perl_sv_utf8_encode(pTHX_ register SV *sv) +Perl_sv_utf8_encode(pTHX_ register SV *const sv) { + PERL_ARGS_ASSERT_SV_UTF8_ENCODE; + if (SvIsCOW(sv)) { sv_force_normal_flags(sv, 0); } if (SvREADONLY(sv)) { - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } (void) sv_utf8_upgrade(sv); SvUTF8_off(sv); @@ -3084,8 +3524,10 @@ Scans PV for validity and returns false if the PV is invalid UTF-8. */ bool -Perl_sv_utf8_decode(pTHX_ register SV *sv) +Perl_sv_utf8_decode(pTHX_ register SV *const sv) { + PERL_ARGS_ASSERT_SV_UTF8_DECODE; + if (SvPOKp(sv)) { const U8 *c; const U8 *e; @@ -3150,10 +3592,12 @@ copy-ish functions and macros use this underneath. */ static void -S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) +S_glob_assign_glob(pTHX_ SV *const dstr, SV *const sstr, const int dtype) { I32 mro_changes = 0; /* 1 = method, 2 = isa */ + PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB; + if (dtype != SVt_PVGV) { const char * const name = GvNAME(sstr); const STRLEN len = GvNAMELEN(sstr); @@ -3172,18 +3616,18 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) } GvSTASH(dstr) = GvSTASH(sstr); if (GvSTASH(dstr)) - Perl_sv_add_backref(aTHX_ (SV*)GvSTASH(dstr), dstr); - gv_name_set((GV *)dstr, name, len, GV_ADD); + Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dstr)), dstr); + gv_name_set(MUTABLE_GV(dstr), name, len, GV_ADD); SvFAKE_on(dstr); /* can coerce to non-glob */ } #ifdef GV_UNIQUE_CHECK - if (GvUNIQUE((GV*)dstr)) { - Perl_croak(aTHX_ PL_no_modify); + if (GvUNIQUE((const GV *)dstr)) { + Perl_croak(aTHX_ "%s", PL_no_modify); } #endif - if(GvGP((GV*)sstr)) { + if(GvGP(MUTABLE_GV(sstr))) { /* If source has method cache entry, clear it */ if(GvCVGEN(sstr)) { SvREFCNT_dec(GvCV(sstr)); @@ -3192,20 +3636,20 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) } /* If source has a real method, then a method is going to change */ - else if(GvCV((GV*)sstr)) { + else if(GvCV((const GV *)sstr)) { mro_changes = 1; } } /* If dest already had a real method, that's a change as well */ - if(!mro_changes && GvGP((GV*)dstr) && GvCVu((GV*)dstr)) { + if(!mro_changes && GvGP(MUTABLE_GV(dstr)) && GvCVu((const GV *)dstr)) { mro_changes = 1; } - if(strEQ(GvNAME((GV*)dstr),"ISA")) + if(strEQ(GvNAME((const GV *)dstr),"ISA")) mro_changes = 2; - gp_free((GV*)dstr); + gp_free(MUTABLE_GV(dstr)); isGV_with_GP_off(dstr); (void)SvOK_off(dstr); isGV_with_GP_on(dstr); @@ -3225,7 +3669,8 @@ S_glob_assign_glob(pTHX_ SV *dstr, SV *sstr, const int dtype) } static void -S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { +S_glob_assign_ref(pTHX_ SV *const dstr, SV *const sstr) +{ SV * const sref = SvREFCNT_inc(SvRV(sstr)); SV *dref = NULL; const int intro = GvINTRO(dstr); @@ -3233,17 +3678,18 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { U8 import_flag = 0; const U32 stype = SvTYPE(sref); + PERL_ARGS_ASSERT_GLOB_ASSIGN_REF; #ifdef GV_UNIQUE_CHECK - if (GvUNIQUE((GV*)dstr)) { - Perl_croak(aTHX_ PL_no_modify); + if (GvUNIQUE((const GV *)dstr)) { + Perl_croak(aTHX_ "%s", PL_no_modify); } #endif if (intro) { GvINTRO_off(dstr); /* one-shot flag */ GvLINE(dstr) = CopLINE(PL_curcop); - GvEGV(dstr) = (GV*)dstr; + GvEGV(dstr) = MUTABLE_GV(dstr); } GvMULTI_on(dstr); switch (stype) { @@ -3270,7 +3716,7 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { common: if (intro) { if (stype == SVt_PVCV) { - /*if (GvCVGEN(dstr) && (GvCV(dstr) != (CV*)sref || GvCVGEN(dstr))) {*/ + /*if (GvCVGEN(dstr) && (GvCV(dstr) != (const CV *)sref || GvCVGEN(dstr))) {*/ if (GvCVGEN(dstr)) { SvREFCNT_dec(GvCV(dstr)); GvCV(dstr) = NULL; @@ -3282,15 +3728,16 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { else dref = *location; if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dstr))) { - CV* const cv = (CV*)*location; + CV* const cv = MUTABLE_CV(*location); if (cv) { - if (!GvCVGEN((GV*)dstr) && + if (!GvCVGEN((const GV *)dstr) && (CvROOT(cv) || CvXSUB(cv))) { /* Redefining a sub - warning is mandatory if it was a const and its value changed. */ - if (CvCONST(cv) && CvCONST((CV*)sref) - && cv_const_sv(cv) == cv_const_sv((CV*)sref)) { + if (CvCONST(cv) && CvCONST((const CV *)sref) + && cv_const_sv(cv) + == cv_const_sv((const CV *)sref)) { NOOP; /* They are 2 constant subroutines generated from the same constant. This probably means that @@ -3301,20 +3748,21 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { } else if (ckWARN(WARN_REDEFINE) || (CvCONST(cv) - && (!CvCONST((CV*)sref) + && (!CvCONST((const CV *)sref) || sv_cmp(cv_const_sv(cv), - cv_const_sv((CV*)sref))))) { + cv_const_sv((const CV *) + sref))))) { Perl_warner(aTHX_ packWARN(WARN_REDEFINE), (const char *) (CvCONST(cv) ? "Constant subroutine %s::%s redefined" : "Subroutine %s::%s redefined"), - HvNAME_get(GvSTASH((GV*)dstr)), - GvENAME((GV*)dstr)); + HvNAME_get(GvSTASH((const GV *)dstr)), + GvENAME(MUTABLE_GV(dstr))); } } if (!intro) - cv_ckproto_len(cv, (GV*)dstr, + cv_ckproto_len(cv, (const GV *)dstr, SvPOK(sref) ? SvPVX_const(sref) : NULL, SvPOK(sref) ? SvCUR(sref) : 0); } @@ -3336,13 +3784,15 @@ S_glob_assign_ref(pTHX_ SV *dstr, SV *sstr) { } void -Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) +Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) { dVAR; register U32 sflags; register int dtype; register svtype stype; + PERL_ARGS_ASSERT_SV_SETSV_FLAGS; + if (sstr == dstr) return; @@ -3365,7 +3815,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) { /* need to nuke the magic */ mg_free(dstr); - SvRMAGICAL_off(dstr); } /* There's a lot of redundancy below but we're going for speed here */ @@ -3385,7 +3834,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) sv_upgrade(dstr, SVt_IV); break; case SVt_NV: - case SVt_RV: case SVt_PV: sv_upgrade(dstr, SVt_PVIV); break; @@ -3403,7 +3851,11 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) assert(!SvTAINTED(sstr)); return; } - goto undef_sstr; + if (!SvROK(sstr)) + goto undef_sstr; + if (dtype < SVt_PV && dtype != SVt_IV) + sv_upgrade(dstr, SVt_IV); + break; case SVt_NV: if (SvNOK(sstr)) { @@ -3412,7 +3864,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) case SVt_IV: sv_upgrade(dstr, SVt_NV); break; - case SVt_RV: case SVt_PV: case SVt_PVIV: sv_upgrade(dstr, SVt_PVNV); @@ -3431,10 +3882,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } goto undef_sstr; - case SVt_RV: - if (dtype < SVt_RV) - sv_upgrade(dstr, SVt_RV); - break; case SVt_PVFM: #ifdef PERL_OLD_COPY_ON_WRITE if ((SvFLAGS(sstr) & CAN_COW_MASK) == CAN_COW_FLAGS) { @@ -3444,6 +3891,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } /* Fall through */ #endif + case SVt_REGEXP: case SVt_PV: if (dtype < SVt_PV) sv_upgrade(dstr, SVt_PV); @@ -3520,7 +3968,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) Perl_croak(aTHX_ "Cannot copy to %s", type); } else if (sflags & SVf_ROK) { if (isGV_with_GP(dstr) && dtype == SVt_PVGV - && SvTYPE(SvRV(sstr)) == SVt_PVGV) { + && SvTYPE(SvRV(sstr)) == SVt_PVGV && isGV_with_GP(SvRV(sstr))) { sstr = SvRV(sstr); if (sstr == dstr) { if (GvIMPORTED(dstr) != GVf_IMPORTED @@ -3536,7 +3984,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } if (dtype >= SVt_PV) { - if (dtype == SVt_PVGV) { + if (dtype == SVt_PVGV && isGV_with_GP(dstr)) { glob_assign_ref(dstr, sstr); return; } @@ -3562,9 +4010,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) } else { GV *gv = gv_fetchsv(sstr, GV_ADD, SVt_PVGV); - if (dstr != (SV*)gv) { + if (dstr != (const SV *)gv) { if (GvGP(dstr)) - gp_free((GV*)dstr); + gp_free(MUTABLE_GV(dstr)); GvGP(dstr) = gp_ref(GvGP(gv)); } } @@ -3717,7 +4165,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) SvNV_set(dstr, SvNVX(sstr)); } if (sflags & SVp_IOK) { - SvOOK_off(dstr); SvIV_set(dstr, SvIVX(sstr)); /* Must do this otherwise some other overloaded use of 0x80000000 gets confused. I guess SVpbm_VALID */ @@ -3754,7 +4201,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) /* FAKE globs can get coerced, so need to turn this off temporarily if it is on. */ SvFAKE_off(sstr); - gv_efullname3(dstr, (GV *)sstr, "*"); + gv_efullname3(dstr, MUTABLE_GV(sstr), "*"); SvFLAGS(sstr) |= wasfake; } else @@ -3773,8 +4220,10 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_setsv_mg(pTHX_ SV *dstr, register SV *sstr) +Perl_sv_setsv_mg(pTHX_ SV *const dstr, register SV *const sstr) { + PERL_ARGS_ASSERT_SV_SETSV_MG; + sv_setsv(dstr,sstr); SvSETMAGIC(dstr); } @@ -3787,6 +4236,8 @@ Perl_sv_setsv_cow(pTHX_ SV *dstr, SV *sstr) STRLEN len = SvLEN(sstr); register char *new_pv; + PERL_ARGS_ASSERT_SV_SETSV_COW; + if (DEBUG_C_TEST) { PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", (void*)sstr, (void*)dstr); @@ -3859,11 +4310,13 @@ undefined. Does not handle 'set' magic. See C. */ void -Perl_sv_setpvn(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) +Perl_sv_setpvn(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len) { dVAR; register char *dptr; + PERL_ARGS_ASSERT_SV_SETPVN; + SV_CHECK_THINKFIRST_COW_DROP(sv); if (!ptr) { (void)SvOK_off(sv); @@ -3894,8 +4347,10 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_setpvn_mg(pTHX_ register SV *sv, register const char *ptr, register STRLEN len) +Perl_sv_setpvn_mg(pTHX_ register SV *const sv, register const char *const ptr, register const STRLEN len) { + PERL_ARGS_ASSERT_SV_SETPVN_MG; + sv_setpvn(sv,ptr,len); SvSETMAGIC(sv); } @@ -3910,11 +4365,13 @@ handle 'set' magic. See C. */ void -Perl_sv_setpv(pTHX_ register SV *sv, register const char *ptr) +Perl_sv_setpv(pTHX_ register SV *const sv, register const char *const ptr) { dVAR; register STRLEN len; + PERL_ARGS_ASSERT_SV_SETPV; + SV_CHECK_THINKFIRST_COW_DROP(sv); if (!ptr) { (void)SvOK_off(sv); @@ -3939,8 +4396,10 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_setpv_mg(pTHX_ register SV *sv, register const char *ptr) +Perl_sv_setpv_mg(pTHX_ register SV *const sv, register const char *const ptr) { + PERL_ARGS_ASSERT_SV_SETPV_MG; + sv_setpv(sv,ptr); SvSETMAGIC(sv); } @@ -3966,10 +4425,13 @@ C, and already meets the requirements for storing in C) */ void -Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) +Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 flags) { dVAR; STRLEN allocate; + + PERL_ARGS_ASSERT_SV_USEPVN_FLAGS; + SV_CHECK_THINKFIRST_COW_DROP(sv); SvUPGRADE(sv, SVt_PV); if (!ptr) { @@ -3987,7 +4449,12 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) #endif allocate = (flags & SV_HAS_TRAILING_NUL) - ? len + 1: PERL_STRLEN_ROUNDUP(len + 1); + ? len + 1 : +#ifdef Perl_safesysmalloc_size + len + 1; +#else + PERL_STRLEN_ROUNDUP(len + 1); +#endif if (flags & SV_HAS_TRAILING_NUL) { /* It's long enough - do nothing. Specfically Perl_newCONSTSUB is relying on this. */ @@ -4003,9 +4470,13 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) ptr = (char*) saferealloc (ptr, allocate); #endif } - SvPV_set(sv, ptr); - SvCUR_set(sv, len); +#ifdef Perl_safesysmalloc_size + SvLEN_set(sv, Perl_safesysmalloc_size(ptr)); +#else SvLEN_set(sv, allocate); +#endif + SvCUR_set(sv, len); + SvPV_set(sv, ptr); if (!(flags & SV_HAS_TRAILING_NUL)) { ptr[len] = '\0'; } @@ -4024,6 +4495,8 @@ Perl_sv_usepvn_flags(pTHX_ SV *sv, char *ptr, STRLEN len, U32 flags) STATIC void S_sv_release_COW(pTHX_ register SV *sv, const char *pvx, SV *after) { + PERL_ARGS_ASSERT_SV_RELEASE_COW; + { /* this SV was SvIsCOW_normal(sv) */ /* we need to find the SV pointing to us. */ SV *current = SV_COW_NEXT_SV(after); @@ -4068,9 +4541,12 @@ with flags set to 0. */ void -Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) +Perl_sv_force_normal_flags(pTHX_ register SV *const sv, const U32 flags) { dVAR; + + PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS; + #ifdef PERL_OLD_COPY_ON_WRITE if (SvREADONLY(sv)) { /* At this point I believe I should acquire a global SV mutex. */ @@ -4113,7 +4589,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) } } else if (IN_PERL_RUNTIME) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); /* At this point I believe that I can drop the global SV mutex. */ } #else @@ -4131,7 +4607,7 @@ Perl_sv_force_normal_flags(pTHX_ register SV *sv, U32 flags) unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); } else if (IN_PERL_RUNTIME) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } #endif if (SvROK(sv)) @@ -4154,15 +4630,36 @@ refer to the same chunk of data. */ void -Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) +Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr) { - register STRLEN delta; + STRLEN delta; + STRLEN old_delta; + U8 *p; +#ifdef DEBUGGING + const U8 *real_start; +#endif + STRLEN max_delta; + + PERL_ARGS_ASSERT_SV_CHOP; + if (!ptr || !SvPOKp(sv)) return; delta = ptr - SvPVX_const(sv); + if (!delta) { + /* Nothing to do. */ + return; + } + /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line, + nothing uses the value of ptr any more. */ + max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv); + if (ptr <= SvPVX_const(sv)) + Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p", + ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta); SV_CHECK_THINKFIRST(sv); - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv,SVt_PVIV); + if (delta > max_delta) + Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p", + SvPVX_const(sv) + delta, ptr, SvPVX_const(sv), + SvPVX_const(sv) + max_delta); if (!SvOOK(sv)) { if (!SvLEN(sv)) { /* make copy of shared string */ @@ -4172,17 +4669,40 @@ Perl_sv_chop(pTHX_ register SV *sv, register const char *ptr) Move(pvx,SvPVX(sv),len,char); *SvEND(sv) = '\0'; } - SvIV_set(sv, 0); - /* Same SvOOK_on but SvOOK_on does a SvIOK_off - and we do that anyway inside the SvNIOK_off - */ SvFLAGS(sv) |= SVf_OOK; + old_delta = 0; + } else { + SvOOK_offset(sv, old_delta); } - SvNIOK_off(sv); SvLEN_set(sv, SvLEN(sv) - delta); SvCUR_set(sv, SvCUR(sv) - delta); SvPV_set(sv, SvPVX(sv) + delta); - SvIV_set(sv, SvIVX(sv) + delta); + + p = (U8 *)SvPVX_const(sv); + + delta += old_delta; + +#ifdef DEBUGGING + real_start = p - delta; +#endif + + assert(delta); + if (delta < 0x100) { + *--p = (U8) delta; + } else { + *--p = 0; + p -= sizeof(STRLEN); + Copy((U8*)&delta, p, sizeof(STRLEN), U8); + } + +#ifdef DEBUGGING + /* Fill the preceding buffer with sentinals to verify that no-one is + using it. */ + while (p > real_start) { + --p; + *p = (U8)PTR2UV(p); + } +#endif } /* @@ -4206,12 +4726,14 @@ in terms of this function. */ void -Perl_sv_catpvn_flags(pTHX_ register SV *dsv, register const char *sstr, register STRLEN slen, I32 flags) +Perl_sv_catpvn_flags(pTHX_ register SV *const dsv, register const char *sstr, register const STRLEN slen, const I32 flags) { dVAR; STRLEN dlen; const char * const dstr = SvPV_force_flags(dsv, dlen, flags); + PERL_ARGS_ASSERT_SV_CATPVN_FLAGS; + SvGROW(dsv, dlen + slen + 1); if (sstr == dstr) sstr = SvPVX_const(dsv); @@ -4241,10 +4763,13 @@ and C are implemented in terms of this function. =cut */ void -Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) +Perl_sv_catsv_flags(pTHX_ SV *const dsv, register SV *const ssv, const I32 flags) { dVAR; - if (ssv) { + + PERL_ARGS_ASSERT_SV_CATSV_FLAGS; + + if (ssv) { STRLEN slen; const char *spv = SvPV_const(ssv, slen); if (spv) { @@ -4265,7 +4790,7 @@ Perl_sv_catsv_flags(pTHX_ SV *dsv, register SV *ssv, I32 flags) if (dutf8 != sutf8) { if (dutf8) { /* Not modifying source SV, so taking a temporary copy. */ - SV* const csv = sv_2mortal(newSVpvn(spv, slen)); + SV* const csv = newSVpvn_flags(spv, slen, SVs_TEMP); sv_utf8_upgrade(csv); spv = SvPV_const(csv, slen); @@ -4290,13 +4815,15 @@ valid UTF-8. Handles 'get' magic, but not 'set' magic. See C. =cut */ void -Perl_sv_catpv(pTHX_ register SV *sv, register const char *ptr) +Perl_sv_catpv(pTHX_ register SV *const sv, register const char *ptr) { dVAR; register STRLEN len; STRLEN tlen; char *junk; + PERL_ARGS_ASSERT_SV_CATPV; + if (!ptr) return; junk = SvPV_force(sv, tlen); @@ -4319,8 +4846,10 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_catpv_mg(pTHX_ register SV *sv, register const char *ptr) +Perl_sv_catpv_mg(pTHX_ register SV *const sv, register const char *const ptr) { + PERL_ARGS_ASSERT_SV_CATPV_MG; + sv_catpv(sv,ptr); SvSETMAGIC(sv); } @@ -4343,7 +4872,7 @@ modules supporting older perls. */ SV * -Perl_newSV(pTHX_ STRLEN len) +Perl_newSV(pTHX_ const STRLEN len) { dVAR; register SV *sv; @@ -4375,12 +4904,14 @@ to contain an C and is stored as-is with its REFCNT incremented. =cut */ MAGIC * -Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, - const char* name, I32 namlen) +Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, + const MGVTBL *const vtable, const char *const name, const I32 namlen) { dVAR; MAGIC* mg; + PERL_ARGS_ASSERT_SV_MAGICEXT; + SvUPGRADE(sv, SVt_PVMG); Newxz(mg, 1, MAGIC); mg->mg_moremagic = SvMAGIC(sv); @@ -4397,12 +4928,11 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, */ if (!obj || obj == sv || how == PERL_MAGIC_arylen || - how == PERL_MAGIC_qr || how == PERL_MAGIC_symtab || (SvTYPE(obj) == SVt_PVGV && - (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || - GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv || - GvFORM(obj) == (CV*)sv))) + (GvSV(obj) == sv || GvHV(obj) == (const HV *)sv + || GvAV(obj) == (const AV *)sv || GvCV(obj) == (const CV *)sv + || GvIOp(obj) == (const IO *)sv || GvFORM(obj) == (const CV *)sv))) { mg->mg_obj = obj; } @@ -4420,7 +4950,7 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, */ if (how == PERL_MAGIC_tiedscalar && SvTYPE(sv) == SVt_PVIO && - obj && SvROK(obj) && GvIO(SvRV(obj)) == (IO*)sv) + obj && SvROK(obj) && GvIO(SvRV(obj)) == (const IO *)sv) { sv_rvweaken(obj); } @@ -4430,9 +4960,13 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, const MGVTBL *vtable, if (name) { if (namlen > 0) mg->mg_ptr = savepvn(name, namlen); - else if (namlen == HEf_SVKEY) - mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV*)name); - else + else if (namlen == HEf_SVKEY) { + /* Yes, this is casting away const. This is only for the case of + HEf_SVKEY. I think we need to document this abberation of the + constness of the API, rather than making name non-const, as + that change propagating outwards a long way. */ + mg->mg_ptr = (char*)SvREFCNT_inc_simple_NN((SV *)name); + } else mg->mg_ptr = (char *) name; } mg->mg_virtual = (MGVTBL *) vtable; @@ -4459,12 +4993,15 @@ 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) +Perl_sv_magic(pTHX_ register SV *const sv, SV *const obj, const int how, + const char *const name, const I32 namlen) { dVAR; const MGVTBL *vtable; MAGIC* mg; + PERL_ARGS_ASSERT_SV_MAGIC; + #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(sv)) sv_force_normal_flags(sv, 0); @@ -4483,7 +5020,7 @@ Perl_sv_magic(pTHX_ register SV *sv, SV *obj, int how, const char *name, I32 nam && how != PERL_MAGIC_backref ) { - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } } if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { @@ -4644,10 +5181,13 @@ Removes all magic of type C from an SV. */ int -Perl_sv_unmagic(pTHX_ SV *sv, int type) +Perl_sv_unmagic(pTHX_ SV *const sv, const int type) { MAGIC* mg; MAGIC** mgp; + + PERL_ARGS_ASSERT_SV_UNMAGIC; + if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) return 0; mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic); @@ -4661,7 +5201,7 @@ Perl_sv_unmagic(pTHX_ SV *sv, int type) if (mg->mg_len > 0) Safefree(mg->mg_ptr); else if (mg->mg_len == HEf_SVKEY) - SvREFCNT_dec((SV*)mg->mg_ptr); + SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); else if (mg->mg_type == PERL_MAGIC_utf8) Safefree(mg->mg_ptr); } @@ -4694,9 +5234,12 @@ called after the RV is cleared. */ SV * -Perl_sv_rvweaken(pTHX_ SV *sv) +Perl_sv_rvweaken(pTHX_ SV *const sv) { SV *tsv; + + PERL_ARGS_ASSERT_SV_RVWEAKEN; + if (!SvOK(sv)) /* let undefs pass */ return sv; if (!SvROK(sv)) @@ -4717,14 +5260,34 @@ Perl_sv_rvweaken(pTHX_ SV *sv) * back-reference to sv onto the array associated with the backref magic. */ +/* A discussion about the backreferences array and its refcount: + * + * The AV holding the backreferences is pointed to either as the mg_obj of + * PERL_MAGIC_backref, or in the specific case of a HV that has the hv_aux + * structure, from the xhv_backreferences field. (A HV without hv_aux will + * have the standard magic instead.) The array is created with a refcount + * of 2. This means that if during global destruction the array gets + * picked on first to have its refcount decremented by the random zapper, + * it won't actually be freed, meaning it's still theere for when its + * parent gets freed. + * When the parent SV is freed, in the case of magic, the magic is freed, + * Perl_magic_killbackrefs is called which decrements one refcount, then + * mg_obj is freed which kills the second count. + * In the vase of a HV being freed, one ref is removed by + * Perl_hv_kill_backrefs, the other by Perl_sv_kill_backrefs, which it + * calls. + */ + void -Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) +Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) { dVAR; AV *av; + PERL_ARGS_ASSERT_SV_ADD_BACKREF; + if (SvTYPE(tsv) == SVt_PVHV) { - AV **const avp = Perl_hv_backreferences_p(aTHX_ (HV*)tsv); + AV **const avp = Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); av = *avp; if (!av) { @@ -4733,7 +5296,7 @@ Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) if (mg) { /* Aha. They've got it stowed in magic. Bring it back. */ - av = (AV*)mg->mg_obj; + av = MUTABLE_AV(mg->mg_obj); /* Stop mg_free decreasing the refernce count. */ mg->mg_obj = NULL; /* Stop mg_free even calling the destructor, given that @@ -4743,7 +5306,7 @@ Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) } else { av = newAV(); AvREAL_off(av); - SvREFCNT_inc_simple_void(av); + SvREFCNT_inc_simple_void(av); /* see discussion above */ } *avp = av; } @@ -4751,14 +5314,12 @@ Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) const MAGIC *const mg = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; if (mg) - av = (AV*)mg->mg_obj; + av = MUTABLE_AV(mg->mg_obj); else { av = newAV(); AvREAL_off(av); - sv_magic(tsv, (SV*)av, PERL_MAGIC_backref, NULL, 0); - /* av now has a refcnt of 2, which avoids it getting freed - * before us during global cleanup. The extra ref is removed - * by magic_killbackrefs() when tsv is being freed */ + sv_magic(tsv, MUTABLE_SV(av), PERL_MAGIC_backref, NULL, 0); + /* av now has a refcnt of 2; see discussion above */ } } if (AvFILLp(av) >= AvMAX(av)) { @@ -4772,15 +5333,17 @@ Perl_sv_add_backref(pTHX_ SV *tsv, SV *sv) */ STATIC void -S_sv_del_backref(pTHX_ SV *tsv, SV *sv) +S_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) { dVAR; AV *av = NULL; SV **svp; I32 i; + PERL_ARGS_ASSERT_SV_DEL_BACKREF; + if (SvTYPE(tsv) == SVt_PVHV && SvOOK(tsv)) { - av = *Perl_hv_backreferences_p(aTHX_ (HV*)tsv); + av = *Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); /* We mustn't attempt to "fix up" the hash here by moving the backreference array back to the hv_aux structure, as that is stored in the main HvARRAY(), and hfreentries assumes that no-one @@ -4790,16 +5353,13 @@ S_sv_del_backref(pTHX_ SV *tsv, SV *sv) const MAGIC *const mg = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; if (mg) - av = (AV *)mg->mg_obj; + av = MUTABLE_AV(mg->mg_obj); } - if (!av) { - if (PL_in_clean_all) - return; + + if (!av) Perl_croak(aTHX_ "panic: del_backref"); - } - if (SvIS_FREED(av)) - return; + assert(!SvIS_FREED(av)); svp = AvARRAY(av); /* We shouldn't be in here more than once, but for paranoia reasons lets @@ -4822,15 +5382,15 @@ S_sv_del_backref(pTHX_ SV *tsv, SV *sv) } int -Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av) +Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) { SV **svp = AvARRAY(av); + PERL_ARGS_ASSERT_SV_KILL_BACKREFS; PERL_UNUSED_ARG(sv); - /* Not sure why the av can get freed ahead of its sv, but somehow it does - in ext/B/t/bytecode.t test 15 (involving print ) */ - if (svp && !SvIS_FREED(av)) { + assert(!svp || !SvIS_FREED(av)); + if (svp) { SV *const *const last = svp + AvFILLp(av); while (svp <= last) { @@ -4846,7 +5406,7 @@ Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av) SvTYPE(referrer) == SVt_PVLV) { /* You lookin' at me? */ assert(GvSTASH(referrer)); - assert(GvSTASH(referrer) == (HV*)sv); + assert(GvSTASH(referrer) == (const HV *)sv); GvSTASH(referrer) = 0; } else { Perl_croak(aTHX_ @@ -4867,13 +5427,17 @@ Perl_sv_kill_backrefs(pTHX_ SV *sv, AV *av) =for apidoc sv_insert Inserts a string at the specified offset/length within the SV. Similar to -the Perl substr() function. +the Perl substr() function. Handles get magic. + +=for apidoc sv_insert_flags + +Same as C, but the extra C are passed the C that applies to C. =cut */ void -Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, STRLEN littlelen) +Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags) { dVAR; register char *big; @@ -4883,10 +5447,11 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, register I32 i; STRLEN curlen; + PERL_ARGS_ASSERT_SV_INSERT_FLAGS; if (!bigstr) Perl_croak(aTHX_ "Can't modify non-existent substring"); - SvPV_force(bigstr, curlen); + SvPV_force_flags(bigstr, curlen, flags); (void)SvPOK_only_UTF8(bigstr); if (offset + len > curlen) { SvGROW(bigstr, offset+len+1); @@ -4939,10 +5504,8 @@ Perl_sv_insert(pTHX_ SV *bigstr, STRLEN offset, STRLEN len, const char *little, else if ((i = mid - big)) { /* faster from front */ midend -= littlelen; mid = midend; + Move(big, midend - i, i, char); sv_chop(bigstr,midend-i); - big += i; - while (i--) - *--midend = *--big; if (littlelen) Move(little, mid, littlelen,char); } @@ -4971,10 +5534,13 @@ time you'll want to use C or one of its many macro front-ends. */ void -Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) +Perl_sv_replace(pTHX_ register SV *const sv, register SV *const nsv) { dVAR; const U32 refcnt = SvREFCNT(sv); + + PERL_ARGS_ASSERT_SV_REPLACE; + SV_CHECK_THINKFIRST_COW_DROP(sv); if (SvREFCNT(nsv) != 1) { Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace() (%" @@ -5001,13 +5567,9 @@ Perl_sv_replace(pTHX_ register SV *sv, register SV *nsv) #else StructCopy(nsv,sv,SV); #endif - /* Currently could join these into one piece of pointer arithmetic, but - it would be unclear. */ - if(SvTYPE(sv) == SVt_IV) + if(SvTYPE(sv) == SVt_IV) { SvANY(sv) = (XPVIV*)((char*)&(sv->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); - else if (SvTYPE(sv) == SVt_RV) { - SvANY(sv) = &sv->sv_u.svu_rv; } @@ -5054,7 +5616,7 @@ instead. */ void -Perl_sv_clear(pTHX_ register SV *sv) +Perl_sv_clear(pTHX_ register SV *const sv) { dVAR; const U32 type = SvTYPE(sv); @@ -5062,18 +5624,30 @@ Perl_sv_clear(pTHX_ register SV *sv) = bodies_by_type + type; HV *stash; - assert(sv); + PERL_ARGS_ASSERT_SV_CLEAR; assert(SvREFCNT(sv) == 0); + assert(SvTYPE(sv) != SVTYPEMASK); if (type <= SVt_IV) { /* See the comment in sv.h about the collusion between this early return and the overloading of the NULL and IV slots in the size table. */ + if (SvROK(sv)) { + SV * const target = SvRV(sv); + if (SvWEAKREF(sv)) + sv_del_backref(target, sv); + else + SvREFCNT_dec(target); + } + SvFLAGS(sv) &= SVf_BREAK; + SvFLAGS(sv) |= SVTYPEMASK; return; } if (SvOBJECT(sv)) { - if (PL_defstash) { /* Still have a symbol table? */ + if (PL_defstash && /* Still have a symbol table? */ + SvDESTROYABLE(sv)) + { dSP; HV* stash; do { @@ -5089,7 +5663,7 @@ Perl_sv_clear(pTHX_ register SV *sv) PUSHMARK(SP); PUSHs(tmpref); PUTBACK; - call_sv((SV*)destructor, G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); + call_sv(MUTABLE_SV(destructor), G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); POPSTACK; @@ -5138,7 +5712,7 @@ Perl_sv_clear(pTHX_ register SV *sv) IoIFP(sv) != PerlIO_stdout() && IoIFP(sv) != PerlIO_stderr()) { - io_close((IO*)sv, FALSE); + io_close(MUTABLE_IO(sv), FALSE); } if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) PerlDir_close(IoDIRP(sv)); @@ -5147,20 +5721,27 @@ Perl_sv_clear(pTHX_ register SV *sv) Safefree(IoFMT_NAME(sv)); Safefree(IoBOTTOM_NAME(sv)); goto freescalar; + case SVt_REGEXP: + /* FIXME for plugins */ + pregfree2((REGEXP*) sv); + goto freescalar; case SVt_PVCV: case SVt_PVFM: - cv_undef((CV*)sv); + cv_undef(MUTABLE_CV(sv)); goto freescalar; case SVt_PVHV: - Perl_hv_kill_backrefs(aTHX_ (HV*)sv); - hv_undef((HV*)sv); + if (PL_last_swash_hv == (const HV *)sv) { + PL_last_swash_hv = NULL; + } + Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); + hv_undef(MUTABLE_HV(sv)); break; case SVt_PVAV: - if (PL_comppad == (AV*)sv) { + if (PL_comppad == MUTABLE_AV(sv)) { PL_comppad = NULL; PL_curpad = NULL; } - av_undef((AV*)sv); + av_undef(MUTABLE_AV(sv)); break; case SVt_PVLV: if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ @@ -5172,32 +5753,34 @@ Perl_sv_clear(pTHX_ register SV *sv) SvREFCNT_dec(LvTARG(sv)); case SVt_PVGV: if (isGV_with_GP(sv)) { - if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash)) + if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) + && HvNAME_get(stash)) mro_method_changed_in(stash); - gp_free((GV*)sv); + gp_free(MUTABLE_GV(sv)); if (GvNAME_HEK(sv)) unshare_hek(GvNAME_HEK(sv)); /* 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 (!SvVALID(sv) && (stash = GvSTASH(sv))) - sv_del_backref((SV*)stash, sv); + sv_del_backref(MUTABLE_SV(stash), sv); } /* FIXME. There are probably more unreferenced pointers to SVs in the interpreter struct that we should check and tidy in a similar fashion to this: */ - if ((GV*)sv == PL_last_in_gv) + if ((const GV *)sv == PL_last_in_gv) PL_last_in_gv = NULL; case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: + case SVt_PV: freescalar: /* Don't bother with SvOOK_off(sv); as we're only going to free it. */ if (SvOOK(sv)) { - SvPV_set(sv, SvPVX_mutable(sv) - SvIVX(sv)); + STRLEN offset; + SvOOK_offset(sv, offset); + SvPV_set(sv, SvPVX_mutable(sv) - offset); /* Don't even bother with turning off the OOK flag. */ } - case SVt_PV: - case SVt_RV: if (SvROK(sv)) { SV * const target = SvRV(sv); if (SvWEAKREF(sv)) @@ -5261,7 +5844,7 @@ instead. */ SV * -Perl_sv_newref(pTHX_ SV *sv) +Perl_sv_newref(pTHX_ SV *const sv) { PERL_UNUSED_CONTEXT; if (sv) @@ -5281,7 +5864,7 @@ Normally called via a wrapper macro C. */ void -Perl_sv_free(pTHX_ SV *sv) +Perl_sv_free(pTHX_ SV *const sv) { dVAR; if (!sv) @@ -5299,17 +5882,28 @@ Perl_sv_free(pTHX_ SV *sv) return; } if (ckWARN_d(WARN_INTERNAL)) { - Perl_warner(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free unreferenced scalar: SV 0x%"UVxf - pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); #ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP Perl_dump_sv_child(aTHX_ sv); #else #ifdef DEBUG_LEAKING_SCALARS - sv_dump(sv); + sv_dump(sv); #endif +#ifdef DEBUG_LEAKING_SCALARS_ABORT + if (PL_warnhook == PERL_WARNHOOK_FATAL + || ckDEAD(packWARN(WARN_INTERNAL))) { + /* Don't let Perl_warner cause us to escape our fate: */ + abort(); + } +#endif + /* This may not return: */ + Perl_warner(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free unreferenced scalar: SV 0x%"UVxf + pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); #endif } +#ifdef DEBUG_LEAKING_SCALARS_ABORT + abort(); +#endif return; } if (--(SvREFCNT(sv)) > 0) @@ -5318,9 +5912,12 @@ Perl_sv_free(pTHX_ SV *sv) } void -Perl_sv_free2(pTHX_ SV *sv) +Perl_sv_free2(pTHX_ SV *const sv) { dVAR; + + PERL_ARGS_ASSERT_SV_FREE2; + #ifdef DEBUGGING if (SvTEMP(sv)) { if (ckWARN_d(WARN_DEBUGGING)) @@ -5350,7 +5947,7 @@ coercion. See also C, which gives raw access to the xpv_cur slot. */ STRLEN -Perl_sv_len(pTHX_ register SV *sv) +Perl_sv_len(pTHX_ register SV *const sv) { STRLEN len; @@ -5383,7 +5980,7 @@ UTF-8 bytes as a single character. Handles magic and type coercion. */ STRLEN -Perl_sv_len_utf8(pTHX_ register SV *sv) +Perl_sv_len_utf8(pTHX_ register SV *const sv) { if (!sv) return 0; @@ -5440,6 +6037,8 @@ S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, { const U8 *s = start; + PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS; + while (s < send && uoffset--) s += UTF8SKIP(s); if (s > send) { @@ -5455,9 +6054,12 @@ S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, the passed in UTF-8 offset. */ static STRLEN S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, - STRLEN uoffset, STRLEN uend) + const STRLEN uoffset, const STRLEN uend) { STRLEN backw = uend - uoffset; + + PERL_ARGS_ASSERT_SV_POS_U2B_MIDWAY; + if (uoffset < 2 * backw) { /* The assumption is that going forwards is twice the speed of going forward (that's where the 2 * backw comes from). @@ -5482,12 +6084,15 @@ S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, will be used to reduce the amount of linear searching. The cache will be created if necessary, and the found value offered to it for update. */ static STRLEN -S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, - const U8 *const send, STRLEN uoffset, - STRLEN uoffset0, STRLEN boffset0) { +S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start, + const U8 *const send, const STRLEN uoffset, + STRLEN uoffset0, STRLEN boffset0) +{ STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */ bool found = FALSE; + PERL_ARGS_ASSERT_SV_POS_U2B_CACHED; + assert (uoffset >= uoffset0); if (SvMAGICAL(sv) && !SvREADONLY(sv) && PL_utf8cache @@ -5575,7 +6180,8 @@ S_sv_pos_u2b_cached(pTHX_ SV *sv, MAGIC **mgp, const U8 *const start, boffset = real_boffset; } - S_utf8_mg_pos_cache_update(aTHX_ sv, mgp, boffset, uoffset, send - start); + if (PL_utf8cache) + utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start); return boffset; } @@ -5600,11 +6206,13 @@ type coercion. */ void -Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) +Perl_sv_pos_u2b(pTHX_ register SV *const sv, I32 *const offsetp, I32 *const lenp) { const U8 *start; STRLEN len; + PERL_ARGS_ASSERT_SV_POS_U2B; + if (!sv) return; @@ -5661,10 +6269,13 @@ Perl_sv_pos_u2b(pTHX_ register SV *sv, I32* offsetp, I32* lenp) from. */ static void -S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, - STRLEN blen) +S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN byte, + const STRLEN utf8, const STRLEN blen) { STRLEN *cache; + + PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE; + if (SvREADONLY(sv)) return; @@ -5798,12 +6409,14 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *sv, MAGIC **mgp, STRLEN byte, STRLEN utf8, assumption is made as in S_sv_pos_u2b_midway(), namely that walking backward is half the speed of walking forward. */ static STRLEN -S_sv_pos_b2u_midway(pTHX_ const U8 *s, const U8 *const target, const U8 *end, - STRLEN endu) +S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target, + const U8 *end, STRLEN endu) { const STRLEN forw = target - s; STRLEN backw = end - target; + PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY; + if (forw < 2 * backw) { return utf8_length(s, target); } @@ -5835,7 +6448,7 @@ Handles magic and type coercion. * */ void -Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) +Perl_sv_pos_b2u(pTHX_ register SV *const sv, I32 *const offsetp) { const U8* s; const STRLEN byte = *offsetp; @@ -5845,6 +6458,8 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) const U8* send; bool found = FALSE; + PERL_ARGS_ASSERT_SV_POS_B2U; + if (!sv) return; @@ -5921,7 +6536,8 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) } *offsetp = len; - S_utf8_mg_pos_cache_update(aTHX_ sv, &mg, byte, len, blen); + if (PL_utf8cache) + utf8_mg_pos_cache_update(sv, &mg, byte, len, blen); } /* @@ -5955,8 +6571,7 @@ Perl_sv_eq(pTHX_ register SV *sv1, register SV *sv2) * invalidate pv1, so we may need to make a copy */ if (sv1 == sv2 && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { pv1 = SvPV_const(sv1, cur1); - sv1 = sv_2mortal(newSVpvn(pv1, cur1)); - if (SvUTF8(sv2)) SvUTF8_on(sv1); + sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2)); } pv1 = SvPV_const(sv1, cur1); } @@ -6037,7 +6652,7 @@ coerce its args to strings if necessary. See also C. */ I32 -Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) +Perl_sv_cmp(pTHX_ register SV *const sv1, register SV *const sv2) { dVAR; STRLEN cur1, cur2; @@ -6113,13 +6728,13 @@ Perl_sv_cmp(pTHX_ register SV *sv1, register SV *sv2) Compares the strings in two SVs in a locale-aware manner. Is UTF-8 and 'use bytes' aware, handles get magic, and will coerce its args to strings -if necessary. See also C. See also C. +if necessary. See also C. =cut */ I32 -Perl_sv_cmp_locale(pTHX_ register SV *sv1, register SV *sv2) +Perl_sv_cmp_locale(pTHX_ register SV *const sv1, register SV *const sv2) { dVAR; #ifdef USE_LOCALE_COLLATE @@ -6184,11 +6799,13 @@ settings. */ char * -Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) +Perl_sv_collxfrm(pTHX_ SV *const sv, STRLEN *const nxp) { dVAR; MAGIC *mg; + PERL_ARGS_ASSERT_SV_COLLXFRM; + mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_collxfrm) : (MAGIC *) NULL; if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { const char *s; @@ -6199,11 +6816,6 @@ Perl_sv_collxfrm(pTHX_ SV *sv, STRLEN *nxp) Safefree(mg->mg_ptr); s = SvPV_const(sv, len); if ((xf = mem_collxfrm(s, len, &xlen))) { - if (SvREADONLY(sv)) { - SAVEFREEPV(xf); - *nxp = xlen; - return xf + sizeof(PL_collation_ix); - } if (! mg) { #ifdef PERL_OLD_COPY_ON_WRITE if (SvIsCOW(sv)) @@ -6245,7 +6857,7 @@ appending to the currently-stored string. */ char * -Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) +Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) { dVAR; const char *rsptr; @@ -6256,6 +6868,8 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) I32 i = 0; I32 rspara = 0; + PERL_ARGS_ASSERT_SV_GETS; + if (SvTHINKFIRST(sv)) sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV); /* XXX. If you make this PVIV, then copy on write can copy scalars read @@ -6313,6 +6927,9 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) I32 bytesread; char *buffer; U32 recsize; +#ifdef VMS + int fd; +#endif /* Grab the size of the record we're getting */ recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */ @@ -6324,13 +6941,19 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) /* doing, but we've got no other real choice - except avoid stdio as implementation - perhaps write a :vms layer ? */ - bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize); + fd = PerlIO_fileno(fp); + if (fd == -1) { /* in-memory file from PerlIO::Scalar */ + bytesread = PerlIO_read(fp, buffer, recsize); + } + else { + bytesread = PerlLIO_read(fd, buffer, recsize); + } #else bytesread = PerlIO_read(fp, buffer, recsize); #endif if (bytesread < 0) bytesread = 0; - SvCUR_set(sv, bytesread += append); + SvCUR_set(sv, bytesread + append); buffer[bytesread] = '\0'; goto return_string_or_null; } @@ -6601,7 +7224,7 @@ if necessary. Handles 'get' magic. */ void -Perl_sv_inc(pTHX_ register SV *sv) +Perl_sv_inc(pTHX_ register SV *const sv) { dVAR; register char *d; @@ -6615,7 +7238,7 @@ Perl_sv_inc(pTHX_ register SV *sv) sv_force_normal_flags(sv, 0); if (SvREADONLY(sv)) { if (IN_PERL_RUNTIME) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } if (SvROK(sv)) { IV i; @@ -6655,8 +7278,15 @@ Perl_sv_inc(pTHX_ register SV *sv) return; } if (flags & SVp_NOK) { + const NV was = SvNVX(sv); + if (NV_OVERFLOWS_INTEGERS_AT && + was >= NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) { + Perl_warner(aTHX_ packWARN(WARN_IMPRECISION), + "Lost precision when incrementing %" NVff " by 1", + was); + } (void)SvNOK_only(sv); - SvNV_set(sv, SvNVX(sv) + 1.0); + SvNV_set(sv, was + 1.0); return; } @@ -6758,7 +7388,7 @@ if necessary. Handles 'get' magic. */ void -Perl_sv_dec(pTHX_ register SV *sv) +Perl_sv_dec(pTHX_ register SV *const sv) { dVAR; int flags; @@ -6771,7 +7401,7 @@ Perl_sv_dec(pTHX_ register SV *sv) sv_force_normal_flags(sv, 0); if (SvREADONLY(sv)) { if (IN_PERL_RUNTIME) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); } if (SvROK(sv)) { IV i; @@ -6800,8 +7430,10 @@ Perl_sv_dec(pTHX_ register SV *sv) SvUV_set(sv, SvUVX(sv) - 1); } } else { - if (SvIVX(sv) == IV_MIN) - sv_setnv(sv, (NV)IV_MIN - 1.0); + if (SvIVX(sv) == IV_MIN) { + sv_setnv(sv, (NV)IV_MIN); + goto oops_its_num; + } else { (void)SvIOK_only(sv); SvIV_set(sv, SvIVX(sv) - 1); @@ -6810,9 +7442,19 @@ Perl_sv_dec(pTHX_ register SV *sv) return; } if (flags & SVp_NOK) { - SvNV_set(sv, SvNVX(sv) - 1.0); - (void)SvNOK_only(sv); - return; + oops_its_num: + { + const NV was = SvNVX(sv); + if (NV_OVERFLOWS_INTEGERS_AT && + was <= -NV_OVERFLOWS_INTEGERS_AT && ckWARN(WARN_IMPRECISION)) { + Perl_warner(aTHX_ packWARN(WARN_IMPRECISION), + "Lost precision when decrementing %" NVff " by 1", + was); + } + (void)SvNOK_only(sv); + SvNV_set(sv, was - 1.0); + return; + } } if (!(flags & SVp_POK)) { if ((flags & SVTYPEMASK) < SVt_PVIV) @@ -6875,7 +7517,7 @@ statement boundaries. See also C and C. * permanent location. */ SV * -Perl_sv_mortalcopy(pTHX_ SV *oldstr) +Perl_sv_mortalcopy(pTHX_ SV *const oldstr) { dVAR; register SV *sv; @@ -6912,6 +7554,40 @@ Perl_sv_newmortal(pTHX) return sv; } + +/* +=for apidoc newSVpvn_flags + +Creates a new SV and copies a string into it. The reference count for the +SV is set to 1. Note that if C is zero, Perl will create a zero length +string. You are responsible for ensuring that the source string is at least +C bytes long. If the C argument is NULL the new SV will be undefined. +Currently the only flag bits accepted are C and C. +If C is set, then C is called on the result before +returning. If C is set, then it will be set on the new SV. +C is a convenience wrapper for this function, defined as + + #define newSVpvn_utf8(s, len, u) \ + newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) + +=cut +*/ + +SV * +Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags) +{ + dVAR; + register SV *sv; + + /* All the flags we don't support must be zero. + And we're new code so I'm going to assert this from the start. */ + assert(!(flags & ~(SVf_UTF8|SVs_TEMP))); + new_SV(sv); + sv_setpvn(sv,s,len); + SvFLAGS(sv) |= (flags & SVf_UTF8); + return (flags & SVs_TEMP) ? sv_2mortal(sv) : sv; +} + /* =for apidoc sv_2mortal @@ -6925,7 +7601,7 @@ and C. */ SV * -Perl_sv_2mortal(pTHX_ register SV *sv) +Perl_sv_2mortal(pTHX_ register SV *const sv) { dVAR; if (!sv) @@ -6949,7 +7625,7 @@ strlen(). For efficiency, consider using C instead. */ SV * -Perl_newSVpv(pTHX_ const char *s, STRLEN len) +Perl_newSVpv(pTHX_ const char *const s, const STRLEN len) { dVAR; register SV *sv; @@ -6971,7 +7647,7 @@ C bytes long. If the C argument is NULL the new SV will be undefined. */ SV * -Perl_newSVpvn(pTHX_ const char *s, STRLEN len) +Perl_newSVpvn(pTHX_ const char *const s, const STRLEN len) { dVAR; register SV *sv; @@ -6981,7 +7657,6 @@ Perl_newSVpvn(pTHX_ const char *s, STRLEN len) return sv; } - /* =for apidoc newSVhek @@ -6993,7 +7668,7 @@ SV if the hek is NULL. */ SV * -Perl_newSVhek(pTHX_ const HEK *hek) +Perl_newSVhek(pTHX_ const HEK *const hek) { dVAR; if (!hek) { @@ -7086,6 +7761,8 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) if (!hash) PERL_HASH(hash, src, len); new_SV(sv); + /* The logic for this is inlined in S_mro_get_linear_isa_dfs(), so if it + changes here, update it there too. */ sv_upgrade(sv, SVt_PV); SvPV_set(sv, sharepvn(src, is_utf8?-len:len, hash)); SvCUR_set(sv, len); @@ -7109,11 +7786,14 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) */ SV * -Perl_newSVpvf_nocontext(const char* pat, ...) +Perl_newSVpvf_nocontext(const char *const pat, ...) { dTHX; register SV *sv; va_list args; + + PERL_ARGS_ASSERT_NEWSVPVF_NOCONTEXT; + va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); @@ -7131,10 +7811,13 @@ C. */ SV * -Perl_newSVpvf(pTHX_ const char* pat, ...) +Perl_newSVpvf(pTHX_ const char *const pat, ...) { register SV *sv; va_list args; + + PERL_ARGS_ASSERT_NEWSVPVF; + va_start(args, pat); sv = vnewSVpvf(pat, &args); va_end(args); @@ -7144,10 +7827,13 @@ Perl_newSVpvf(pTHX_ const char* pat, ...) /* backend for newSVpvf() and newSVpvf_nocontext() */ SV * -Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args) +Perl_vnewSVpvf(pTHX_ const char *const pat, va_list *const args) { dVAR; register SV *sv; + + PERL_ARGS_ASSERT_VNEWSVPVF; + new_SV(sv); sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); return sv; @@ -7163,7 +7849,7 @@ The reference count for the SV is set to 1. */ SV * -Perl_newSVnv(pTHX_ NV n) +Perl_newSVnv(pTHX_ const NV n) { dVAR; register SV *sv; @@ -7183,7 +7869,7 @@ SV is set to 1. */ SV * -Perl_newSViv(pTHX_ IV i) +Perl_newSViv(pTHX_ const IV i) { dVAR; register SV *sv; @@ -7203,7 +7889,7 @@ The reference count for the SV is set to 1. */ SV * -Perl_newSVuv(pTHX_ UV u) +Perl_newSVuv(pTHX_ const UV u) { dVAR; register SV *sv; @@ -7216,14 +7902,14 @@ Perl_newSVuv(pTHX_ UV u) /* =for apidoc newSV_type -Creates a new SV, of the type specificied. The reference count for the new SV +Creates a new SV, of the type specified. The reference count for the new SV is set to 1. =cut */ SV * -Perl_newSV_type(pTHX_ svtype type) +Perl_newSV_type(pTHX_ const svtype type) { register SV *sv; @@ -7242,10 +7928,13 @@ SV is B incremented. */ SV * -Perl_newRV_noinc(pTHX_ SV *tmpRef) +Perl_newRV_noinc(pTHX_ SV *const tmpRef) { dVAR; - register SV *sv = newSV_type(SVt_RV); + register SV *sv = newSV_type(SVt_IV); + + PERL_ARGS_ASSERT_NEWRV_NOINC; + SvTEMP_off(tmpRef); SvRV_set(sv, tmpRef); SvROK_on(sv); @@ -7257,9 +7946,12 @@ Perl_newRV_noinc(pTHX_ SV *tmpRef) */ SV * -Perl_newRV(pTHX_ SV *sv) +Perl_newRV(pTHX_ SV *const sv) { dVAR; + + PERL_ARGS_ASSERT_NEWRV; + return newRV_noinc(SvREFCNT_inc_simple_NN(sv)); } @@ -7273,7 +7965,7 @@ Creates a new SV which is an exact duplicate of the original SV. */ SV * -Perl_newSVsv(pTHX_ register SV *old) +Perl_newSVsv(pTHX_ register SV *const old) { dVAR; register SV *sv; @@ -7303,16 +7995,18 @@ Note that the perl-level function is vaguely deprecated. */ void -Perl_sv_reset(pTHX_ register const char *s, HV *stash) +Perl_sv_reset(pTHX_ register const char *s, HV *const stash) { dVAR; char todo[PERL_UCHAR_MAX+1]; + PERL_ARGS_ASSERT_SV_RESET; + if (!stash) return; if (!*s) { /* reset ?? searches */ - MAGIC * const mg = mg_find((SV *)stash, PERL_MAGIC_symtab); + MAGIC * const mg = mg_find((const SV *)stash, PERL_MAGIC_symtab); if (mg) { const U32 count = mg->mg_len / sizeof(PMOP**); PMOP **pmp = (PMOP**) mg->mg_ptr; @@ -7357,7 +8051,7 @@ Perl_sv_reset(pTHX_ register const char *s, HV *stash) if (!todo[(U8)*HeKEY(entry)]) continue; - gv = (GV*)HeVAL(entry); + gv = MUTABLE_GV(HeVAL(entry)); sv = GvSV(gv); if (sv) { if (SvTHINKFIRST(sv)) { @@ -7405,21 +8099,26 @@ named after the PV if we're a string. */ IO* -Perl_sv_2io(pTHX_ SV *sv) +Perl_sv_2io(pTHX_ SV *const sv) { IO* io; GV* gv; + PERL_ARGS_ASSERT_SV_2IO; + switch (SvTYPE(sv)) { case SVt_PVIO: - io = (IO*)sv; + io = MUTABLE_IO(sv); break; case SVt_PVGV: - gv = (GV*)sv; - io = GvIO(gv); - if (!io) - Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); - break; + if (isGV_with_GP(sv)) { + gv = MUTABLE_GV(sv); + io = GvIO(gv); + if (!io) + Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); + break; + } + /* FALL THROUGH */ default: if (!SvOK(sv)) Perl_croak(aTHX_ PL_no_usym, "filehandle"); @@ -7448,12 +8147,14 @@ The flags in C are passed to sv_fetchsv. */ CV * -Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) +Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) { dVAR; GV *gv = NULL; CV *cv = NULL; + PERL_ARGS_ASSERT_SV_2CV; + if (!sv) { *st = NULL; *gvp = NULL; @@ -7463,47 +8164,52 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) case SVt_PVCV: *st = CvSTASH(sv); *gvp = NULL; - return (CV*)sv; + return MUTABLE_CV(sv); case SVt_PVHV: case SVt_PVAV: *st = NULL; *gvp = NULL; return NULL; case SVt_PVGV: - gv = (GV*)sv; - *gvp = gv; - *st = GvESTASH(gv); - goto fix_gv; + if (isGV_with_GP(sv)) { + gv = MUTABLE_GV(sv); + *gvp = gv; + *st = GvESTASH(gv); + goto fix_gv; + } + /* FALL THROUGH */ default: - SvGETMAGIC(sv); if (SvROK(sv)) { SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + SvGETMAGIC(sv); tryAMAGICunDEREF(to_cv); sv = SvRV(sv); if (SvTYPE(sv) == SVt_PVCV) { - cv = (CV*)sv; + cv = MUTABLE_CV(sv); *gvp = NULL; *st = CvSTASH(cv); return cv; } - else if(isGV(sv)) - gv = (GV*)sv; + else if(isGV_with_GP(sv)) + gv = MUTABLE_GV(sv); else Perl_croak(aTHX_ "Not a subroutine reference"); } - else if (isGV(sv)) - gv = (GV*)sv; + else if (isGV_with_GP(sv)) { + SvGETMAGIC(sv); + gv = MUTABLE_GV(sv); + } else - gv = gv_fetchsv(sv, lref, SVt_PVCV); + gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */ *gvp = gv; if (!gv) { *st = NULL; return NULL; } /* Some flags to gv_fetchsv mean don't really create the GV */ - if (SvTYPE(gv) != SVt_PVGV) { + if (!isGV_with_GP(gv)) { *st = NULL; return NULL; } @@ -7523,7 +8229,7 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **st, GV **gvp, I32 lref) LEAVE; if (!GvCVu(gv)) Perl_croak(aTHX_ "Unable to create sub named \"%"SVf"\"", - SVfARG(sv)); + SVfARG(SvOK(sv) ? sv : &PL_sv_no)); } return GvCVu(gv); } @@ -7540,7 +8246,7 @@ instead use an in-line version. */ I32 -Perl_sv_true(pTHX_ register SV *sv) +Perl_sv_true(pTHX_ register SV *const sv) { if (!sv) return 0; @@ -7585,9 +8291,12 @@ C and C */ char * -Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) +Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) { dVAR; + + PERL_ARGS_ASSERT_SV_PVN_FORCE_FLAGS; + if (SvTHINKFIRST(sv) && !SvROK(sv)) sv_force_normal_flags(sv, 0); @@ -7607,7 +8316,8 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) else 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) + || isGV_with_GP(sv)) Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), OP_NAME(PL_op)); s = sv_2pv_flags(sv, &len, flags); @@ -7642,8 +8352,10 @@ The backend for the C macro. Always use the macro instead. */ char * -Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) +Perl_sv_pvbyten_force(pTHX_ SV *const sv, STRLEN *const lp) { + PERL_ARGS_ASSERT_SV_PVBYTEN_FORCE; + sv_pvn_force(sv,lp); sv_utf8_downgrade(sv,0); *lp = SvCUR(sv); @@ -7659,8 +8371,10 @@ The backend for the C macro. Always use the macro instead. */ char * -Perl_sv_pvutf8n_force(pTHX_ SV *sv, STRLEN *lp) +Perl_sv_pvutf8n_force(pTHX_ SV *const sv, STRLEN *const lp) { + PERL_ARGS_ASSERT_SV_PVUTF8N_FORCE; + sv_pvn_force(sv,lp); sv_utf8_upgrade(sv); *lp = SvCUR(sv); @@ -7676,8 +8390,10 @@ Returns a string describing what the SV is a reference to. */ const char * -Perl_sv_reftype(pTHX_ const SV *sv, int ob) +Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) { + PERL_ARGS_ASSERT_SV_REFTYPE; + /* The fact that I don't need to downcast to char * everywhere, only in ?: inside return suggests a const propagation bug in g++. */ if (ob && SvOBJECT(sv)) { @@ -7689,7 +8405,6 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob) case SVt_NULL: case SVt_IV: case SVt_NV: - case SVt_RV: case SVt_PV: case SVt_PVIV: case SVt_PVNV: @@ -7709,10 +8424,12 @@ Perl_sv_reftype(pTHX_ const SV *sv, int ob) case SVt_PVAV: return "ARRAY"; case SVt_PVHV: return "HASH"; case SVt_PVCV: return "CODE"; - case SVt_PVGV: return "GLOB"; + case SVt_PVGV: return (char *) (isGV_with_GP(sv) + ? "GLOB" : "SCALAR"); case SVt_PVFM: return "FORMAT"; case SVt_PVIO: return "IO"; case SVt_BIND: return "BIND"; + case SVt_REGEXP: return "REGEXP"; default: return "UNKNOWN"; } } @@ -7736,7 +8453,7 @@ Perl_sv_isobject(pTHX_ SV *sv) SvGETMAGIC(sv); if (!SvROK(sv)) return 0; - sv = (SV*)SvRV(sv); + sv = SvRV(sv); if (!SvOBJECT(sv)) return 0; return 1; @@ -7753,15 +8470,18 @@ an inheritance relationship. */ int -Perl_sv_isa(pTHX_ SV *sv, const char *name) +Perl_sv_isa(pTHX_ SV *sv, const char *const name) { const char *hvname; + + PERL_ARGS_ASSERT_SV_ISA; + if (!sv) return 0; SvGETMAGIC(sv); if (!SvROK(sv)) return 0; - sv = (SV*)SvRV(sv); + sv = SvRV(sv); if (!SvOBJECT(sv)) return 0; hvname = HvNAME_get(SvSTASH(sv)); @@ -7783,11 +8503,13 @@ reference count is 1. */ SV* -Perl_newSVrv(pTHX_ SV *rv, const char *classname) +Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) { dVAR; SV *sv; + PERL_ARGS_ASSERT_NEWSVRV; + new_SV(sv); SV_CHECK_THINKFIRST_COW_DROP(rv); @@ -7800,15 +8522,11 @@ Perl_newSVrv(pTHX_ SV *rv, const char *classname) SvFLAGS(rv) = 0; SvREFCNT(rv) = refcnt; - sv_upgrade(rv, SVt_RV); + sv_upgrade(rv, SVt_IV); } else if (SvROK(rv)) { SvREFCNT_dec(SvRV(rv)); - } else if (SvTYPE(rv) < SVt_RV) - sv_upgrade(rv, SVt_RV); - else if (SvTYPE(rv) > SVt_RV) { - SvPV_free(rv); - SvCUR_set(rv, 0); - SvLEN_set(rv, 0); + } else { + prepare_SV_for_RV(rv); } SvOK_off(rv); @@ -7841,9 +8559,12 @@ Note that C copies the string while this copies the pointer. */ SV* -Perl_sv_setref_pv(pTHX_ SV *rv, const char *classname, void *pv) +Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const pv) { dVAR; + + PERL_ARGS_ASSERT_SV_SETREF_PV; + if (!pv) { sv_setsv(rv, &PL_sv_undef); SvSETMAGIC(rv); @@ -7866,8 +8587,10 @@ will have a reference count of 1, and the RV will be returned. */ SV* -Perl_sv_setref_iv(pTHX_ SV *rv, const char *classname, IV iv) +Perl_sv_setref_iv(pTHX_ SV *const rv, const char *const classname, const IV iv) { + PERL_ARGS_ASSERT_SV_SETREF_IV; + sv_setiv(newSVrv(rv,classname), iv); return rv; } @@ -7885,8 +8608,10 @@ will have a reference count of 1, and the RV will be returned. */ SV* -Perl_sv_setref_uv(pTHX_ SV *rv, const char *classname, UV uv) +Perl_sv_setref_uv(pTHX_ SV *const rv, const char *const classname, const UV uv) { + PERL_ARGS_ASSERT_SV_SETREF_UV; + sv_setuv(newSVrv(rv,classname), uv); return rv; } @@ -7904,8 +8629,10 @@ will have a reference count of 1, and the RV will be returned. */ SV* -Perl_sv_setref_nv(pTHX_ SV *rv, const char *classname, NV nv) +Perl_sv_setref_nv(pTHX_ SV *const rv, const char *const classname, const NV nv) { + PERL_ARGS_ASSERT_SV_SETREF_NV; + sv_setnv(newSVrv(rv,classname), nv); return rv; } @@ -7926,8 +8653,11 @@ Note that C copies the pointer while this copies the string. */ SV* -Perl_sv_setref_pvn(pTHX_ SV *rv, const char *classname, const char *pv, STRLEN n) +Perl_sv_setref_pvn(pTHX_ SV *const rv, const char *const classname, + const char *const pv, const STRLEN n) { + PERL_ARGS_ASSERT_SV_SETREF_PVN; + sv_setpvn(newSVrv(rv,classname), pv, n); return rv; } @@ -7943,16 +8673,21 @@ of the SV is unaffected. */ SV* -Perl_sv_bless(pTHX_ SV *sv, HV *stash) +Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) { dVAR; SV *tmpRef; + + PERL_ARGS_ASSERT_SV_BLESS; + if (!SvROK(sv)) Perl_croak(aTHX_ "Can't bless non-reference value"); tmpRef = SvRV(sv); if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY)) { + if (SvIsCOW(tmpRef)) + sv_force_normal_flags(tmpRef, 0); if (SvREADONLY(tmpRef)) - Perl_croak(aTHX_ PL_no_modify); + Perl_croak(aTHX_ "%s", PL_no_modify); if (SvOBJECT(tmpRef)) { if (SvTYPE(tmpRef) != SVt_PVIO) --PL_sv_objcount; @@ -7963,7 +8698,7 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) if (SvTYPE(tmpRef) != SVt_PVIO) ++PL_sv_objcount; SvUPGRADE(tmpRef, SVt_PVMG); - SvSTASH_set(tmpRef, (HV*)SvREFCNT_inc_simple(stash)); + SvSTASH_set(tmpRef, MUTABLE_HV(SvREFCNT_inc_simple(stash))); if (Gv_AMG(stash)) SvAMAGIC_on(sv); @@ -7983,24 +8718,27 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) */ STATIC void -S_sv_unglob(pTHX_ SV *sv) +S_sv_unglob(pTHX_ SV *const sv) { dVAR; void *xpvmg; HV *stash; SV * const temp = sv_newmortal(); + PERL_ARGS_ASSERT_SV_UNGLOB; + assert(SvTYPE(sv) == SVt_PVGV); SvFAKE_off(sv); - gv_efullname3(temp, (GV *) sv, "*"); + gv_efullname3(temp, MUTABLE_GV(sv), "*"); if (GvGP(sv)) { - if(GvCVu((GV*)sv) && (stash = GvSTASH((GV*)sv)) && HvNAME_get(stash)) + if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) + && HvNAME_get(stash)) mro_method_changed_in(stash); - gp_free((GV*)sv); + gp_free(MUTABLE_GV(sv)); } if (GvSTASH(sv)) { - sv_del_backref((SV*)GvSTASH(sv), sv); + sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv); GvSTASH(sv) = NULL; } GvMULTI_off(sv); @@ -8038,10 +8776,12 @@ See C. */ void -Perl_sv_unref_flags(pTHX_ SV *ref, U32 flags) +Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags) { SV* const target = SvRV(ref); + PERL_ARGS_ASSERT_SV_UNREF_FLAGS; + if (SvWEAKREF(ref)) { sv_del_backref(target, ref); SvWEAKREF_off(ref); @@ -8066,8 +8806,10 @@ Untaint an SV. Use C instead. */ void -Perl_sv_untaint(pTHX_ SV *sv) +Perl_sv_untaint(pTHX_ SV *const sv) { + PERL_ARGS_ASSERT_SV_UNTAINT; + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); if (mg) @@ -8083,8 +8825,10 @@ Test an SV for taintedness. Use C instead. */ bool -Perl_sv_tainted(pTHX_ SV *sv) +Perl_sv_tainted(pTHX_ SV *const sv) { + PERL_ARGS_ASSERT_SV_TAINTED; + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); if (mg && (mg->mg_len & 1) ) @@ -8103,12 +8847,14 @@ Does not handle 'set' magic. See C. */ void -Perl_sv_setpviv(pTHX_ SV *sv, IV iv) +Perl_sv_setpviv(pTHX_ SV *const sv, const IV iv) { char buf[TYPE_CHARS(UV)]; char *ebuf; char * const ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); + PERL_ARGS_ASSERT_SV_SETPVIV; + sv_setpvn(sv, ptr, ebuf - ptr); } @@ -8121,8 +8867,10 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) +Perl_sv_setpviv_mg(pTHX_ SV *const sv, const IV iv) { + PERL_ARGS_ASSERT_SV_SETPVIV_MG; + sv_setpviv(sv, iv); SvSETMAGIC(sv); } @@ -8135,10 +8883,13 @@ Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) */ void -Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...) +Perl_sv_setpvf_nocontext(SV *const sv, const char *const pat, ...) { dTHX; va_list args; + + PERL_ARGS_ASSERT_SV_SETPVF_NOCONTEXT; + va_start(args, pat); sv_vsetpvf(sv, pat, &args); va_end(args); @@ -8150,10 +8901,13 @@ Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...) */ void -Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...) +Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...) { dTHX; va_list args; + + PERL_ARGS_ASSERT_SV_SETPVF_MG_NOCONTEXT; + va_start(args, pat); sv_vsetpvf_mg(sv, pat, &args); va_end(args); @@ -8170,9 +8924,12 @@ appending it. Does not handle 'set' magic. See C. */ void -Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...) +Perl_sv_setpvf(pTHX_ SV *const sv, const char *const pat, ...) { va_list args; + + PERL_ARGS_ASSERT_SV_SETPVF; + va_start(args, pat); sv_vsetpvf(sv, pat, &args); va_end(args); @@ -8190,8 +8947,10 @@ Usually used via its frontend C. */ void -Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args) +Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) { + PERL_ARGS_ASSERT_SV_VSETPVF; + sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); } @@ -8204,9 +8963,12 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...) +Perl_sv_setpvf_mg(pTHX_ SV *const sv, const char *const pat, ...) { va_list args; + + PERL_ARGS_ASSERT_SV_SETPVF_MG; + va_start(args, pat); sv_vsetpvf_mg(sv, pat, &args); va_end(args); @@ -8223,8 +8985,10 @@ Usually used via its frontend C. */ void -Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) +Perl_sv_vsetpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args) { + PERL_ARGS_ASSERT_SV_VSETPVF_MG; + sv_vsetpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); SvSETMAGIC(sv); } @@ -8237,10 +9001,13 @@ Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) */ void -Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...) +Perl_sv_catpvf_nocontext(SV *const sv, const char *const pat, ...) { dTHX; va_list args; + + PERL_ARGS_ASSERT_SV_CATPVF_NOCONTEXT; + va_start(args, pat); sv_vcatpvf(sv, pat, &args); va_end(args); @@ -8252,10 +9019,13 @@ Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...) */ void -Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...) +Perl_sv_catpvf_mg_nocontext(SV *const sv, const char *const pat, ...) { dTHX; va_list args; + + PERL_ARGS_ASSERT_SV_CATPVF_MG_NOCONTEXT; + va_start(args, pat); sv_vcatpvf_mg(sv, pat, &args); va_end(args); @@ -8276,9 +9046,12 @@ valid UTF-8; if the original SV was bytes, the pattern should be too. =cut */ void -Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...) +Perl_sv_catpvf(pTHX_ SV *const sv, const char *const pat, ...) { va_list args; + + PERL_ARGS_ASSERT_SV_CATPVF; + va_start(args, pat); sv_vcatpvf(sv, pat, &args); va_end(args); @@ -8296,8 +9069,10 @@ Usually used via its frontend C. */ void -Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args) +Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) { + PERL_ARGS_ASSERT_SV_VCATPVF; + sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); } @@ -8310,9 +9085,12 @@ Like C, but also handles 'set' magic. */ void -Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) +Perl_sv_catpvf_mg(pTHX_ SV *const sv, const char *const pat, ...) { va_list args; + + PERL_ARGS_ASSERT_SV_CATPVF_MG; + va_start(args, pat); sv_vcatpvf_mg(sv, pat, &args); va_end(args); @@ -8329,8 +9107,10 @@ Usually used via its frontend C. */ void -Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) +Perl_sv_vcatpvf_mg(pTHX_ SV *const sv, const char *const pat, va_list *const args) { + PERL_ARGS_ASSERT_SV_VCATPVF_MG; + sv_vcatpvfn(sv, pat, strlen(pat), args, NULL, 0, NULL); SvSETMAGIC(sv); } @@ -8347,17 +9127,23 @@ Usually used via one of its frontends C and C. */ void -Perl_sv_vsetpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) +Perl_sv_vsetpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, + va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted) { - sv_setpvn(sv, "", 0); + PERL_ARGS_ASSERT_SV_VSETPVFN; + + sv_setpvs(sv, ""); sv_vcatpvfn(sv, pat, patlen, args, svargs, svmax, maybe_tainted); } STATIC I32 -S_expect_number(pTHX_ char** pattern) +S_expect_number(pTHX_ char **const pattern) { dVAR; I32 var = 0; + + PERL_ARGS_ASSERT_EXPECT_NUMBER; + switch (**pattern) { case '1': case '2': case '3': case '4': case '5': case '6': @@ -8374,11 +9160,13 @@ S_expect_number(pTHX_ char** pattern) } STATIC char * -S_F0convert(NV nv, char *endbuf, STRLEN *len) +S_F0convert(NV nv, char *const endbuf, STRLEN *const len) { const int neg = nv < 0; UV uv; + PERL_ARGS_ASSERT_F0CONVERT; + if (neg) nv = -nv; if (nv < UV_MAX) { @@ -8422,7 +9210,8 @@ Usually used via one of its frontends C and C. /* XXX maybe_tainted is never assigned to, so the doc above is lying. */ void -Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV **svargs, I32 svmax, bool *maybe_tainted) +Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, + va_list *const args, SV **const svargs, const I32 svmax, bool *const maybe_tainted) { dVAR; char *p; @@ -8442,6 +9231,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* large enough for "%#.#f" --chip */ /* what about long double NVs? --jhi */ + PERL_ARGS_ASSERT_SV_VCATPVFN; PERL_UNUSED_ARG(maybe_tainted); /* no matter what, this is a string now */ @@ -8462,7 +9252,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } if (args && patlen == 3 && pat[0] == '%' && pat[1] == '-' && pat[2] == 'p') { - argsv = (SV*)va_arg(*args, void*); + argsv = MUTABLE_SV(va_arg(*args, void*)); sv_catsv(sv, argsv); return; } @@ -8537,6 +9327,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV STRLEN esignlen = 0; const char *eptr = NULL; + const char *fmtstart; STRLEN elen = 0; SV *vecsv = NULL; const U8 *vecstr = NULL; @@ -8577,6 +9368,8 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (q++ >= patend) break; + fmtstart = q; + /* We allow format specification elements in this order: \d+\$ explicit format parameter index @@ -8601,10 +9394,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV %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 + + %1p (VDf) removed. RMB 2007-10-19 */ char* r = q; bool sv = FALSE; @@ -8618,19 +9412,12 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV precis = n; has_precis = TRUE; } - argsv = (SV*)va_arg(*args, void*); + argsv = MUTABLE_SV(va_arg(*args, void*)); eptr = SvPV_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), @@ -8745,7 +9532,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV */ if (sv_derived_from(vecsv, "version")) { char *version = savesvpv(vecsv); - if ( hv_exists((HV*)SvRV(vecsv), "alpha", 5 ) ) { + if ( hv_exists(MUTABLE_HV(SvRV(vecsv)), "alpha", 5 ) ) { Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "vector argument not supported with alpha versions"); goto unknown; @@ -8978,8 +9765,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'l': iv = va_arg(*args, long); break; case 'V': iv = va_arg(*args, IV); break; default: iv = va_arg(*args, int); break; + case 'q': #ifdef HAS_QUAD - case 'q': iv = va_arg(*args, Quad_t); break; + iv = va_arg(*args, Quad_t); break; +#else + goto unknown; #endif } } @@ -8990,8 +9780,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'l': iv = (long)tiv; break; case 'V': default: iv = tiv; break; + case 'q': #ifdef HAS_QUAD - case 'q': iv = (Quad_t)tiv; break; + iv = (Quad_t)tiv; break; +#else + goto unknown; #endif } } @@ -9063,8 +9856,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'l': uv = va_arg(*args, unsigned long); break; case 'V': uv = va_arg(*args, UV); break; default: uv = va_arg(*args, unsigned); break; + case 'q': #ifdef HAS_QUAD - case 'q': uv = va_arg(*args, Uquad_t); break; + uv = va_arg(*args, Uquad_t); break; +#else + goto unknown; #endif } } @@ -9075,8 +9871,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV case 'l': uv = (unsigned long)tuv; break; case 'V': default: uv = tuv; break; + case 'q': #ifdef HAS_QUAD - case 'q': uv = (Uquad_t)tuv; break; + uv = (Uquad_t)tuv; break; +#else + goto unknown; #endif } } @@ -9194,7 +9993,9 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV : SvNV(argsv); need = 0; - if (c != 'e' && c != 'E') { + /* nv * 0 will be NaN for NaN, +Inf and -Inf, and 0 for anything + else. frexp() has some unspecified behaviour for those three */ + if (c != 'e' && c != 'E' && (nv * 0) == 0) { i = PERL_INT_MIN; /* FIXME: if HAS_LONG_DOUBLE but not USE_LONG_DOUBLE this will cast our (long double) to (double) */ @@ -9360,8 +10161,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV default: *(va_arg(*args, int*)) = i; break; case 'l': *(va_arg(*args, long*)) = i; break; case 'V': *(va_arg(*args, IV*)) = i; break; + case 'q': #ifdef HAS_QUAD - case 'q': *(va_arg(*args, Quad_t*)) = i; break; + *(va_arg(*args, Quad_t*)) = i; break; +#else + goto unknown; #endif } } @@ -9380,16 +10184,22 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV SV * const msg = sv_newmortal(); Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", (PL_op->op_type == OP_PRTF) ? "" : "s"); - if (c) { - if (isPRINT(c)) - Perl_sv_catpvf(aTHX_ msg, - "\"%%%c\"", c & 0xFF); - else - Perl_sv_catpvf(aTHX_ msg, - "\"%%\\%03"UVof"\"", - (UV)c & 0xFF); - } else + if (fmtstart < patend) { + const char * const fmtend = q < patend ? q : patend; + const char * f; + sv_catpvs(msg, "\"%"); + for (f = fmtstart; f < fmtend; f++) { + if (isPRINT(*f)) { + sv_catpvn(msg, f, 1); + } else { + Perl_sv_catpvf(aTHX_ msg, + "\\%03"UVof, (UV)*f & 0xFF); + } + } + sv_catpvs(msg, "\""); + } else { sv_catpvs(msg, "end of string"); + } Perl_warner(aTHX_ packWARN(WARN_PRINTF), "%"SVf, SVfARG(msg)); /* yes, this is reentrant */ } @@ -9417,7 +10227,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV } else { const STRLEN old_elen = elen; - SV * const nsv = sv_2mortal(newSVpvn(eptr, elen)); + SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP); sv_utf8_upgrade(nsv); eptr = SvPVX_const(nsv); elen = SvCUR(nsv); @@ -9431,13 +10241,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV have = esignlen + zeros + elen; if (have < zeros) - Perl_croak_nocontext(PL_memory_wrap); + Perl_croak_nocontext("%s", PL_memory_wrap); need = (have > width ? have : width); gap = need - have; if (need >= (((STRLEN)~0) - SvCUR(sv) - dotstrlen - 1)) - Perl_croak_nocontext(PL_memory_wrap); + Perl_croak_nocontext("%s", PL_memory_wrap); SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); p = SvEND(sv); if (esignlen && fill == '0') { @@ -9495,7 +10305,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV All the macros and functions in this section are for the private use of the main function, perl_clone(). -The foo_dup() functions make an exact copy of an existing foo thinngy. +The foo_dup() functions make an exact copy of an existing foo thingy. During the course of a cloning, a hash table is used to map old addresses to new addresses. The table is created and manipulated with the ptr_table_* functions. @@ -9518,26 +10328,28 @@ ptr_table_* functions. If this changes, please unmerge ss_dup. */ #define sv_dup_inc(s,t) SvREFCNT_inc(sv_dup(s,t)) #define sv_dup_inc_NN(s,t) SvREFCNT_inc_NN(sv_dup(s,t)) -#define av_dup(s,t) (AV*)sv_dup((SV*)s,t) -#define av_dup_inc(s,t) (AV*)SvREFCNT_inc(sv_dup((SV*)s,t)) -#define hv_dup(s,t) (HV*)sv_dup((SV*)s,t) -#define hv_dup_inc(s,t) (HV*)SvREFCNT_inc(sv_dup((SV*)s,t)) -#define cv_dup(s,t) (CV*)sv_dup((SV*)s,t) -#define cv_dup_inc(s,t) (CV*)SvREFCNT_inc(sv_dup((SV*)s,t)) -#define io_dup(s,t) (IO*)sv_dup((SV*)s,t) -#define io_dup_inc(s,t) (IO*)SvREFCNT_inc(sv_dup((SV*)s,t)) -#define gv_dup(s,t) (GV*)sv_dup((SV*)s,t) -#define gv_dup_inc(s,t) (GV*)SvREFCNT_inc(sv_dup((SV*)s,t)) +#define av_dup(s,t) MUTABLE_AV(sv_dup((const SV *)s,t)) +#define av_dup_inc(s,t) MUTABLE_AV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define hv_dup(s,t) MUTABLE_HV(sv_dup((const SV *)s,t)) +#define hv_dup_inc(s,t) MUTABLE_HV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define cv_dup(s,t) MUTABLE_CV(sv_dup((const SV *)s,t)) +#define cv_dup_inc(s,t) MUTABLE_CV(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define io_dup(s,t) MUTABLE_IO(sv_dup((const SV *)s,t)) +#define io_dup_inc(s,t) MUTABLE_IO(SvREFCNT_inc(sv_dup((const SV *)s,t))) +#define gv_dup(s,t) MUTABLE_GV(sv_dup((const SV *)s,t)) +#define gv_dup_inc(s,t) MUTABLE_GV(SvREFCNT_inc(sv_dup((const SV *)s,t))) #define SAVEPV(p) ((p) ? savepv(p) : NULL) #define SAVEPVN(p,n) ((p) ? savepvn(p,n) : NULL) /* clone a parser */ yy_parser * -Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) +Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) { yy_parser *parser; + PERL_ARGS_ASSERT_PARSER_DUP; + if (!proto) return NULL; @@ -9651,10 +10463,11 @@ Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param) /* duplicate a file handle */ PerlIO * -Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param) +Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param) { PerlIO *ret; + PERL_ARGS_ASSERT_FP_DUP; PERL_UNUSED_ARG(type); if (!fp) @@ -9674,7 +10487,7 @@ Perl_fp_dup(pTHX_ PerlIO *fp, char type, CLONE_PARAMS *param) /* duplicate a directory handle */ DIR * -Perl_dirp_dup(pTHX_ DIR *dp) +Perl_dirp_dup(pTHX_ DIR *const dp) { PERL_UNUSED_CONTEXT; if (!dp) @@ -9686,10 +10499,12 @@ Perl_dirp_dup(pTHX_ DIR *dp) /* duplicate a typeglob */ GP * -Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param) +Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param) { GP *ret; + PERL_ARGS_ASSERT_GP_DUP; + if (!gp) return (GP*)NULL; /* look for it in the table first */ @@ -9719,10 +10534,13 @@ Perl_gp_dup(pTHX_ GP *gp, CLONE_PARAMS* param) /* duplicate a chain of magic */ MAGIC * -Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) +Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param) { MAGIC *mgprev = (MAGIC*)NULL; MAGIC *mgret; + + PERL_ARGS_ASSERT_MG_DUP; + if (!mg) return (MAGIC*)NULL; /* look for it in the table first */ @@ -9741,13 +10559,17 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) nmg->mg_private = mg->mg_private; nmg->mg_type = mg->mg_type; nmg->mg_flags = mg->mg_flags; + /* FIXME for plugins if (mg->mg_type == PERL_MAGIC_qr) { - nmg->mg_obj = (SV*)CALLREGDUPE((REGEXP*)mg->mg_obj, param); + nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)mg->mg_obj, param)); } - else if(mg->mg_type == PERL_MAGIC_backref) { + else + */ + if(mg->mg_type == PERL_MAGIC_backref) { /* The backref AV has its reference count deliberately bumped by 1. */ - nmg->mg_obj = SvREFCNT_inc(av_dup_inc((AV*) mg->mg_obj, param)); + nmg->mg_obj + = SvREFCNT_inc(av_dup_inc((const AV *) mg->mg_obj, param)); } else { nmg->mg_obj = (mg->mg_flags & MGf_REFCOUNTED) @@ -9771,7 +10593,7 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS* param) } } else if (mg->mg_len == HEf_SVKEY) - nmg->mg_ptr = (char*)sv_dup_inc((SV*)mg->mg_ptr, param); + nmg->mg_ptr = (char*)sv_dup_inc((const SV *)mg->mg_ptr, param); } if ((mg->mg_flags & MGf_DUP) && mg->mg_virtual && mg->mg_virtual->svt_dup) { CALL_FPTR(nmg->mg_virtual->svt_dup)(aTHX_ nmg, param); @@ -9812,10 +10634,13 @@ Perl_ptr_table_new(pTHX) /* map an existing pointer using a table */ STATIC PTR_TBL_ENT_t * -S_ptr_table_find(PTR_TBL_t *tbl, const void *sv) { +S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv) +{ PTR_TBL_ENT_t *tblent; const UV hash = PTR_TABLE_HASH(sv); - assert(tbl); + + PERL_ARGS_ASSERT_PTR_TABLE_FIND; + tblent = tbl->tbl_ary[hash & tbl->tbl_max]; for (; tblent; tblent = tblent->next) { if (tblent->oldval == sv) @@ -9825,19 +10650,24 @@ S_ptr_table_find(PTR_TBL_t *tbl, const void *sv) { } void * -Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *tbl, const void *sv) +Perl_ptr_table_fetch(pTHX_ PTR_TBL_t *const tbl, const void *const sv) { PTR_TBL_ENT_t const *const tblent = ptr_table_find(tbl, sv); + + PERL_ARGS_ASSERT_PTR_TABLE_FETCH; PERL_UNUSED_CONTEXT; + return tblent ? tblent->newval : NULL; } /* add a new entry to a pointer-mapping table */ void -Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv) +Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void *const newsv) { PTR_TBL_ENT_t *tblent = ptr_table_find(tbl, oldsv); + + PERL_ARGS_ASSERT_PTR_TABLE_STORE; PERL_UNUSED_CONTEXT; if (tblent) { @@ -9860,12 +10690,14 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *tbl, const void *oldsv, void *newsv) /* double the hash bucket size of an existing ptr table */ void -Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) +Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl) { PTR_TBL_ENT_t **ary = tbl->tbl_ary; const UV oldsize = tbl->tbl_max + 1; UV newsize = oldsize * 2; UV i; + + PERL_ARGS_ASSERT_PTR_TABLE_SPLIT; PERL_UNUSED_CONTEXT; Renew(ary, newsize, PTR_TBL_ENT_t*); @@ -9893,7 +10725,7 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *tbl) /* remove all the entries from a ptr table */ void -Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl) +Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl) { if (tbl && tbl->tbl_items) { register PTR_TBL_ENT_t * const * const array = tbl->tbl_ary; @@ -9916,7 +10748,7 @@ Perl_ptr_table_clear(pTHX_ PTR_TBL_t *tbl) /* clear and free a ptr table */ void -Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) +Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl) { if (!tbl) { return; @@ -9929,12 +10761,14 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *tbl) #if defined(USE_ITHREADS) void -Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param) +Perl_rvpv_dup(pTHX_ SV *const dstr, const SV *const sstr, CLONE_PARAMS *const param) { + PERL_ARGS_ASSERT_RVPV_DUP; + if (SvROK(sstr)) { SvRV_set(dstr, SvWEAKREF(sstr) - ? sv_dup(SvRV(sstr), param) - : sv_dup_inc(SvRV(sstr), param)); + ? sv_dup(SvRV_const(sstr), param) + : sv_dup_inc(SvRV_const(sstr), param)); } else if (SvPVX_const(sstr)) { @@ -9962,31 +10796,36 @@ Perl_rvpv_dup(pTHX_ SV *dstr, const SV *sstr, CLONE_PARAMS* param) } else { /* Some other special case - random pointer */ - SvPV_set(dstr, SvPVX(sstr)); + SvPV_set(dstr, (char *) SvPVX_const(sstr)); } } } else { /* Copy the NULL */ - if (SvTYPE(dstr) == SVt_RV) - SvRV_set(dstr, NULL); - else - SvPV_set(dstr, NULL); + SvPV_set(dstr, NULL); } } /* duplicate an SV of any type (including AV, HV etc) */ SV * -Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) +Perl_sv_dup(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) { dVAR; SV *dstr; - if (!sstr || SvTYPE(sstr) == SVTYPEMASK) + PERL_ARGS_ASSERT_SV_DUP; + + if (!sstr) return NULL; + if (SvTYPE(sstr) == SVTYPEMASK) { +#ifdef DEBUG_LEAKING_SCALARS_ABORT + abort(); +#endif + return NULL; + } /* look for it in the table first */ - dstr = (SV*)ptr_table_fetch(PL_ptr_table, sstr); + dstr = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, sstr)); if (dstr) return dstr; @@ -9994,10 +10833,10 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) /** We are joining here so we don't want do clone something that is bad **/ if (SvTYPE(sstr) == SVt_PVHV) { - const char * const hvname = HvNAME_get(sstr); + const HEK * const hvname = HvNAME_HEK(sstr); if (hvname) /** don't clone stashes if they already exist **/ - return (SV*)gv_stashpv(hvname,0); + return MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), 0)); } } @@ -10027,8 +10866,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) /* don't clone objects whose class has asked us not to */ if (SvOBJECT(sstr) && ! (SvFLAGS(SvSTASH(sstr)) & SVphv_CLONEABLE)) { - SvFLAGS(dstr) &= ~SVTYPEMASK; - SvOBJECT_off(dstr); + SvFLAGS(dstr) = 0; return dstr; } @@ -10038,16 +10876,16 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) break; case SVt_IV: SvANY(dstr) = (XPVIV*)((char*)&(dstr->sv_u.svu_iv) - STRUCT_OFFSET(XPVIV, xiv_iv)); - SvIV_set(dstr, SvIVX(sstr)); + if(SvROK(sstr)) { + Perl_rvpv_dup(aTHX_ dstr, sstr, param); + } else { + SvIV_set(dstr, SvIVX(sstr)); + } break; case SVt_NV: SvANY(dstr) = new_XNV(); SvNV_set(dstr, SvNVX(sstr)); break; - case SVt_RV: - SvANY(dstr) = &(dstr->sv_u.svu_rv); - Perl_rvpv_dup(aTHX_ dstr, sstr, param); - break; /* case SVt_BIND: */ default: { @@ -10063,7 +10901,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) break; case SVt_PVGV: - if (GvUNIQUE((GV*)sstr)) { + if (GvUNIQUE((const GV *)sstr)) { NOOP; /* Do sharing here, and fall through */ } case SVt_PVIO: @@ -10072,6 +10910,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) case SVt_PVAV: case SVt_PVCV: case SVt_PVLV: + case SVt_REGEXP: case SVt_PVMG: case SVt_PVNV: case SVt_PVIV: @@ -10126,12 +10965,16 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) break; case SVt_PVMG: break; + case SVt_REGEXP: + /* FIXME for plugins */ + re_dup_guts((REGEXP*) sstr, (REGEXP*) dstr, param); + break; case SVt_PVLV: /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ if (LvTYPE(dstr) == 't') /* for tie: unrefcnted fake (SV**) */ LvTARG(dstr) = dstr; else if (LvTYPE(dstr) == 'T') /* for tie: fake HE */ - LvTARG(dstr) = (SV*)he_dup((HE*)LvTARG(dstr), 0, param); + LvTARG(dstr) = MUTABLE_SV(he_dup((HE*)LvTARG(dstr), 0, param)); else LvTARG(dstr) = sv_dup_inc(LvTARG(dstr), param); case SVt_PVGV: @@ -10179,16 +11022,17 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(dstr)); break; case SVt_PVAV: - if (AvARRAY((AV*)sstr)) { + /* avoid cloning an empty array */ + if (AvARRAY((const AV *)sstr) && AvFILLp((const AV *)sstr) >= 0) { SV **dst_ary, **src_ary; - SSize_t items = AvFILLp((AV*)sstr) + 1; + SSize_t items = AvFILLp((const AV *)sstr) + 1; - src_ary = AvARRAY((AV*)sstr); - Newxz(dst_ary, AvMAX((AV*)sstr)+1, SV*); + src_ary = AvARRAY((const AV *)sstr); + Newxz(dst_ary, AvMAX((const AV *)sstr)+1, SV*); ptr_table_store(PL_ptr_table, src_ary, dst_ary); - AvARRAY((AV*)dstr) = dst_ary; - AvALLOC((AV*)dstr) = dst_ary; - if (AvREAL((AV*)sstr)) { + AvARRAY(MUTABLE_AV(dstr)) = dst_ary; + AvALLOC((const AV *)dstr) = dst_ary; + if (AvREAL((const AV *)sstr)) { while (items-- > 0) *dst_ary++ = sv_dup_inc(*src_ary++, param); } @@ -10196,18 +11040,20 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) while (items-- > 0) *dst_ary++ = sv_dup(*src_ary++, param); } - items = AvMAX((AV*)sstr) - AvFILLp((AV*)sstr); + items = AvMAX((const AV *)sstr) - AvFILLp((const AV *)sstr); while (items-- > 0) { *dst_ary++ = &PL_sv_undef; } } else { - AvARRAY((AV*)dstr) = NULL; - AvALLOC((AV*)dstr) = (SV**)NULL; + AvARRAY(MUTABLE_AV(dstr)) = NULL; + AvALLOC((const AV *)dstr) = (SV**)NULL; + AvMAX( (const AV *)dstr) = -1; + AvFILLp((const AV *)dstr) = -1; } break; case SVt_PVHV: - if (HvARRAY((HV*)sstr)) { + if (HvARRAY((const HV *)sstr)) { STRLEN i = 0; const bool sharekeys = !!HvSHAREKEYS(sstr); XPVHV * const dxhv = (XPVHV*)SvANY(dstr); @@ -10238,10 +11084,11 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) daux->xhv_eiter = saux->xhv_eiter ? he_dup(saux->xhv_eiter, (bool)!!HvSHAREKEYS(sstr), param) : 0; + /* backref array needs refcnt=2; see sv_add_backref */ daux->xhv_backreferences = saux->xhv_backreferences - ? (AV*) SvREFCNT_inc( - sv_dup((SV*)saux->xhv_backreferences, param)) + ? MUTABLE_AV(SvREFCNT_inc( + sv_dup_inc((const SV *)saux->xhv_backreferences, param))) : 0; daux->xhv_mro_meta = saux->xhv_mro_meta @@ -10254,7 +11101,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) } } else - HvARRAY((HV*)dstr) = NULL; + HvARRAY(MUTABLE_HV(dstr)) = NULL; break; case SVt_PVCV: if (!(param->flags & CLONEf_COPY_STACKS)) { @@ -10270,7 +11117,7 @@ Perl_sv_dup(pTHX_ const SV *sstr, CLONE_PARAMS* param) if (CvCONST(dstr) && CvISXSUB(dstr)) { CvXSUBANY(dstr).any_ptr = GvUNIQUE(CvGV(dstr)) ? SvREFCNT_inc(CvXSUBANY(dstr).any_ptr) : - sv_dup_inc((SV *)CvXSUBANY(dstr).any_ptr, param); + sv_dup_inc((const SV *)CvXSUBANY(dstr).any_ptr, param); } /* don't dup if copying back - CvGV isn't refcounted, so the * duped GV may never be freed. A bit of a hack! DAPM */ @@ -10301,6 +11148,8 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) { PERL_CONTEXT *ncxs; + PERL_ARGS_ASSERT_CX_DUP; + if (!cxs) return (PERL_CONTEXT*)NULL; @@ -10310,69 +11159,64 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) return ncxs; /* create anew and remember what it is */ - Newxz(ncxs, max + 1, PERL_CONTEXT); + Newx(ncxs, max + 1, PERL_CONTEXT); ptr_table_store(PL_ptr_table, cxs, ncxs); + Copy(cxs, ncxs, max + 1, PERL_CONTEXT); while (ix >= 0) { - PERL_CONTEXT * const cx = &cxs[ix]; PERL_CONTEXT * const ncx = &ncxs[ix]; - ncx->cx_type = cx->cx_type; - if (CxTYPE(cx) == CXt_SUBST) { + if (CxTYPE(ncx) == CXt_SUBST) { Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); } else { - ncx->blk_oldsp = cx->blk_oldsp; - ncx->blk_oldcop = cx->blk_oldcop; - ncx->blk_oldmarksp = cx->blk_oldmarksp; - ncx->blk_oldscopesp = cx->blk_oldscopesp; - ncx->blk_oldpm = cx->blk_oldpm; - ncx->blk_gimme = cx->blk_gimme; - switch (CxTYPE(cx)) { + switch (CxTYPE(ncx)) { case CXt_SUB: - ncx->blk_sub.cv = (cx->blk_sub.olddepth == 0 - ? cv_dup_inc(cx->blk_sub.cv, param) - : cv_dup(cx->blk_sub.cv,param)); - ncx->blk_sub.argarray = (cx->blk_sub.hasargs - ? av_dup_inc(cx->blk_sub.argarray, param) + ncx->blk_sub.cv = (ncx->blk_sub.olddepth == 0 + ? cv_dup_inc(ncx->blk_sub.cv, param) + : cv_dup(ncx->blk_sub.cv,param)); + ncx->blk_sub.argarray = (CxHASARGS(ncx) + ? av_dup_inc(ncx->blk_sub.argarray, + param) : NULL); - ncx->blk_sub.savearray = av_dup_inc(cx->blk_sub.savearray, param); - ncx->blk_sub.olddepth = cx->blk_sub.olddepth; - ncx->blk_sub.hasargs = cx->blk_sub.hasargs; - ncx->blk_sub.lval = cx->blk_sub.lval; - ncx->blk_sub.retop = cx->blk_sub.retop; + ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray, + param); ncx->blk_sub.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, - cx->blk_sub.oldcomppad); + ncx->blk_sub.oldcomppad); break; case CXt_EVAL: - ncx->blk_eval.old_in_eval = cx->blk_eval.old_in_eval; - ncx->blk_eval.old_op_type = cx->blk_eval.old_op_type; - ncx->blk_eval.old_namesv = sv_dup_inc(cx->blk_eval.old_namesv, param); - ncx->blk_eval.old_eval_root = cx->blk_eval.old_eval_root; - ncx->blk_eval.cur_text = sv_dup(cx->blk_eval.cur_text, param); - ncx->blk_eval.retop = cx->blk_eval.retop; + ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv, + param); + ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param); break; - case CXt_LOOP: - ncx->blk_loop.label = cx->blk_loop.label; - ncx->blk_loop.resetsp = cx->blk_loop.resetsp; - ncx->blk_loop.my_op = cx->blk_loop.my_op; - ncx->blk_loop.iterdata = (CxPADLOOP(cx) - ? cx->blk_loop.iterdata - : gv_dup((GV*)cx->blk_loop.iterdata, param)); - ncx->blk_loop.oldcomppad - = (PAD*)ptr_table_fetch(PL_ptr_table, - cx->blk_loop.oldcomppad); - ncx->blk_loop.itersave = sv_dup_inc(cx->blk_loop.itersave, param); - ncx->blk_loop.iterlval = sv_dup_inc(cx->blk_loop.iterlval, param); - ncx->blk_loop.iterary = av_dup_inc(cx->blk_loop.iterary, param); - ncx->blk_loop.iterix = cx->blk_loop.iterix; - ncx->blk_loop.itermax = cx->blk_loop.itermax; + case CXt_LOOP_LAZYSV: + ncx->blk_loop.state_u.lazysv.end + = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param); + /* We are taking advantage of av_dup_inc and sv_dup_inc + actually being the same function, and order equivalance of + the two unions. + We can assert the later [but only at run time :-(] */ + assert ((void *) &ncx->blk_loop.state_u.ary.ary == + (void *) &ncx->blk_loop.state_u.lazysv.cur); + case CXt_LOOP_FOR: + ncx->blk_loop.state_u.ary.ary + = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param); + case CXt_LOOP_LAZYIV: + case CXt_LOOP_PLAIN: + if (CxPADLOOP(ncx)) { + ncx->blk_loop.oldcomppad + = (PAD*)ptr_table_fetch(PL_ptr_table, + ncx->blk_loop.oldcomppad); + } else { + ncx->blk_loop.oldcomppad + = (PAD*)gv_dup((const GV *)ncx->blk_loop.oldcomppad, + param); + } break; case CXt_FORMAT: - ncx->blk_sub.cv = cv_dup(cx->blk_sub.cv, param); - ncx->blk_sub.gv = gv_dup(cx->blk_sub.gv, param); - ncx->blk_sub.dfoutgv = gv_dup_inc(cx->blk_sub.dfoutgv, param); - ncx->blk_sub.hasargs = cx->blk_sub.hasargs; - ncx->blk_sub.retop = cx->blk_sub.retop; + ncx->blk_format.cv = cv_dup(ncx->blk_format.cv, param); + ncx->blk_format.gv = gv_dup(ncx->blk_format.gv, param); + ncx->blk_format.dfoutgv = gv_dup_inc(ncx->blk_format.dfoutgv, + param); break; case CXt_BLOCK: case CXt_NULL: @@ -10391,6 +11235,8 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) { PERL_SI *nsi; + PERL_ARGS_ASSERT_SI_DUP; + if (!si) return (PERL_SI*)NULL; @@ -10444,6 +11290,8 @@ Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl) { void *ret; + PERL_ARGS_ASSERT_ANY_DUP; + if (!v) return (void*)NULL; @@ -10472,10 +11320,10 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) const I32 max = proto_perl->Isavestack_max; I32 ix = proto_perl->Isavestack_ix; ANY *nss; - SV *sv; - GV *gv; - AV *av; - HV *hv; + const SV *sv; + const GV *gv; + const AV *av; + const HV *hv; void* ptr; int intval; long longval; @@ -10486,6 +11334,8 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) void (*dptr) (void*); void (*dxptr) (pTHX_ void*); + PERL_ARGS_ASSERT_SS_DUP; + Newxz(nss, max, ANY); while (ix > 0) { @@ -10493,17 +11343,17 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPINT(nss,ix) = type; switch (type) { case SAVEt_HELEM: /* hash element */ - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); /* fall through */ case SAVEt_ITEM: /* normal string */ case SAVEt_SV: /* scalar reference */ - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); /* fall through */ case SAVEt_FREESV: case SAVEt_MORTALIZESV: - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); break; case SAVEt_SHARED_PVREF: /* char* in shared space */ @@ -10514,19 +11364,19 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) break; case SAVEt_GENERIC_SVREF: /* generic sv */ case SAVEt_SVREF: /* scalar reference */ - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ break; case SAVEt_HV: /* hash reference */ case SAVEt_AV: /* array reference */ - sv = (SV*) POPPTR(ss,ix); + sv = (const SV *) POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); /* fall through */ case SAVEt_COMPPAD: case SAVEt_NSTAB: - sv = (SV*) POPPTR(ss,ix); + sv = (const SV *) POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup(sv, param); break; case SAVEt_INT: /* int reference */ @@ -10563,7 +11413,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) case SAVEt_SPTR: /* SV* reference */ ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup(sv, param); break; case SAVEt_VPTR: /* random* reference */ @@ -10583,7 +11433,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) gp = (GP*)POPPTR(ss,ix); TOPPTR(nss,ix) = gp = gp_dup(gp, param); (void)GpREFCNT_inc(gp); - gv = (GV*)POPPTR(ss,ix); + gv = (const GV *)POPPTR(ss,ix); TOPPTR(nss,ix) = gv_dup_inc(gv, param); break; case SAVEt_FREEOP: @@ -10612,16 +11462,16 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) else TOPPTR(nss,ix) = NULL; break; - case SAVEt_FREEPV: - c = (char*)POPPTR(ss,ix); - TOPPTR(nss,ix) = pv_dup_inc(c); - break; case SAVEt_DELETE: - hv = (HV*)POPPTR(ss,ix); + hv = (const HV *)POPPTR(ss,ix); TOPPTR(nss,ix) = hv_dup_inc(hv, param); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + /* Fall through */ + case SAVEt_FREEPV: c = (char*)POPPTR(ss,ix); TOPPTR(nss,ix) = pv_dup_inc(c); - /* fall through */ + break; case SAVEt_STACK_POS: /* Position on Perl stack */ i = POPINT(ss,ix); TOPINT(nss,ix) = i; @@ -10649,11 +11499,11 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) ix -= i; break; case SAVEt_AELEM: /* array element */ - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup_inc(sv, param); i = POPINT(ss,ix); TOPINT(nss,ix) = i; - av = (AV*)POPPTR(ss,ix); + av = (const AV *)POPPTR(ss,ix); TOPPTR(nss,ix) = av_dup_inc(av, param); break; case SAVEt_OP: @@ -10661,8 +11511,6 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPPTR(nss,ix) = ptr; break; case SAVEt_HINTS: - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; ptr = POPPTR(ss,ix); if (ptr) { HINTS_REFCNT_LOCK; @@ -10670,18 +11518,20 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) HINTS_REFCNT_UNLOCK; } TOPPTR(nss,ix) = ptr; + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; if (i & HINT_LOCALIZE_HH) { - hv = (HV*)POPPTR(ss,ix); + hv = (const HV *)POPPTR(ss,ix); TOPPTR(nss,ix) = hv_dup_inc(hv, param); } break; - case SAVEt_PADSV: + case SAVEt_PADSV_AND_MORTALIZE: longval = (long)POPLONG(ss,ix); TOPLONG(nss,ix) = longval; ptr = POPPTR(ss,ix); TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - sv = (SV*)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup(sv, param); + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); break; case SAVEt_BOOL: ptr = POPPTR(ss,ix); @@ -10694,7 +11544,7 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) TOPINT(nss,ix) = i; i = POPINT(ss,ix); TOPINT(nss,ix) = i; - sv = (SV*)POPPTR(ss,ix); + sv = (const SV *)POPPTR(ss,ix); TOPPTR(nss,ix) = sv_dup(sv, param); break; case SAVEt_RE_STATE: @@ -10781,11 +11631,11 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) * so we know which stashes want their objects cloned */ static void -do_mark_cloneable_stash(pTHX_ SV *sv) +do_mark_cloneable_stash(pTHX_ SV *const sv) { - const HEK * const hvname = HvNAME_HEK((HV*)sv); + const HEK * const hvname = HvNAME_HEK((const HV *)sv); if (hvname) { - GV* const cloner = gv_fetchmethod_autoload((HV*)sv, "CLONE_SKIP", 0); + GV* const cloner = gv_fetchmethod_autoload(MUTABLE_HV(sv), "CLONE_SKIP", 0); SvFLAGS(sv) |= SVphv_CLONEABLE; /* clone objects by default */ if (cloner && GvCV(cloner)) { dSP; @@ -10794,9 +11644,9 @@ do_mark_cloneable_stash(pTHX_ SV *sv) ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVhek(hvname))); + mXPUSHs(newSVhek(hvname)); PUTBACK; - call_sv((SV*)GvCV(cloner), G_SCALAR); + call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR); SPAGAIN; status = POPu; PUTBACK; @@ -10857,6 +11707,8 @@ perl_clone(PerlInterpreter *proto_perl, UV flags) dVAR; #ifdef PERL_IMPLICIT_SYS + PERL_ARGS_ASSERT_PERL_CLONE; + /* perlhost.h so we need to call into it to clone the host, CPerlHost should have a c interface, sky */ @@ -10892,6 +11744,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, CLONE_PARAMS* const param = &clone_params; PerlInterpreter * const my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); + + PERL_ARGS_ASSERT_PERL_CLONE_USING; + /* for each stash, determine whether its objects should be cloned */ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); PERL_SET_THX(my_perl); @@ -10927,6 +11782,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, CLONE_PARAMS clone_params; CLONE_PARAMS* param = &clone_params; PerlInterpreter * const my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); + + PERL_ARGS_ASSERT_PERL_CLONE; + /* for each stash, determine whether its objects should be cloned */ S_visit(proto_perl, do_mark_cloneable_stash, SVt_PVHV, SVTYPEMASK); PERL_SET_THX(my_perl); @@ -11061,7 +11919,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_patchlevel = sv_dup_inc(proto_perl->Ipatchlevel, param); PL_localpatches = proto_perl->Ilocalpatches; PL_splitstr = proto_perl->Isplitstr; - PL_preprocess = proto_perl->Ipreprocess; PL_minus_n = proto_perl->Iminus_n; PL_minus_p = proto_perl->Iminus_p; PL_minus_l = proto_perl->Iminus_l; @@ -11093,9 +11950,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif PL_encoding = sv_dup(proto_perl->Iencoding, param); - sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */ - sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */ - sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */ + sv_setpvs(PERL_DEBUG_PAD(0), ""); /* For regex debugging. */ + sv_setpvs(PERL_DEBUG_PAD(1), ""); /* ext/re needs these */ + sv_setpvs(PERL_DEBUG_PAD(2), ""); /* even without DEBUGGING. */ /* RE engine related */ @@ -11104,29 +11961,15 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_regmatch_slab = NULL; /* Clone the regex array */ - PL_regex_padav = newAV(); - { - const I32 len = av_len((AV*)proto_perl->Iregex_padav); - SV* const * const regexen = AvARRAY((AV*)proto_perl->Iregex_padav); - IV i; - av_push(PL_regex_padav, sv_dup_inc_NN(regexen[0],param)); - for(i = 1; i <= len; i++) { - const SV * const regex = regexen[i]; - SV * const sv = - SvREPADTMP(regex) - ? sv_dup_inc(regex, param) - : SvREFCNT_inc( - newSViv(PTR2IV(CALLREGDUPE( - INT2PTR(REGEXP *, SvIVX(regex)), param)))) - ; - if (SvFLAGS(regex) & SVf_BREAK) - SvFLAGS(sv) |= SVf_BREAK; /* unrefcnted PL_curpm */ - av_push(PL_regex_padav, sv); - } - } + /* ORANGE FIXME for plugins, probably in the SV dup code. + newSViv(PTR2IV(CALLREGDUPE( + INT2PTR(REGEXP *, SvIVX(regex)), param)))) + */ + PL_regex_padav = av_dup_inc(proto_perl->Iregex_padav, param); PL_regex_pad = AvARRAY(PL_regex_padav); /* shortcuts to various I/O objects */ + PL_ofsgv = gv_dup(proto_perl->Iofsgv, param); PL_stdingv = gv_dup(proto_perl->Istdingv, param); PL_stderrgv = gv_dup(proto_perl->Istderrgv, param); PL_defgv = gv_dup(proto_perl->Idefgv, param); @@ -11167,7 +12010,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_sub_generation = proto_perl->Isub_generation; PL_isarev = hv_dup_inc(proto_perl->Iisarev, param); - PL_delayedisa = hv_dup_inc(proto_perl->Idelayedisa, param); /* funky return mechanisms */ PL_forkprocess = proto_perl->Iforkprocess; @@ -11270,11 +12112,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_runops = proto_perl->Irunops; -#ifdef CSH - PL_cshlen = proto_perl->Icshlen; - PL_cshname = proto_perl->Icshname; /* XXX never deallocated */ -#endif - PL_parser = parser_dup(proto_perl->Iparser, param); PL_subline = proto_perl->Isubline; @@ -11351,6 +12188,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_lockhook = proto_perl->Ilockhook; PL_unlockhook = proto_perl->Iunlockhook; PL_threadhook = proto_perl->Ithreadhook; + PL_destroyhook = proto_perl->Idestroyhook; #ifdef THREADS_HAVE_PIDS PL_ppid = proto_perl->Ippid; @@ -11448,8 +12286,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, * orphaned */ for (i = 0; i<= proto_perl->Itmps_ix; i++) { - SV * const nsv = (SV*)ptr_table_fetch(PL_ptr_table, - proto_perl->Itmps_stack[i]); + SV * const nsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, + proto_perl->Itmps_stack[i])); if (nsv && !SvREFCNT(nsv)) { EXTEND_MORTAL(1); PL_tmps_stack[++PL_tmps_ix] = SvREFCNT_inc_simple(nsv); @@ -11464,7 +12302,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_Sv = NULL; PL_Xpv = (XPV*)NULL; - PL_na = proto_perl->Ina; + my_perl->Ina = proto_perl->Ina; PL_statbuf = proto_perl->Istatbuf; PL_statcache = proto_perl->Istatcache; @@ -11478,7 +12316,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_curpm = proto_perl->Icurpm; /* XXX No PMOP ref count */ PL_rs = sv_dup_inc(proto_perl->Irs, param); PL_last_in_gv = gv_dup(proto_perl->Ilast_in_gv, param); - PL_ofs_sv = sv_dup_inc(proto_perl->Iofs_sv, param); PL_defoutgv = gv_dup_inc(proto_perl->Idefoutgv, param); PL_chopset = proto_perl->Ichopset; /* XXX never deallocated */ PL_toptarget = sv_dup_inc(proto_perl->Itoptarget, param); @@ -11533,6 +12370,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PTR2UV(PL_watchok)); } + PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param); + if (!(flags & CLONEf_KEEP_PTR_TABLE)) { ptr_table_free(PL_ptr_table); PL_ptr_table = NULL; @@ -11542,16 +12381,16 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, identified by sv_dup() above. */ while(av_len(param->stashes) != -1) { - HV* const stash = (HV*) av_shift(param->stashes); + HV* const stash = MUTABLE_HV(av_shift(param->stashes)); GV* const cloner = gv_fetchmethod_autoload(stash, "CLONE", 0); if (cloner && GvCV(cloner)) { dSP; ENTER; SAVETMPS; PUSHMARK(SP); - XPUSHs(sv_2mortal(newSVhek(HvNAME_HEK(stash)))); + mXPUSHs(newSVhek(HvNAME_HEK(stash))); PUTBACK; - call_sv((SV*)GvCV(cloner), G_DISCARD); + call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD); FREETMPS; LEAVE; } @@ -11592,6 +12431,9 @@ char * Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) { dVAR; + + PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8; + if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { SV *uni; STRLEN len; @@ -11654,6 +12496,9 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, { dVAR; bool ret = FALSE; + + PERL_ARGS_ASSERT_SV_CAT_DECODE; + if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding) && offset) { SV *offsv; dSP; @@ -11665,8 +12510,9 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, XPUSHs(encoding); XPUSHs(dsv); XPUSHs(ssv); - XPUSHs(offsv = sv_2mortal(newSViv(*offset))); - XPUSHs(sv_2mortal(newSVpvn(tstr, tlen))); + offsv = newSViv(*offset); + mXPUSHs(offsv); + mXPUSHp(tstr, tlen); PUTBACK; call_method("cat_decode", G_SCALAR); SPAGAIN; @@ -11696,12 +12542,14 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, * If so, return a mortal copy of the key. */ STATIC SV* -S_find_hash_subscript(pTHX_ HV *hv, SV* val) +S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) { dVAR; register HE **array; I32 i; + PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT; + if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) || (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) return NULL; @@ -11720,7 +12568,7 @@ S_find_hash_subscript(pTHX_ HV *hv, SV* val) return NULL; if (HeKLEN(entry) == HEf_SVKEY) return sv_mortalcopy(HeKEY_sv(entry)); - return sv_2mortal(newSVpvn(HeKEY(entry), HeKLEN(entry))); + return sv_2mortal(newSVhek(HeKEY_hek(entry))); } } return NULL; @@ -11730,9 +12578,12 @@ S_find_hash_subscript(pTHX_ HV *hv, SV* val) * If so, return the index, otherwise return -1. */ STATIC I32 -S_find_array_subscript(pTHX_ AV *av, SV* val) +S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) { dVAR; + + PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT; + if (!av || SvMAGICAL(av) || !AvARRAY(av) || (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) return -1; @@ -11760,8 +12611,8 @@ S_find_array_subscript(pTHX_ AV *av, SV* val) #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) +S_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, + const SV *const keyname, I32 aindex, int subscript_type) { SV * const name = sv_newmortal(); @@ -11790,7 +12641,7 @@ S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, if (!cv || !CvPADLIST(cv)) return NULL; - av = (AV*)(*av_fetch(CvPADLIST(cv), 0, FALSE)); + av = MUTABLE_AV((*av_fetch(CvPADLIST(cv), 0, FALSE))); sv = *av_fetch(av, targ, FALSE); sv_setpvn(name, SvPV_nolen_const(sv), SvCUR(sv)); } @@ -11806,8 +12657,10 @@ S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, *SvPVX(name) = '$'; Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex); } - else if (subscript_type == FUV_SUBSCRIPT_WITHIN) - Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within ")); + else if (subscript_type == FUV_SUBSCRIPT_WITHIN) { + /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */ + Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0); + } return name; } @@ -11834,13 +12687,13 @@ PL_comppad/PL_curpad points to the currently executing pad. */ STATIC SV * -S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) +S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, + bool match) { dVAR; SV *sv; - AV *av; - GV *gv; - OP *o, *o2, *kid; + const GV *gv; + const OP *o, *o2, *kid; if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || uninit_sv == &PL_sv_placeholder))) @@ -11869,7 +12722,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) gv = cGVOPx_gv(cUNOPx(obase)->op_first); if (!gv) break; - sv = hash ? (SV*)GvHV(gv): (SV*)GvAV(gv); + sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv)); } else /* @{expr}, %{expr} */ return find_uninit_var(cUNOPx(obase)->op_first, @@ -11878,12 +12731,12 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) /* attempt to find a match within the aggregate */ if (hash) { - keysv = find_hash_subscript((HV*)sv, uninit_sv); + keysv = find_hash_subscript((const HV*)sv, uninit_sv); if (keysv) subscript_type = FUV_SUBSCRIPT_HASH; } else { - index = find_array_subscript((AV*)sv, uninit_sv); + index = find_array_subscript((const AV *)sv, uninit_sv); if (index >= 0) subscript_type = FUV_SUBSCRIPT_ARRAY; } @@ -11911,7 +12764,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) if (obase->op_flags & OPf_SPECIAL) { /* lexical array */ if (match) { SV **svp; - av = (AV*)PAD_SV(obase->op_targ); + AV *av = MUTABLE_AV(PAD_SV(obase->op_targ)); if (!av || SvRMAGICAL(av)) break; svp = av_fetch(av, (I32)obase->op_private, FALSE); @@ -11927,7 +12780,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) break; if (match) { SV **svp; - av = GvAV(gv); + AV *const av = GvAV(gv); if (!av || SvRMAGICAL(av)) break; svp = av_fetch(av, (I32)obase->op_private, FALSE); @@ -11967,7 +12820,8 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) gv = cGVOPx_gv(cUNOPo->op_first); if (!gv) break; - sv = o->op_type == OP_RV2HV ? (SV*)GvHV(gv) : (SV*)GvAV(gv); + sv = o->op_type + == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv)); } if (!sv) break; @@ -11978,12 +12832,12 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) if (SvMAGICAL(sv)) break; if (obase->op_type == OP_HELEM) { - HE* he = hv_fetch_ent((HV*)sv, cSVOPx_sv(kid), 0, 0); + HE* he = hv_fetch_ent(MUTABLE_HV(sv), cSVOPx_sv(kid), 0, 0); if (!he || HeVAL(he) != uninit_sv) break; } else { - SV * const * const svp = av_fetch((AV*)sv, SvIV(cSVOPx_sv(kid)), FALSE); + SV * const * const svp = av_fetch(MUTABLE_AV(sv), SvIV(cSVOPx_sv(kid)), FALSE); if (!svp || *svp != uninit_sv) break; } @@ -11999,13 +12853,14 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) /* index is an expression; * attempt to find a match within the aggregate */ if (obase->op_type == OP_HELEM) { - SV * const keysv = find_hash_subscript((HV*)sv, uninit_sv); + SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); if (keysv) return varname(gv, '%', o->op_targ, keysv, 0, FUV_SUBSCRIPT_HASH); } else { - const I32 index = find_array_subscript((AV*)sv, uninit_sv); + const I32 index + = find_array_subscript((const AV *)sv, uninit_sv); if (index >= 0) return varname(gv, '@', o->op_targ, NULL, index, FUV_SUBSCRIPT_ARRAY); @@ -12056,7 +12911,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) : DEFSV)) { sv = sv_newmortal(); - sv_setpvn(sv, "$_", 2); + sv_setpvs(sv, "$_"); return sv; } } @@ -12065,6 +12920,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) case OP_PRTF: case OP_PRINT: case OP_SAY: + match = 1; /* print etc can return undef on defined args */ /* 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) @@ -12072,16 +12928,104 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) goto do_op2; + case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */ case OP_RV2SV: - case OP_CUSTOM: - case OP_ENTERSUB: - match = 1; /* XS or custom code could trigger random warnings */ + case OP_CUSTOM: /* XS or custom code could trigger random warnings */ + + /* the following ops are capable of returning PL_sv_undef even for + * defined arg(s) */ + + case OP_BACKTICK: + case OP_PIPE_OP: + case OP_FILENO: + case OP_BINMODE: + case OP_TIED: + case OP_GETC: + case OP_SYSREAD: + case OP_SEND: + case OP_IOCTL: + case OP_SOCKET: + case OP_SOCKPAIR: + case OP_BIND: + case OP_CONNECT: + case OP_LISTEN: + case OP_ACCEPT: + case OP_SHUTDOWN: + case OP_SSOCKOPT: + case OP_GETPEERNAME: + case OP_FTRREAD: + case OP_FTRWRITE: + case OP_FTREXEC: + case OP_FTROWNED: + case OP_FTEREAD: + case OP_FTEWRITE: + case OP_FTEEXEC: + case OP_FTEOWNED: + case OP_FTIS: + case OP_FTZERO: + case OP_FTSIZE: + case OP_FTFILE: + case OP_FTDIR: + case OP_FTLINK: + case OP_FTPIPE: + case OP_FTSOCK: + case OP_FTBLK: + case OP_FTCHR: + case OP_FTTTY: + case OP_FTSUID: + case OP_FTSGID: + case OP_FTSVTX: + case OP_FTTEXT: + case OP_FTBINARY: + case OP_FTMTIME: + case OP_FTATIME: + case OP_FTCTIME: + case OP_READLINK: + case OP_OPEN_DIR: + case OP_READDIR: + case OP_TELLDIR: + case OP_SEEKDIR: + case OP_REWINDDIR: + case OP_CLOSEDIR: + case OP_GMTIME: + case OP_ALARM: + case OP_SEMGET: + case OP_GETLOGIN: + case OP_UNDEF: + case OP_SUBSTR: + case OP_AEACH: + case OP_EACH: + case OP_SORT: + case OP_CALLER: + case OP_DOFILE: + case OP_PROTOTYPE: + case OP_NCMP: + case OP_SMARTMATCH: + case OP_UNPACK: + case OP_SYSOPEN: + case OP_SYSSEEK: + match = 1; goto do_op; + case OP_ENTERSUB: + case OP_GOTO: + /* XXX tmp hack: these two may call an XS sub, and currently + XS subs don't have a SUB entry on the context stack, so CV and + pad determination goes wrong, and BAD things happen. So, just + don't try to determine the value under those circumstances. + Need a better fix at dome point. DAPM 11/2007 */ + break; + + + case OP_POS: + /* def-ness of rval pos() is independent of the def-ness of its arg */ + if ( !(obase->op_flags & OPf_MOD)) + break; + case OP_SCHOMP: case OP_CHOMP: if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) - return sv_2mortal(newSVpvs("${$/}")); + return newSVpvs_flags("${$/}", SVs_TEMP); /*FALLTHROUGH*/ default: @@ -12137,7 +13081,7 @@ Print appropriate "Use of uninitialized variable" warning */ void -Perl_report_uninit(pTHX_ SV* uninit_sv) +Perl_report_uninit(pTHX_ const SV *uninit_sv) { dVAR; if (PL_op) {