diff --git a/sv.c b/sv.c index 510b3e3cc6a1..a9ed3af27a15 100644 --- a/sv.c +++ b/sv.c @@ -118,9 +118,9 @@ */ # define ASSERT_UTF8_CACHE(cache) \ STMT_START { if (cache) { assert((cache)[0] <= (cache)[1]); \ - assert((cache)[2] <= (cache)[3]); \ - assert((cache)[3] <= (cache)[1]);} \ - } STMT_END + assert((cache)[2] <= (cache)[3]); \ + assert((cache)[3] <= (cache)[1]);} \ + } STMT_END #else # define ASSERT_UTF8_CACHE(cache) NOOP #endif @@ -187,27 +187,27 @@ following functions (specified as [function that calls visit()] / [function called by visit() for each SV]): sv_report_used() / do_report_used() - dump all remaining SVs (debugging aid) + dump all remaining SVs (debugging aid) sv_clean_objs() / do_clean_objs(),do_clean_named_objs(), - do_clean_named_io_objs(),do_curse() - Attempt to free all objects pointed to by RVs, - try to do the same for all objects indir- - ectly referenced by typeglobs too, and - then do a final sweep, cursing any - objects that remain. Called once from - perl_destruct(), prior to calling sv_clean_all() - below. + do_clean_named_io_objs(),do_curse() + Attempt to free all objects pointed to by RVs, + try to do the same for all objects indir- + ectly referenced by typeglobs too, and + then do a final sweep, cursing any + objects that remain. Called once from + perl_destruct(), prior to calling sv_clean_all() + below. sv_clean_all() / do_clean_all() - SvREFCNT_dec(sv) each remaining SV, possibly - triggering an sv_free(). It also sets the - SVf_BREAK flag on the SV to indicate that the - refcnt has been artificially lowered, and thus - stopping sv_free() from giving spurious warnings - about SVs which unexpectedly have a refcnt - of zero. called repeatedly from perl_destruct() - until there are no SVs left. + SvREFCNT_dec(sv) each remaining SV, possibly + triggering an sv_free(). It also sets the + SVf_BREAK flag on the SV to indicate that the + refcnt has been artificially lowered, and thus + stopping sv_free() from giving spurious warnings + about SVs which unexpectedly have a refcnt + of zero. called repeatedly from perl_destruct() + until there are no SVs left. =head2 Arena allocator API Summary @@ -232,9 +232,9 @@ Public API: #ifdef PERL_MEM_LOG # define MEM_LOG_NEW_SV(sv, file, line, func) \ - Perl_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) + 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 @@ -242,11 +242,11 @@ Public API: #ifdef DEBUG_LEAKING_SCALARS # define FREE_SV_DEBUG_FILE(sv) STMT_START { \ - if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \ + if ((sv)->sv_debug_file) PerlMemShared_free((sv)->sv_debug_file); \ } STMT_END # 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)) + PTR2UV(sv), (long)(sv)->sv_debug_serial)) #else # define FREE_SV_DEBUG_FILE(sv) # define DEBUG_SV_SERIAL(sv) NOOP @@ -260,7 +260,7 @@ Public API: # define POISON_SV_HEAD(sv) PoisonNew(sv, 1, struct STRUCT_SV) */ # define POISON_SV_HEAD(sv) PoisonNew(&SvANY(sv), 1, void *), \ - PoisonNew(&SvREFCNT(sv), 1, U32) + PoisonNew(&SvREFCNT(sv), 1, U32) #else # define SvARENA_CHAIN(sv) SvANY(sv) # define SvARENA_CHAIN_SET(sv,val) SvANY(sv) = (void *)(val) @@ -276,24 +276,24 @@ Public API: #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); \ - POISON_SV_HEAD(p); \ - SvFLAGS(p) = SVTYPEMASK; \ - if (!(old_flags & SVf_BREAK)) { \ - SvARENA_CHAIN_SET(p, PL_sv_root); \ - PL_sv_root = (p); \ - } \ - --PL_sv_count; \ + const U32 old_flags = SvFLAGS(p); \ + MEM_LOG_DEL_SV(p, __FILE__, __LINE__, FUNCTION__); \ + DEBUG_SV_SERIAL(p); \ + FREE_SV_DEBUG_FILE(p); \ + POISON_SV_HEAD(p); \ + SvFLAGS(p) = SVTYPEMASK; \ + 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 = MUTABLE_SV(SvARENA_CHAIN(p)); \ - ++PL_sv_count; \ + (p) = PL_sv_root; \ + PL_sv_root = MUTABLE_SV(SvARENA_CHAIN(p)); \ + ++PL_sv_count; \ } STMT_END @@ -320,19 +320,19 @@ S_new_SV(pTHX_ const char *file, int line, const char *func) SV* sv; if (PL_sv_root) - uproot_SV(sv); + uproot_SV(sv); else - sv = S_more_sv(aTHX); + sv = S_more_sv(aTHX); SvANY(sv) = 0; 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_parser->copline - : PL_curcop - ? CopLINE(PL_curcop) - : 0 - ); + ? PL_parser->copline + : PL_curcop + ? CopLINE(PL_curcop) + : 0 + ); sv->sv_debug_inpad = 0; sv->sv_debug_parent = NULL; sv->sv_debug_file = PL_curcop ? savesharedpv(CopFILE(PL_curcop)): NULL; @@ -341,7 +341,7 @@ S_new_SV(pTHX_ const char *file, int line, const char *func) 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)); + PTR2UV(sv), (long)sv->sv_debug_serial, file, line, func)); return sv; } @@ -350,14 +350,14 @@ S_new_SV(pTHX_ const char *file, int line, const char *func) #else # define new_SV(p) \ STMT_START { \ - if (PL_sv_root) \ - uproot_SV(p); \ - else \ - (p) = S_more_sv(aTHX); \ - SvANY(p) = 0; \ - SvREFCNT(p) = 1; \ - SvFLAGS(p) = 0; \ - MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ + if (PL_sv_root) \ + uproot_SV(p); \ + else \ + (p) = S_more_sv(aTHX); \ + SvANY(p) = 0; \ + SvREFCNT(p) = 1; \ + SvFLAGS(p) = 0; \ + MEM_LOG_NEW_SV(p, __FILE__, __LINE__, FUNCTION__); \ } STMT_END #endif @@ -368,10 +368,10 @@ S_new_SV(pTHX_ const char *file, int line, const char *func) #define del_SV(p) \ STMT_START { \ - if (DEBUG_D_TEST) \ - del_sv(p); \ - else \ - plant_SV(p); \ + if (DEBUG_D_TEST) \ + del_sv(p); \ + else \ + plant_SV(p); \ } STMT_END STATIC void @@ -380,22 +380,22 @@ S_del_sv(pTHX_ SV *p) PERL_ARGS_ASSERT_DEL_SV; if (DEBUG_D_TEST) { - SV* sva; - bool ok = 0; - 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) { - ok = 1; - break; - } - } - if (!ok) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), - "Attempt to free non-arena SV: 0x%" UVxf - pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); - return; - } + SV* sva; + bool ok = 0; + 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) { + ok = 1; + break; + } + } + if (!ok) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), + "Attempt to free non-arena SV: 0x%" UVxf + pTHX__FORMAT, PTR2UV(p) pTHX__VALUE); + return; + } } plant_SV(p); } @@ -438,14 +438,14 @@ S_sv_add_arena(pTHX_ char *const ptr, const U32 size, const U32 flags) svend = &sva[SvREFCNT(sva) - 1]; sv = sva + 1; while (sv < svend) { - SvARENA_CHAIN_SET(sv, (sv + 1)); + SvARENA_CHAIN_SET(sv, (sv + 1)); #ifdef DEBUGGING - SvREFCNT(sv) = 0; + SvREFCNT(sv) = 0; #endif - /* Must always set typemask because it's always checked in on cleanup - when the arenas are walked looking for objects. */ - SvFLAGS(sv) = SVTYPEMASK; - sv++; + /* 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_SET(sv, 0); #ifdef DEBUGGING @@ -466,17 +466,17 @@ S_visit(pTHX_ SVFUNC_t f, const U32 flags, const U32 mask) PERL_ARGS_ASSERT_VISIT; for (sva = PL_sv_arenaroot; sva; sva = MUTABLE_SV(SvANY(sva))) { - const SV * const svend = &sva[SvREFCNT(sva)]; - SV* sv; - for (sv = sva + 1; sv < svend; ++sv) { - if (SvTYPE(sv) != (svtype)SVTYPEMASK - && (sv->sv_flags & mask) == flags - && SvREFCNT(sv)) - { - (*f)(aTHX_ sv); - ++visited; - } - } + const SV * const svend = &sva[SvREFCNT(sva)]; + SV* sv; + for (sv = sva + 1; sv < svend; ++sv) { + if (SvTYPE(sv) != (svtype)SVTYPEMASK + && (sv->sv_flags & mask) == flags + && SvREFCNT(sv)) + { + (*f)(aTHX_ sv); + ++visited; + } + } } return visited; } @@ -489,8 +489,8 @@ static void do_report_used(pTHX_ SV *const sv) { if (SvTYPE(sv) != (svtype)SVTYPEMASK) { - PerlIO_printf(Perl_debug_log, "****\n"); - sv_dump(sv); + PerlIO_printf(Perl_debug_log, "****\n"); + sv_dump(sv); } } #endif @@ -520,19 +520,19 @@ do_clean_objs(pTHX_ SV *const ref) { assert (SvROK(ref)); { - SV * const target = SvRV(ref); - if (SvOBJECT(target)) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); - if (SvWEAKREF(ref)) { - sv_del_backref(target, ref); - SvWEAKREF_off(ref); - SvRV_set(ref, NULL); - } else { - SvROK_off(ref); - SvRV_set(ref, NULL); - SvREFCNT_dec_NN(target); - } - } + SV * const target = SvRV(ref); + if (SvOBJECT(target)) { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(ref))); + if (SvWEAKREF(ref)) { + sv_del_backref(target, ref); + SvWEAKREF_off(ref); + SvRV_set(ref, NULL); + } else { + SvROK_off(ref); + SvRV_set(ref, NULL); + SvREFCNT_dec_NN(target); + } + } } } @@ -547,35 +547,35 @@ do_clean_named_objs(pTHX_ SV *const sv) assert(SvTYPE(sv) == SVt_PVGV); assert(isGV_with_GP(sv)); if (!GvGP(sv)) - return; + return; /* freeing GP entries may indirectly free the current GV; * hold onto it while we mess with the GP slots */ SvREFCNT_inc(sv); if ( ((obj = GvSV(sv) )) && SvOBJECT(obj)) { - DEBUG_D((PerlIO_printf(Perl_debug_log, - "Cleaning named glob SV object:\n "), sv_dump(obj))); - GvSV(sv) = NULL; - SvREFCNT_dec_NN(obj); + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob SV object:\n "), sv_dump(obj))); + GvSV(sv) = NULL; + SvREFCNT_dec_NN(obj); } if ( ((obj = MUTABLE_SV(GvAV(sv)) )) && SvOBJECT(obj)) { - DEBUG_D((PerlIO_printf(Perl_debug_log, - "Cleaning named glob AV object:\n "), sv_dump(obj))); - GvAV(sv) = NULL; - SvREFCNT_dec_NN(obj); + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob AV object:\n "), sv_dump(obj))); + GvAV(sv) = NULL; + SvREFCNT_dec_NN(obj); } if ( ((obj = MUTABLE_SV(GvHV(sv)) )) && SvOBJECT(obj)) { - DEBUG_D((PerlIO_printf(Perl_debug_log, - "Cleaning named glob HV object:\n "), sv_dump(obj))); - GvHV(sv) = NULL; - SvREFCNT_dec_NN(obj); + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob HV object:\n "), sv_dump(obj))); + GvHV(sv) = NULL; + SvREFCNT_dec_NN(obj); } if ( ((obj = MUTABLE_SV(GvCV(sv)) )) && SvOBJECT(obj)) { - DEBUG_D((PerlIO_printf(Perl_debug_log, - "Cleaning named glob CV object:\n "), sv_dump(obj))); - GvCV_set(sv, NULL); - SvREFCNT_dec_NN(obj); + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob CV object:\n "), sv_dump(obj))); + GvCV_set(sv, NULL); + SvREFCNT_dec_NN(obj); } SvREFCNT_dec_NN(sv); /* undo the inc above */ } @@ -590,14 +590,14 @@ do_clean_named_io_objs(pTHX_ SV *const sv) assert(SvTYPE(sv) == SVt_PVGV); assert(isGV_with_GP(sv)); if (!GvGP(sv) || sv == (SV*)PL_stderrgv || sv == (SV*)PL_defoutgv) - return; + return; SvREFCNT_inc(sv); if ( ((obj = MUTABLE_SV(GvIO(sv)) )) && SvOBJECT(obj)) { - DEBUG_D((PerlIO_printf(Perl_debug_log, - "Cleaning named glob IO object:\n "), sv_dump(obj))); - GvIOp(sv) = NULL; - SvREFCNT_dec_NN(obj); + DEBUG_D((PerlIO_printf(Perl_debug_log, + "Cleaning named glob IO object:\n "), sv_dump(obj))); + GvIOp(sv) = NULL; + SvREFCNT_dec_NN(obj); } SvREFCNT_dec_NN(sv); /* undo the inc above */ } @@ -607,7 +607,7 @@ static void do_curse(pTHX_ SV * const sv) { if ((PL_stderrgv && GvGP(PL_stderrgv) && (SV*)GvIO(PL_stderrgv) == sv) || (PL_defoutgv && GvGP(PL_defoutgv) && (SV*)GvIO(PL_defoutgv) == sv)) - return; + return; (void)curse(sv, 0); } @@ -636,11 +636,11 @@ Perl_sv_clean_objs(pTHX) olddef = PL_defoutgv; PL_defoutgv = NULL; /* disable skip of PL_defoutgv */ if (olddef && isGV_with_GP(olddef)) - do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef)); + do_clean_named_io_objs(aTHX_ MUTABLE_SV(olddef)); olderr = PL_stderrgv; PL_stderrgv = NULL; /* disable skip of PL_stderrgv */ if (olderr && isGV_with_GP(olderr)) - do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr)); + do_clean_named_io_objs(aTHX_ MUTABLE_SV(olderr)); SvREFCNT_dec(olddef); PL_in_clean_objs = FALSE; } @@ -651,8 +651,8 @@ static void do_clean_all(pTHX_ SV *const sv) { if (sv == (const SV *) PL_fdpid || sv == (const SV *)PL_strtab) { - /* don't clean pid table and strtab */ - return; + /* 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; @@ -706,7 +706,7 @@ struct arena_set; therefore likely to be 1 aligned memory page. */ #define ARENAS_PER_SET ((PERL_ARENA_SIZE - sizeof(struct arena_set*) \ - - 2 * sizeof(int)) / sizeof (struct arena_desc)) + - 2 * sizeof(int)) / sizeof (struct arena_desc)) struct arena_set { struct arena_set* next; @@ -735,33 +735,33 @@ Perl_sv_free_arenas(pTHX) contiguity of the fake ones with the corresponding real ones.) */ for (sva = PL_sv_arenaroot; sva; sva = svanext) { - svanext = MUTABLE_SV(SvANY(sva)); - while (svanext && SvFAKE(svanext)) - svanext = MUTABLE_SV(SvANY(svanext)); + svanext = MUTABLE_SV(SvANY(sva)); + while (svanext && SvFAKE(svanext)) + svanext = MUTABLE_SV(SvANY(svanext)); - if (!SvFAKE(sva)) - Safefree(sva); + if (!SvFAKE(sva)) + Safefree(sva); } { - struct arena_set *aroot = (struct arena_set*) PL_body_arenas; - - while (aroot) { - struct arena_set *current = aroot; - i = aroot->curr; - while (i--) { - assert(aroot->set[i].arena); - Safefree(aroot->set[i].arena); - } - aroot = aroot->next; - Safefree(current); - } + struct arena_set *aroot = (struct arena_set*) PL_body_arenas; + + while (aroot) { + struct arena_set *current = aroot; + i = aroot->curr; + while (i--) { + assert(aroot->set[i].arena); + Safefree(aroot->set[i].arena); + } + aroot = aroot->next; + Safefree(current); + } } PL_body_arenas = 0; i = PERL_ARENA_ROOTS_SIZE; while (i--) - PL_body_roots[i] = 0; + PL_body_roots[i] = 0; PL_sv_arenaroot = 0; PL_sv_root = 0; @@ -936,8 +936,8 @@ ALIGNED_TYPE(XPVIO); for why copying the padding proved to be a bug. */ #define copy_length(type, last_member) \ - STRUCT_OFFSET(type, last_member) \ - + sizeof (((type*)SvANY((const SV *)0))->last_member) + STRUCT_OFFSET(type, last_member) \ + + sizeof (((type*)SvANY((const SV *)0))->last_member) static const struct body_details bodies_by_type[] = { /* HEs use this offset for their arena. */ @@ -1033,15 +1033,15 @@ static const struct body_details bodies_by_type[] = { #define new_body_allocated(sv_type) \ (void *)((char *)S_new_body(aTHX_ sv_type) \ - - bodies_by_type[sv_type].offset) + - bodies_by_type[sv_type].offset) /* return a thing to the free list */ #define del_body(thing, root) \ STMT_START { \ - void ** const thing_copy = (void **)thing; \ - *thing_copy = *root; \ - *root = (void*)thing_copy; \ + void ** const thing_copy = (void **)thing; \ + *thing_copy = *root; \ + *root = (void*)thing_copy; \ } STMT_END #ifdef PURIFY @@ -1062,20 +1062,20 @@ static const struct body_details bodies_by_type[] = { #define new_XPVMG() new_body_allocated(SVt_PVMG) #define del_XPVGV(p) del_body(p + bodies_by_type[SVt_PVGV].offset, \ - &PL_body_roots[SVt_PVGV]) + &PL_body_roots[SVt_PVGV]) #endif /* PURIFY */ /* no arena for you! */ #define new_NOARENA(details) \ - safemalloc((details)->body_size + (details)->offset) + safemalloc((details)->body_size + (details)->offset) #define new_NOARENAZ(details) \ - safecalloc((details)->body_size + (details)->offset, 1) + safecalloc((details)->body_size + (details)->offset, 1) void * Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, - const size_t arena_size) + const size_t arena_size) { void ** const root = &PL_body_roots[sv_type]; struct arena_desc *adesc; @@ -1088,12 +1088,12 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, static bool done_sanity_check; if (!done_sanity_check) { - unsigned int i = SVt_LAST; + unsigned int i = SVt_LAST; - done_sanity_check = TRUE; + done_sanity_check = TRUE; - while (i--) - assert (bodies_by_type[i].type == i); + while (i--) + assert (bodies_by_type[i].type == i); } #endif @@ -1101,13 +1101,13 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, /* may need new arena-set to hold new arena */ if (!aroot || aroot->curr >= aroot->set_size) { - struct arena_set *newroot; - Newxz(newroot, 1, struct arena_set); - newroot->set_size = ARENAS_PER_SET; - newroot->next = aroot; - aroot = newroot; - PL_body_arenas = (void *) newroot; - DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot)); + struct arena_set *newroot; + Newxz(newroot, 1, struct arena_set); + newroot->set_size = ARENAS_PER_SET; + newroot->next = aroot; + aroot = newroot; + PL_body_arenas = (void *) newroot; + DEBUG_m(PerlIO_printf(Perl_debug_log, "new arenaset %p\n", (void*)aroot)); } /* ok, now have arena-set with at least 1 empty/available arena-desc */ @@ -1119,7 +1119,7 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, adesc->size = good_arena_size; adesc->utype = sv_type; DEBUG_m(PerlIO_printf(Perl_debug_log, "arena %d added: %p size %" UVuf "\n", - curr, (void*)adesc->arena, (UV)good_arena_size)); + curr, (void*)adesc->arena, (UV)good_arena_size)); start = (char *) adesc->arena; @@ -1130,34 +1130,34 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, /* computed count doesn't 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)good_arena_size, - (int)arena_size, sv_type, (int)body_size, - (int)good_arena_size / (int)body_size)); + "arena %p end %p arena-size %d (from %d) type %d " + "size %d ct %d\n", + (void*)start, (void*)end, (int)good_arena_size, + (int)arena_size, sv_type, (int)body_size, + (int)good_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)arena_size, sv_type, (int)body_size, - (int)good_arena_size / (int)body_size)); + "arena %p end %p arena-size %d type %d size %d ct %d\n", + (void*)start, (void*)end, + (int)arena_size, sv_type, (int)body_size, + (int)good_arena_size / (int)body_size)); #endif *root = (void *)start; while (1) { - /* Where the next body would start: */ - char * const next = start + body_size; + /* Where the next body would start: */ + char * const next = start + body_size; - if (next >= end) { - /* This is the last body: */ - assert(next == end); + if (next >= end) { + /* This is the last body: */ + assert(next == end); - *(void **)start = 0; - return *root; - } + *(void **)start = 0; + return *root; + } - *(void**) start = (void *)next; - start = next; + *(void**) start = (void *)next; + start = next; } } @@ -1167,12 +1167,12 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, */ #define new_body_inline(xpv, sv_type) \ STMT_START { \ - void ** const r3wt = &PL_body_roots[sv_type]; \ - xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ - ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \ - bodies_by_type[sv_type].body_size,\ - bodies_by_type[sv_type].arena_size)); \ - *(r3wt) = *(void**)(xpv); \ + void ** const r3wt = &PL_body_roots[sv_type]; \ + xpv = (PTR_TBL_ENT_t*) (*((void **)(r3wt)) \ + ? *((void **)(r3wt)) : Perl_more_bodies(aTHX_ sv_type, \ + bodies_by_type[sv_type].body_size,\ + bodies_by_type[sv_type].arena_size)); \ + *(r3wt) = *(void**)(xpv); \ } STMT_END #ifndef PURIFY @@ -1211,13 +1211,13 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) const svtype old_type = SvTYPE(sv); const struct body_details *new_type_details; const struct body_details *old_type_details - = bodies_by_type + old_type; + = bodies_by_type + old_type; SV *referent = NULL; PERL_ARGS_ASSERT_SV_UPGRADE; if (old_type == new_type) - return; + return; /* This clause was purposefully added ahead of the early return above to the shared string hackery for (sort {$a <=> $b} keys %hash), with the @@ -1229,7 +1229,7 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) purpose. So it's safe to move the early return earlier. */ if (new_type > SVt_PVMG && SvIsCOW(sv)) { - sv_force_normal_flags(sv, 0); + sv_force_normal_flags(sv, 0); } old_body = SvANY(sv); @@ -1274,49 +1274,49 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) switch (old_type) { case SVt_NULL: - break; + break; case SVt_IV: - if (SvROK(sv)) { - referent = 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; + if (SvROK(sv)) { + referent = 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: - if (new_type < SVt_PVNV) { - new_type = SVt_PVNV; - } - break; + if (new_type < SVt_PVNV) { + new_type = SVt_PVNV; + } + break; case SVt_PV: - assert(new_type > SVt_PV); - STATIC_ASSERT_STMT(SVt_IV < SVt_PV); - STATIC_ASSERT_STMT(SVt_NV < SVt_PV); - break; + assert(new_type > SVt_PV); + STATIC_ASSERT_STMT(SVt_IV < SVt_PV); + STATIC_ASSERT_STMT(SVt_NV < SVt_PV); + break; case SVt_PVIV: - break; + break; case SVt_PVNV: - break; + break; case SVt_PVMG: - /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, - there's no way that it can be safely upgraded, because perl.c - expects to Safefree(SvANY(PL_mess_sv)) */ - assert(sv != PL_mess_sv); - break; + /* Because the XPVMG of PL_mess_sv isn't allocated from the arena, + there's no way that it can be safely upgraded, because perl.c + expects to Safefree(SvANY(PL_mess_sv)) */ + assert(sv != PL_mess_sv); + break; default: - if (UNLIKELY(old_type_details->cant_upgrade)) - Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf, - sv_reftype(sv, 0), (UV) old_type, (UV) new_type); + if (UNLIKELY(old_type_details->cant_upgrade)) + Perl_croak(aTHX_ "Can't upgrade %s (%" UVuf ") to %" UVuf, + sv_reftype(sv, 0), (UV) old_type, (UV) new_type); } if (UNLIKELY(old_type > new_type)) - Perl_croak(aTHX_ "sv_upgrade from type %d down to type %d", - (int)old_type, (int)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; @@ -1328,80 +1328,80 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) assert (new_type != SVt_NULL); switch (new_type) { case SVt_IV: - assert(old_type == SVt_NULL); - SET_SVANY_FOR_BODYLESS_IV(sv); - SvIV_set(sv, 0); - return; + assert(old_type == SVt_NULL); + SET_SVANY_FOR_BODYLESS_IV(sv); + SvIV_set(sv, 0); + return; case SVt_NV: - assert(old_type == SVt_NULL); + assert(old_type == SVt_NULL); #if NVSIZE <= IVSIZE - SET_SVANY_FOR_BODYLESS_NV(sv); + SET_SVANY_FOR_BODYLESS_NV(sv); #else - SvANY(sv) = new_XNV(); + SvANY(sv) = new_XNV(); #endif - SvNV_set(sv, 0); - return; + SvNV_set(sv, 0); + return; case SVt_PVHV: case SVt_PVAV: - assert(new_type_details->body_size); + assert(new_type_details->body_size); #ifndef PURIFY - assert(new_type_details->arena); - assert(new_type_details->arena_size); - /* This points to the start of the allocated area. */ - new_body_inline(new_body, new_type); - Zero(new_body, new_type_details->body_size, char); - new_body = ((char *)new_body) - new_type_details->offset; + assert(new_type_details->arena); + assert(new_type_details->arena_size); + /* This points to the start of the allocated area. */ + new_body_inline(new_body, new_type); + Zero(new_body, new_type_details->body_size, char); + new_body = ((char *)new_body) - new_type_details->offset; #else - /* We always allocated the full length item with PURIFY. To do this - we fake things so that arena is false for all 16 types.. */ - new_body = new_NOARENAZ(new_type_details); + /* We always allocated the full length item with PURIFY. To do this + we fake things so that arena is false for all 16 types.. */ + new_body = new_NOARENAZ(new_type_details); #endif - SvANY(sv) = new_body; - if (new_type == SVt_PVAV) { - 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); + SvANY(sv) = new_body; + if (new_type == SVt_PVAV) { + 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 */ + HvSHAREKEYS_on(sv); /* key-sharing on by default */ #endif /* start with PERL_HASH_DEFAULT_HvMAX+1 buckets: */ - HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; - } - - /* 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_IV) { - assert(!SvROK(sv)); - } else if (old_type >= SVt_PV) { - assert(SvPVX_const(sv) == 0); - } - - if (old_type >= SVt_PVMG) { - SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic); - SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); - } else { - sv->sv_u.svu_array = NULL; /* or svu_hash */ - } - break; + HvMAX(sv) = PERL_HASH_DEFAULT_HvMAX; + } + + /* 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_IV) { + assert(!SvROK(sv)); + } else if (old_type >= SVt_PV) { + assert(SvPVX_const(sv) == 0); + } + + if (old_type >= SVt_PVMG) { + SvMAGIC_set(sv, ((XPVMG*)old_body)->xmg_u.xmg_magic); + SvSTASH_set(sv, ((XPVMG*)old_body)->xmg_stash); + } else { + sv->sv_u.svu_array = NULL; /* or svu_hash */ + } + break; case SVt_PVIV: - /* XXX Is this still needed? Was it ever needed? Surely as there is - no route from NV to PVIV, NOK can never be true */ - assert(!SvNOKp(sv)); - assert(!SvNOK(sv)); + /* XXX Is this still needed? Was it ever needed? Surely as there is + no route from NV to PVIV, NOK can never be true */ + assert(!SvNOKp(sv)); + assert(!SvNOK(sv)); /* FALLTHROUGH */ case SVt_PVIO: case SVt_PVFM: @@ -1414,84 +1414,84 @@ Perl_sv_upgrade(pTHX_ SV *const sv, svtype new_type) case SVt_PVNV: case SVt_PV: - assert(new_type_details->body_size); - /* We always allocated the full length item with PURIFY. To do this - we fake things so that arena is false for all 16 types.. */ - if(new_type_details->arena) { - /* This points to the start of the allocated area. */ - new_body_inline(new_body, new_type); - Zero(new_body, new_type_details->body_size, char); - new_body = ((char *)new_body) - new_type_details->offset; - } else { - new_body = new_NOARENAZ(new_type_details); - } - SvANY(sv) = new_body; - - if (old_type_details->copy) { - /* There is now the potential for an upgrade from something without - an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */ - int offset = old_type_details->offset; - int length = old_type_details->copy; - - if (new_type_details->offset > old_type_details->offset) { - const int difference - = new_type_details->offset - old_type_details->offset; - offset += difference; - length -= difference; - } - assert (length >= 0); - - Copy((char *)old_body + offset, (char *)new_body + offset, length, - char); - } + assert(new_type_details->body_size); + /* We always allocated the full length item with PURIFY. To do this + we fake things so that arena is false for all 16 types.. */ + if(new_type_details->arena) { + /* This points to the start of the allocated area. */ + new_body_inline(new_body, new_type); + Zero(new_body, new_type_details->body_size, char); + new_body = ((char *)new_body) - new_type_details->offset; + } else { + new_body = new_NOARENAZ(new_type_details); + } + SvANY(sv) = new_body; + + if (old_type_details->copy) { + /* There is now the potential for an upgrade from something without + an offset (PVNV or PVMG) to something with one (PVCV, PVFM) */ + int offset = old_type_details->offset; + int length = old_type_details->copy; + + if (new_type_details->offset > old_type_details->offset) { + const int difference + = new_type_details->offset - old_type_details->offset; + offset += difference; + length -= difference; + } + assert (length >= 0); + + Copy((char *)old_body + offset, (char *)new_body + offset, length, + char); + } #ifndef NV_ZERO_IS_ALLBITS_ZERO - /* If NV 0.0 is stores as all bits 0 then Zero() already creates a - * correct 0.0 for us. Otherwise, if the old body didn't have an - * NV slot, but the new one does, then we need to initialise the - * freshly created NV slot with whatever the correct bit pattern is - * for 0.0 */ - if (old_type_details->zero_nv && !new_type_details->zero_nv - && !isGV_with_GP(sv)) - SvNV_set(sv, 0); + /* If NV 0.0 is stores as all bits 0 then Zero() already creates a + * correct 0.0 for us. Otherwise, if the old body didn't have an + * NV slot, but the new one does, then we need to initialise the + * freshly created NV slot with whatever the correct bit pattern is + * for 0.0 */ + if (old_type_details->zero_nv && !new_type_details->zero_nv + && !isGV_with_GP(sv)) + SvNV_set(sv, 0); #endif - if (UNLIKELY(new_type == SVt_PVIO)) { - IO * const io = MUTABLE_IO(sv); - GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); + if (UNLIKELY(new_type == SVt_PVIO)) { + IO * const io = MUTABLE_IO(sv); + GV *iogv = gv_fetchpvs("IO::File::", GV_ADD, SVt_PVHV); - SvOBJECT_on(io); - /* Clear the stashcache because a new IO could overrule a package - name */ + SvOBJECT_on(io); + /* Clear the stashcache because a new IO could overrule a package + name */ DEBUG_o(Perl_deb(aTHX_ "sv_upgrade clearing PL_stashcache\n")); - hv_clear(PL_stashcache); - - SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); - IoPAGE_LEN(sv) = 60; - } - if (old_type < SVt_PV) { - /* referent will be NULL unless the old type was SVt_IV emulating - SVt_RV */ - sv->sv_u.svu_rv = referent; - } - break; + hv_clear(PL_stashcache); + + SvSTASH_set(io, MUTABLE_HV(SvREFCNT_inc(GvHV(iogv)))); + IoPAGE_LEN(sv) = 60; + } + if (old_type < SVt_PV) { + /* referent will be NULL unless the old type was SVt_IV emulating + SVt_RV */ + sv->sv_u.svu_rv = referent; + } + break; default: - Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", - (unsigned long)new_type); + Perl_croak(aTHX_ "panic: sv_upgrade to unknown type %lu", + (unsigned long)new_type); } /* if this is zero, this is a body-less SVt_NULL, SVt_IV/SVt_RV, and sometimes SVt_NV */ if (old_type_details->body_size) { #ifdef PURIFY - safefree(old_body); + safefree(old_body); #else - /* Note that there is an assumption that all bodies of types that - can be upgraded came from arenas. Only the more complex non- - upgradable types are allowed to be directly malloc()ed. */ - assert(old_type_details->arena); - del_body((void*)((char*)old_body + old_type_details->offset), - &PL_body_roots[old_type]); + /* Note that there is an assumption that all bodies of types that + can be upgraded came from arenas. Only the more complex non- + upgradable types are allowed to be directly malloc()ed. */ + assert(old_type_details->arena); + del_body((void*)((char*)old_body + old_type_details->offset), + &PL_body_roots[old_type]); #endif } } @@ -1554,21 +1554,21 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) PERL_ARGS_ASSERT_SV_GROW; if (SvROK(sv)) - sv_unref(sv); + sv_unref(sv); if (SvTYPE(sv) < SVt_PV) { - sv_upgrade(sv, SVt_PV); - s = SvPVX_mutable(sv); + sv_upgrade(sv, SVt_PV); + s = SvPVX_mutable(sv); } else if (SvOOK(sv)) { /* pv is offset? */ - sv_backoff(sv); - s = SvPVX_mutable(sv); - if (newlen > SvLEN(sv)) - newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ + sv_backoff(sv); + s = SvPVX_mutable(sv); + if (newlen > SvLEN(sv)) + newlen += 10 * (newlen - SvCUR(sv)); /* avoid copy each time */ } else { - if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0); - s = SvPVX_mutable(sv); + if (SvIsCOW(sv)) S_sv_uncow(aTHX_ sv, 0); + s = SvPVX_mutable(sv); } #ifdef PERL_COPY_ON_WRITE @@ -1589,10 +1589,10 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) #endif if (newlen > SvLEN(sv)) { /* need more room? */ - STRLEN minlen = SvCUR(sv); - minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10; - if (newlen < minlen) - newlen = minlen; + STRLEN minlen = SvCUR(sv); + minlen += (minlen >> PERL_STRLEN_EXPAND_SHIFT) + 10; + if (newlen < minlen) + newlen = minlen; #ifndef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC /* Don't round up on the first allocation, as odds are pretty good that @@ -1603,21 +1603,21 @@ Perl_sv_grow(pTHX_ SV *const sv, STRLEN newlen) newlen = rounded; } #endif - if (SvLEN(sv) && s) { - s = (char*)saferealloc(s, newlen); - } - else { - s = (char*)safemalloc(newlen); - if (SvPVX_const(sv) && SvCUR(sv)) { + if (SvLEN(sv) && s) { + s = (char*)saferealloc(s, newlen); + } + else { + s = (char*)safemalloc(newlen); + if (SvPVX_const(sv) && SvCUR(sv)) { Move(SvPVX_const(sv), s, SvCUR(sv), char); - } - } - SvPV_set(sv, s); + } + } + SvPV_set(sv, s); #ifdef PERL_UNWARANTED_CHUMMINESS_WITH_MALLOC - /* 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)); + /* 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 @@ -1646,24 +1646,24 @@ Perl_sv_setiv(pTHX_ SV *const sv, const IV i) switch (SvTYPE(sv)) { case SVt_NULL: case SVt_NV: - sv_upgrade(sv, SVt_IV); - break; + sv_upgrade(sv, SVt_IV); + break; case SVt_PV: - sv_upgrade(sv, SVt_PVIV); - break; + sv_upgrade(sv, SVt_PVIV); + break; case SVt_PVGV: - if (!isGV_with_GP(sv)) - break; + if (!isGV_with_GP(sv)) + break; /* FALLTHROUGH */ case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: - /* diag_listed_as: Can't coerce %s to %s in %s */ - Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), - OP_DESC(PL_op)); + /* diag_listed_as: Can't coerce %s to %s in %s */ + Perl_croak(aTHX_ "Can't coerce %s to integer in %s", sv_reftype(sv,0), + OP_DESC(PL_op)); NOT_REACHED; /* NOTREACHED */ break; default: NOOP; @@ -1750,25 +1750,25 @@ Perl_sv_setnv(pTHX_ SV *const sv, const NV num) switch (SvTYPE(sv)) { case SVt_NULL: case SVt_IV: - sv_upgrade(sv, SVt_NV); - break; + sv_upgrade(sv, SVt_NV); + break; case SVt_PV: case SVt_PVIV: - sv_upgrade(sv, SVt_PVNV); - break; + sv_upgrade(sv, SVt_PVNV); + break; case SVt_PVGV: - if (!isGV_with_GP(sv)) - break; + if (!isGV_with_GP(sv)) + break; /* FALLTHROUGH */ case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: case SVt_PVFM: case SVt_PVIO: - /* diag_listed_as: Can't coerce %s to %s in %s */ - Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), - OP_DESC(PL_op)); + /* diag_listed_as: Can't coerce %s to %s in %s */ + Perl_croak(aTHX_ "Can't coerce %s to number in %s", sv_reftype(sv,0), + OP_DESC(PL_op)); NOT_REACHED; /* NOTREACHED */ break; default: NOOP; @@ -1803,56 +1803,56 @@ S_sv_display(pTHX_ SV *const sv, char *tmpbuf, STRLEN tmpbuf_size) { SV *dsv = newSVpvs_flags("", SVs_TEMP); pv = sv_uni_display(dsv, sv, 32, UNI_DISPLAY_ISPRINT); } else { - char *d = tmpbuf; - const char * const limit = tmpbuf + tmpbuf_size - 8; - /* each *s can expand to 4 chars + "...\0", - i.e. need room for 8 chars */ - - const char *s = SvPVX_const(sv); - const char * const end = s + SvCUR(sv); - for ( ; s < end && d < limit; s++ ) { - int ch = *s & 0xFF; - if (! isASCII(ch) && !isPRINT_LC(ch)) { - *d++ = 'M'; - *d++ = '-'; + char *d = tmpbuf; + const char * const limit = tmpbuf + tmpbuf_size - 8; + /* each *s can expand to 4 chars + "...\0", + i.e. need room for 8 chars */ + + const char *s = SvPVX_const(sv); + const char * const end = s + SvCUR(sv); + for ( ; s < end && d < limit; s++ ) { + int ch = *s & 0xFF; + if (! isASCII(ch) && !isPRINT_LC(ch)) { + *d++ = 'M'; + *d++ = '-'; /* Map to ASCII "equivalent" of Latin1 */ - ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127); - } - if (ch == '\n') { - *d++ = '\\'; - *d++ = 'n'; - } - else if (ch == '\r') { - *d++ = '\\'; - *d++ = 'r'; - } - else if (ch == '\f') { - *d++ = '\\'; - *d++ = 'f'; - } - else if (ch == '\\') { - *d++ = '\\'; - *d++ = '\\'; - } - else if (ch == '\0') { - *d++ = '\\'; - *d++ = '0'; - } - else if (isPRINT_LC(ch)) - *d++ = ch; - else { - *d++ = '^'; - *d++ = toCTRL(ch); - } - } - if (s < end) { - *d++ = '.'; - *d++ = '.'; - *d++ = '.'; - } - *d = '\0'; - pv = tmpbuf; + ch = LATIN1_TO_NATIVE(NATIVE_TO_LATIN1(ch) & 127); + } + if (ch == '\n') { + *d++ = '\\'; + *d++ = 'n'; + } + else if (ch == '\r') { + *d++ = '\\'; + *d++ = 'r'; + } + else if (ch == '\f') { + *d++ = '\\'; + *d++ = 'f'; + } + else if (ch == '\\') { + *d++ = '\\'; + *d++ = '\\'; + } + else if (ch == '\0') { + *d++ = '\\'; + *d++ = '0'; + } + else if (isPRINT_LC(ch)) + *d++ = ch; + else { + *d++ = '^'; + *d++ = toCTRL(ch); + } + } + if (s < end) { + *d++ = '.'; + *d++ = '.'; + *d++ = '.'; + } + *d = '\0'; + pv = tmpbuf; } return pv; @@ -1873,14 +1873,14 @@ S_not_a_number(pTHX_ SV *const sv) pv = sv_display(sv, tmpbuf, sizeof(tmpbuf)); if (PL_op) - Perl_warner(aTHX_ packWARN(WARN_NUMERIC), - /* diag_listed_as: Argument "%s" isn't numeric%s */ - "Argument \"%s\" isn't numeric in %s", pv, - OP_DESC(PL_op)); + Perl_warner(aTHX_ packWARN(WARN_NUMERIC), + /* diag_listed_as: Argument "%s" isn't numeric%s */ + "Argument \"%s\" isn't numeric in %s", pv, + OP_DESC(PL_op)); else - Perl_warner(aTHX_ packWARN(WARN_NUMERIC), - /* diag_listed_as: Argument "%s" isn't numeric%s */ - "Argument \"%s\" isn't numeric", pv); + Perl_warner(aTHX_ packWARN(WARN_NUMERIC), + /* diag_listed_as: Argument "%s" isn't numeric%s */ + "Argument \"%s\" isn't numeric", pv); } STATIC void @@ -1917,10 +1917,10 @@ Perl_looks_like_number(pTHX_ SV *const sv) PERL_ARGS_ASSERT_LOOKS_LIKE_NUMBER; if (SvPOK(sv) || SvPOKp(sv)) { - sbegin = SvPV_nomg_const(sv, len); + sbegin = SvPV_nomg_const(sv, len); } else - return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); + return SvFLAGS(sv) & (SVf_NOK|SVp_NOK|SVf_IOK|SVp_IOK); numtype = grok_number(sbegin, len, NULL); return ((numtype & IS_NUMBER_TRAILING)) ? 0 : numtype; } @@ -1931,15 +1931,15 @@ S_glob_2number(pTHX_ GV * const gv) PERL_ARGS_ASSERT_GLOB_2NUMBER; /* We know that all GVs stringify to something that is not-a-number, - so no need to test that. */ + so no need to test that. */ if (ckWARN(WARN_NUMERIC)) { - SV *const buffer = sv_newmortal(); - gv_efullname3(buffer, gv, "*"); - not_a_number(buffer); + SV *const buffer = sv_newmortal(); + gv_efullname3(buffer, gv, "*"); + not_a_number(buffer); } /* We just want something true to return, so that S_sv_2iuv_common - can tail call us and return true. */ + can tail call us and return true. */ return TRUE; } @@ -2030,26 +2030,26 @@ S_glob_2number(pTHX_ GV * const gv) STATIC int S_sv_2iuv_non_preserve(pTHX_ SV *const sv # ifdef DEBUGGING - , I32 numtype + , I32 numtype # endif - ) + ) { PERL_ARGS_ASSERT_SV_2IUV_NON_PRESERVE; PERL_UNUSED_CONTEXT; 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); - (void)SvNOK_on(sv); - SvIV_set(sv, IV_MIN); - return IS_NUMBER_UNDERFLOW_IV; + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + SvIV_set(sv, IV_MIN); + return IS_NUMBER_UNDERFLOW_IV; } if (SvNVX(sv) > (NV)UV_MAX) { - (void)SvIOKp_on(sv); - (void)SvNOK_on(sv); - SvIsUV_on(sv); - SvUV_set(sv, UV_MAX); - return IS_NUMBER_OVERFLOW_UV; + (void)SvIOKp_on(sv); + (void)SvNOK_on(sv); + SvIsUV_on(sv); + SvUV_set(sv, UV_MAX); + return IS_NUMBER_OVERFLOW_UV; } (void)SvIOKp_on(sv); (void)SvNOK_on(sv); @@ -2118,96 +2118,96 @@ S_sv_2iuv_common(pTHX_ SV *const sv) 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 - * (ie PV->NV conversion should detect loss of accuracy and cache - * IV or UV at same time to avoid this. */ - /* IV-over-UV optimisation - choose to cache IV if possible */ - - if (SvTYPE(sv) == SVt_NV) - sv_upgrade(sv, SVt_PVNV); - - (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ - /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost - certainly cast into the IV range at IV_MAX, whereas the correct - answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary - cases go to UV */ + /* 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 + * (ie PV->NV conversion should detect loss of accuracy and cache + * IV or UV at same time to avoid this. */ + /* IV-over-UV optimisation - choose to cache IV if possible */ + + if (SvTYPE(sv) == SVt_NV) + sv_upgrade(sv, SVt_PVNV); + + (void)SvIOKp_on(sv); /* Must do this first, to clear any SvOOK */ + /* < not <= as for NV doesn't preserve UV, ((NV)IV_MAX+1) will almost + certainly cast into the IV range at IV_MAX, whereas the correct + answer is the UV IV_MAX +1. Hence < ensures that dodgy boundary + cases go to UV */ #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - if (Perl_isnan(SvNVX(sv))) { - SvUV_set(sv, 0); - SvIsUV_on(sv); - return FALSE; - } + if (Perl_isnan(SvNVX(sv))) { + SvUV_set(sv, 0); + SvIsUV_on(sv); + return FALSE; + } #endif - if (SvNVX(sv) < (NV)IV_MAX + 0.5) { - SvIV_set(sv, I_V(SvNVX(sv))); - if (SvNVX(sv) == (NV) SvIVX(sv) + if (SvNVX(sv) < (NV)IV_MAX + 0.5) { + SvIV_set(sv, I_V(SvNVX(sv))); + if (SvNVX(sv) == (NV) SvIVX(sv) #ifndef NV_PRESERVES_UV && SvIVX(sv) != IV_MIN /* avoid negating IV_MIN below */ - && (((UV)1 << NV_PRESERVES_UV_BITS) > - (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) - /* Don't flag it as "accurately an integer" if the number - came from a (by definition imprecise) NV operation, and - we're outside the range of NV integer precision */ + && (((UV)1 << NV_PRESERVES_UV_BITS) > + (UV)(SvIVX(sv) > 0 ? SvIVX(sv) : -SvIVX(sv))) + /* Don't flag it as "accurately an integer" if the number + came from a (by definition imprecise) NV operation, and + we're outside the range of NV integer precision */ #endif - ) { - 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), - SvNVX(sv), - SvIVX(sv))); - - } else { - /* IV not precise. No need to convert from PV, as NV - conversion would already have cached IV if it detected - that PV->IV would be better than PV->NV->IV - flags already correct - don't set public IOK. */ - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (imprecise)\n", - PTR2UV(sv), - SvNVX(sv), - SvIVX(sv))); - } - /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, - but the cast (NV)IV_MIN rounds to a the value less (more - negative) than IV_MIN which happens to be equal to SvNVX ?? - Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and - NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and - (NV)UVX == NVX are both true, but the values differ. :-( - Hopefully for 2s complement IV_MIN is something like - 0x8000000000000000 which will be exact. NWC */ - } - else { - SvUV_set(sv, U_V(SvNVX(sv))); - if ( - (SvNVX(sv) == (NV) SvUVX(sv)) + ) { + 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), + SvNVX(sv), + SvIVX(sv))); + + } else { + /* IV not precise. No need to convert from PV, as NV + conversion would already have cached IV if it detected + that PV->IV would be better than PV->NV->IV + flags already correct - don't set public IOK. */ + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%" UVxf " iv(%" NVgf " => %" IVdf ") (imprecise)\n", + PTR2UV(sv), + SvNVX(sv), + SvIVX(sv))); + } + /* Can the above go wrong if SvIVX == IV_MIN and SvNVX < IV_MIN, + but the cast (NV)IV_MIN rounds to a the value less (more + negative) than IV_MIN which happens to be equal to SvNVX ?? + Analogous to 0xFFFFFFFFFFFFFFFF rounding up to NV (2**64) and + NV rounding back to 0xFFFFFFFFFFFFFFFF, so UVX == UV(NVX) and + (NV)UVX == NVX are both true, but the values differ. :-( + Hopefully for 2s complement IV_MIN is something like + 0x8000000000000000 which will be exact. NWC */ + } + else { + SvUV_set(sv, U_V(SvNVX(sv))); + if ( + (SvNVX(sv) == (NV) SvUVX(sv)) #ifndef NV_PRESERVES_UV - /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ - /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ - && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) - /* Don't flag it as "accurately an integer" if the number - came from a (by definition imprecise) NV operation, and - we're outside the range of NV integer precision */ + /* Make sure it's not 0xFFFFFFFFFFFFFFFF */ + /*&& (SvUVX(sv) != UV_MAX) irrelevant with code below */ + && (((UV)1 << NV_PRESERVES_UV_BITS) > SvUVX(sv)) + /* Don't flag it as "accurately an integer" if the number + 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); - DEBUG_c(PerlIO_printf(Perl_debug_log, - "0x%" UVxf " 2iv(%" UVuf " => %" IVdf ") (as unsigned)\n", - PTR2UV(sv), - SvUVX(sv), - SvUVX(sv))); - } + && SvNOK(sv) + ) + SvIOK_on(sv); + SvIsUV_on(sv); + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%" UVxf " 2iv(%" UVuf " => %" IVdf ") (as unsigned)\n", + PTR2UV(sv), + SvUVX(sv), + SvUVX(sv))); + } } else if (SvPOKp(sv)) { - UV value; - int numtype; + UV value; + int numtype; const char *s = SvPVX_const(sv); const STRLEN cur = SvCUR(sv); @@ -2224,89 +2224,89 @@ S_sv_2iuv_common(pTHX_ SV *const sv) } } - numtype = grok_number(s, cur, &value); - /* We want to avoid a possible problem when we cache an IV/ a UV which - may be later translated to an NV, and the resulting NV is not - the same as the direct translation of the initial string - (eg 123.456 can shortcut to the IV 123 with atol(), but we must - be careful to ensure that the value with the .456 is around if the - NV value is requested in the future). - - This means that if we cache such an IV/a UV, we need to cache the - NV as well. Moreover, we trade speed for space, and do not - cache the NV if we are sure it's not needed. - */ - - /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer, only upgrade to PVIV */ - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); - (void)SvIOK_on(sv); - } else if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); + numtype = grok_number(s, cur, &value); + /* We want to avoid a possible problem when we cache an IV/ a UV which + may be later translated to an NV, and the resulting NV is not + the same as the direct translation of the initial string + (eg 123.456 can shortcut to the IV 123 with atol(), but we must + be careful to ensure that the value with the .456 is around if the + NV value is requested in the future). + + This means that if we cache such an IV/a UV, we need to cache the + NV as well. Moreover, we trade speed for space, and do not + cache the NV if we are sure it's not needed. + */ + + /* SVt_PVNV is one higher than SVt_PVIV, hence this order */ + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer, only upgrade to PVIV */ + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); + (void)SvIOK_on(sv); + } else if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); if ((numtype & (IS_NUMBER_INFINITY | IS_NUMBER_NAN))) { if (ckWARN(WARN_NUMERIC) && ((numtype & IS_NUMBER_TRAILING))) - not_a_number(sv); + not_a_number(sv); S_sv_setnv(aTHX_ sv, numtype); return FALSE; } - /* If NVs preserve UVs then we only use the UV value if we know that - we aren't going to call atof() below. If NVs don't preserve UVs - then the value returned may have more precision than atof() will - return, even though value isn't perfectly accurate. */ - if ((numtype & (IS_NUMBER_IN_UV + /* If NVs preserve UVs then we only use the UV value if we know that + we aren't going to call atof() below. If NVs don't preserve UVs + then the value returned may have more precision than atof() will + return, even though value isn't perfectly accurate. */ + if ((numtype & (IS_NUMBER_IN_UV #ifdef NV_PRESERVES_UV - | IS_NUMBER_NOT_INT + | IS_NUMBER_NOT_INT #endif - )) == IS_NUMBER_IN_UV) { - /* This won't turn off the public IOK flag if it was set above */ - (void)SvIOKp_on(sv); - - if (!(numtype & IS_NUMBER_NEG)) { - /* positive */; - if (value <= (UV)IV_MAX) { - SvIV_set(sv, (IV)value); - } else { - /* it didn't overflow, and it was positive. */ - SvUV_set(sv, value); - SvIsUV_on(sv); - } - } else { - /* 2s complement assumption */ - if (value <= (UV)IV_MIN) { - SvIV_set(sv, value == (UV)IV_MIN + )) == IS_NUMBER_IN_UV) { + /* This won't turn off the public IOK flag if it was set above */ + (void)SvIOKp_on(sv); + + if (!(numtype & IS_NUMBER_NEG)) { + /* positive */; + if (value <= (UV)IV_MAX) { + SvIV_set(sv, (IV)value); + } else { + /* it didn't overflow, and it was positive. */ + SvUV_set(sv, value); + SvIsUV_on(sv); + } + } else { + /* 2s complement assumption */ + if (value <= (UV)IV_MIN) { + SvIV_set(sv, value == (UV)IV_MIN ? IV_MIN : -(IV)value); - } else { - /* Too negative for an IV. This is a double upgrade, but - I'm assuming it will be rare. */ - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - SvNOK_on(sv); - SvIOK_off(sv); - SvIOKp_on(sv); - SvNV_set(sv, -(NV)value); - SvIV_set(sv, IV_MIN); - } - } - } - /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we + } else { + /* Too negative for an IV. This is a double upgrade, but + I'm assuming it will be rare. */ + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + SvNOK_on(sv); + SvIOK_off(sv); + SvIOKp_on(sv); + SvNV_set(sv, -(NV)value); + SvIV_set(sv, IV_MIN); + } + } + } + /* For !NV_PRESERVES_UV and IS_NUMBER_IN_UV and IS_NUMBER_NOT_INT we will be in the previous block to set the IV slot, and the next block to set the NV slot. So no else here. */ - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - != IS_NUMBER_IN_UV) { - /* It wasn't an (integer that doesn't overflow the UV). */ + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + != IS_NUMBER_IN_UV) { + /* It wasn't an (integer that doesn't overflow the UV). */ S_sv_setnv(aTHX_ sv, numtype); - if (! numtype && ckWARN(WARN_NUMERIC)) - not_a_number(sv); + if (! numtype && ckWARN(WARN_NUMERIC)) + not_a_number(sv); - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" NVgf ")\n", - PTR2UV(sv), SvNVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" NVgf ")\n", + PTR2UV(sv), SvNVX(sv))); #ifdef NV_PRESERVES_UV (void)SvIOKp_on(sv); @@ -2323,7 +2323,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv) if ((NV)(SvIVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); } else { - NOOP; /* Integer is imprecise. NOK, IOKp */ + NOOP; /* Integer is imprecise. NOK, IOKp */ } /* UV will not work better than IV */ } else { @@ -2338,10 +2338,10 @@ S_sv_2iuv_common(pTHX_ SV *const sv) if ((NV)(SvUVX(sv)) == SvNVX(sv)) { SvIOK_on(sv); } else { - NOOP; /* Integer is imprecise. NOK, IOKp, is UV */ + NOOP; /* Integer is imprecise. NOK, IOKp, is UV */ } } - SvIsUV_on(sv); + SvIsUV_on(sv); } #else /* NV_PRESERVES_UV */ if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) @@ -2349,7 +2349,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv) /* The IV/UV slot will have been set from value returned by grok_number above. The NV slot has just been set using Atof. */ - SvNOK_on(sv); + SvNOK_on(sv); assert (SvIOKp(sv)); } else { if (((UV)1 << NV_PRESERVES_UV_BITS) > @@ -2371,7 +2371,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv) 0 0 already failed to read UV. 0 1 already failed to read UV. 1 0 you won't get here in this case. IV/UV - slot set, public IOK, Atof() unneeded. + slot set, public IOK, Atof() unneeded. 1 1 already read UV. so there's no point in sv_2iuv_non_preserve() attempting to use atol, strtol, strtoul etc. */ @@ -2383,25 +2383,25 @@ S_sv_2iuv_common(pTHX_ SV *const sv) } } #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); - } + /* 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(MUTABLE_GV(sv)); + if (isGV_with_GP(sv)) + return glob_2number(MUTABLE_GV(sv)); - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - if (SvTYPE(sv) < SVt_IV) - /* Typically the caller expects that sv_any is not NULL now. */ - sv_upgrade(sv, SVt_IV); - /* Return 0 from the caller. */ - return TRUE; + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + if (SvTYPE(sv) < SVt_IV) + /* Typically the caller expects that sv_any is not NULL now. */ + sv_upgrade(sv, SVt_IV); + /* Return 0 from the caller. */ + return TRUE; } return FALSE; } @@ -2422,52 +2422,52 @@ Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) PERL_ARGS_ASSERT_SV_2IV_FLAGS; assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV - && SvTYPE(sv) != SVt_PVFM); + && SvTYPE(sv) != SVt_PVFM); if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) - mg_get(sv); + mg_get(sv); if (SvROK(sv)) { - if (SvAMAGIC(sv)) { - SV * tmpstr; - if (flags & SV_SKIP_OVERLOAD) - return 0; - tmpstr = AMG_CALLunary(sv, numer_amg); - if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - return SvIV(tmpstr); - } - } - return PTR2IV(SvRV(sv)); + if (SvAMAGIC(sv)) { + SV * tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr = AMG_CALLunary(sv, numer_amg); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvIV(tmpstr); + } + } + return PTR2IV(SvRV(sv)); } if (SvVALID(sv) || isREGEXP(sv)) { /* FBMs use the space for SvIVX and SvNVX for other purposes, so must not let them cache IVs. - In practice they are extremely unlikely to actually get anywhere - accessible by user Perl code - the only way that I'm aware of is when - a constant subroutine which is used as the second argument to index. - - Regexps have no SvIVX and SvNVX fields. - */ - assert(SvPOKp(sv)); - { - UV value; - const char * const ptr = - isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); - const int numtype - = grok_number(ptr, SvCUR(sv), &value); - - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer */ - if (numtype & IS_NUMBER_NEG) { - if (value < (UV)IV_MIN) - return -(IV)value; - } else { - if (value < (UV)IV_MAX) - return (IV)value; - } - } + In practice they are extremely unlikely to actually get anywhere + accessible by user Perl code - the only way that I'm aware of is when + a constant subroutine which is used as the second argument to index. + + Regexps have no SvIVX and SvNVX fields. + */ + assert(SvPOKp(sv)); + { + UV value; + const char * const ptr = + isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); + const int numtype + = grok_number(ptr, SvCUR(sv), &value); + + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer */ + if (numtype & IS_NUMBER_NEG) { + if (value < (UV)IV_MIN) + return -(IV)value; + } else { + if (value < (UV)IV_MAX) + return (IV)value; + } + } /* Quite wrong but no good choices. */ if ((numtype & IS_NUMBER_INFINITY)) { @@ -2476,29 +2476,29 @@ Perl_sv_2iv_flags(pTHX_ SV *const sv, const I32 flags) return 0; /* So wrong. */ } - if (!numtype) { - if (ckWARN(WARN_NUMERIC)) - not_a_number(sv); - } - return I_V(Atof(ptr)); - } + if (!numtype) { + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } + return I_V(Atof(ptr)); + } } if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && !SvOK(sv)) { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - return 0; - } + if (SvREADONLY(sv) && !SvOK(sv)) { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + return 0; + } } if (!SvIOKp(sv)) { - if (S_sv_2iuv_common(aTHX_ sv)) - return 0; + if (S_sv_2iuv_common(aTHX_ sv)) + return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2iv(%" IVdf ")\n", - PTR2UV(sv),SvIVX(sv))); + PTR2UV(sv),SvIVX(sv))); return SvIsUV(sv) ? (IV)SvUVX(sv) : SvIVX(sv); } @@ -2520,39 +2520,39 @@ Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) PERL_ARGS_ASSERT_SV_2UV_FLAGS; if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) - mg_get(sv); + mg_get(sv); if (SvROK(sv)) { - if (SvAMAGIC(sv)) { - SV *tmpstr; - if (flags & SV_SKIP_OVERLOAD) - return 0; - tmpstr = AMG_CALLunary(sv, numer_amg); - if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - return SvUV(tmpstr); - } - } - return PTR2UV(SvRV(sv)); + if (SvAMAGIC(sv)) { + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr = AMG_CALLunary(sv, numer_amg); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + return SvUV(tmpstr); + } + } + return PTR2UV(SvRV(sv)); } if (SvVALID(sv) || isREGEXP(sv)) { - /* FBMs use the space for SvIVX and SvNVX for other purposes, and use - the same flag bit as SVf_IVisUV, so must not let them cache IVs. - Regexps have no SvIVX and SvNVX fields. */ - assert(SvPOKp(sv)); - { - UV value; - const char * const ptr = - isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); - const int numtype - = grok_number(ptr, SvCUR(sv), &value); - - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer */ - if (!(numtype & IS_NUMBER_NEG)) - return value; - } + /* FBMs use the space for SvIVX and SvNVX for other purposes, and use + the same flag bit as SVf_IVisUV, so must not let them cache IVs. + Regexps have no SvIVX and SvNVX fields. */ + assert(SvPOKp(sv)); + { + UV value; + const char * const ptr = + isREGEXP(sv) ? RX_WRAPPED((REGEXP*)sv) : SvPVX_const(sv); + const int numtype + = grok_number(ptr, SvCUR(sv), &value); + + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer */ + if (!(numtype & IS_NUMBER_NEG)) + return value; + } /* Quite wrong but no good choices. */ if ((numtype & IS_NUMBER_INFINITY)) { @@ -2561,29 +2561,29 @@ Perl_sv_2uv_flags(pTHX_ SV *const sv, const I32 flags) return 0; /* So wrong. */ } - if (!numtype) { - if (ckWARN(WARN_NUMERIC)) - not_a_number(sv); - } - return U_V(Atof(ptr)); - } + if (!numtype) { + if (ckWARN(WARN_NUMERIC)) + not_a_number(sv); + } + return U_V(Atof(ptr)); + } } if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv) && !SvOK(sv)) { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - return 0; - } + if (SvREADONLY(sv) && !SvOK(sv)) { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + return 0; + } } if (!SvIOKp(sv)) { - if (S_sv_2iuv_common(aTHX_ sv)) - return 0; + if (S_sv_2iuv_common(aTHX_ sv)) + return 0; } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2uv(%" UVuf ")\n", - PTR2UV(sv),SvUVX(sv))); + PTR2UV(sv),SvUVX(sv))); return SvIsUV(sv) ? SvUVX(sv) : (UV)SvIVX(sv); } @@ -2603,129 +2603,129 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) PERL_ARGS_ASSERT_SV_2NV_FLAGS; assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV - && SvTYPE(sv) != SVt_PVFM); + && SvTYPE(sv) != SVt_PVFM); if (SvGMAGICAL(sv) || SvVALID(sv) || isREGEXP(sv)) { - /* FBMs use the space for SvIVX and SvNVX for other purposes, and use - the same flag bit as SVf_IVisUV, so must not let them cache NVs. - Regexps have no SvIVX and SvNVX fields. */ - const char *ptr; - if (flags & SV_GMAGIC) - mg_get(sv); - if (SvNOKp(sv)) - return SvNVX(sv); - if (SvPOKp(sv) && !SvIOKp(sv)) { - ptr = SvPVX_const(sv); - if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && - !grok_number(ptr, SvCUR(sv), NULL)) - not_a_number(sv); - return Atof(ptr); - } - if (SvIOKp(sv)) { - if (SvIsUV(sv)) - return (NV)SvUVX(sv); - else - return (NV)SvIVX(sv); - } + /* FBMs use the space for SvIVX and SvNVX for other purposes, and use + the same flag bit as SVf_IVisUV, so must not let them cache NVs. + Regexps have no SvIVX and SvNVX fields. */ + const char *ptr; + if (flags & SV_GMAGIC) + mg_get(sv); + if (SvNOKp(sv)) + return SvNVX(sv); + if (SvPOKp(sv) && !SvIOKp(sv)) { + ptr = SvPVX_const(sv); + if (!SvIOKp(sv) && ckWARN(WARN_NUMERIC) && + !grok_number(ptr, SvCUR(sv), NULL)) + not_a_number(sv); + return Atof(ptr); + } + if (SvIOKp(sv)) { + if (SvIsUV(sv)) + return (NV)SvUVX(sv); + else + return (NV)SvIVX(sv); + } if (SvROK(sv)) { - goto return_rok; - } - assert(SvTYPE(sv) >= SVt_PVMG); - /* This falls through to the report_uninit near the end of the - function. */ + goto return_rok; + } + assert(SvTYPE(sv) >= SVt_PVMG); + /* This falls through to the report_uninit near the end of the + function. */ } else if (SvTHINKFIRST(sv)) { - if (SvROK(sv)) { - return_rok: - if (SvAMAGIC(sv)) { - SV *tmpstr; - if (flags & SV_SKIP_OVERLOAD) - return 0; - tmpstr = AMG_CALLunary(sv, numer_amg); + if (SvROK(sv)) { + return_rok: + if (SvAMAGIC(sv)) { + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return 0; + tmpstr = AMG_CALLunary(sv, numer_amg); if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - return SvNV(tmpstr); - } - } - return PTR2NV(SvRV(sv)); - } - if (SvREADONLY(sv) && !SvOK(sv)) { - if (ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - return 0.0; - } + return SvNV(tmpstr); + } + } + return PTR2NV(SvRV(sv)); + } + if (SvREADONLY(sv) && !SvOK(sv)) { + if (ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + return 0.0; + } } if (SvTYPE(sv) < SVt_NV) { - /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ - sv_upgrade(sv, SVt_NV); + /* The logic to use SVt_PVNV if necessary is in sv_upgrade. */ + sv_upgrade(sv, SVt_NV); CLANG_DIAG_IGNORE_STMT(-Wthread-safety); - DEBUG_c({ + DEBUG_c({ DECLARATION_FOR_LC_NUMERIC_MANIPULATION; STORE_LC_NUMERIC_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, - "0x%" UVxf " num(%" NVgf ")\n", - PTR2UV(sv), SvNVX(sv)); + PerlIO_printf(Perl_debug_log, + "0x%" UVxf " num(%" NVgf ")\n", + PTR2UV(sv), SvNVX(sv)); RESTORE_LC_NUMERIC(); - }); + }); CLANG_DIAG_RESTORE_STMT; } else if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); + sv_upgrade(sv, SVt_PVNV); if (SvNOKp(sv)) { return SvNVX(sv); } if (SvIOKp(sv)) { - SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); + SvNV_set(sv, SvIsUV(sv) ? (NV)SvUVX(sv) : (NV)SvIVX(sv)); #ifdef NV_PRESERVES_UV - if (SvIOK(sv)) - SvNOK_on(sv); - else - SvNOKp_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 (SvIOK(sv) && - SvIsUV(sv) ? ((SvUVX(sv) != UV_MAX)&&(SvUVX(sv) == U_V(SvNVX(sv)))) - : (SvIVX(sv) == I_V(SvNVX(sv)))) - SvNOK_on(sv); - else - SvNOKp_on(sv); + /* Only set the public NV OK flag if this NV preserves the IV */ + /* Check it's not 0xFFFFFFFFFFFFFFFF */ + 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 + SvNOKp_on(sv); #endif } else if (SvPOKp(sv)) { - UV value; - const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); - if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) - not_a_number(sv); + UV value; + const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), &value); + if (!SvIOKp(sv) && !numtype && ckWARN(WARN_NUMERIC)) + not_a_number(sv); #ifdef NV_PRESERVES_UV - if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) - == IS_NUMBER_IN_UV) { - /* It's definitely an integer */ - SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); - } else { + if ((numtype & (IS_NUMBER_IN_UV | IS_NUMBER_NOT_INT)) + == IS_NUMBER_IN_UV) { + /* It's definitely an integer */ + SvNV_set(sv, (numtype & IS_NUMBER_NEG) ? -(NV)value : (NV)value); + } else { S_sv_setnv(aTHX_ sv, numtype); } - if (numtype) - SvNOK_on(sv); - else - SvNOKp_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 - the PV at least as well as an IV/UV would. - Not sure how to do this 100% reliably. */ - /* if that shift count is out of range then Configure's test is - wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == - UV_BITS */ - if (((UV)1 << NV_PRESERVES_UV_BITS) > - U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { - SvNOK_on(sv); /* Definitely small enough to preserve all bits */ - } else if (!(numtype & IS_NUMBER_IN_UV)) { + SvNV_set(sv, Atof(SvPVX_const(sv))); + /* Only set the public NV OK flag if this NV preserves the value in + the PV at least as well as an IV/UV would. + Not sure how to do this 100% reliably. */ + /* if that shift count is out of range then Configure's test is + wonky. We shouldn't be in here with NV_PRESERVES_UV_BITS == + UV_BITS */ + if (((UV)1 << NV_PRESERVES_UV_BITS) > + U_V(SvNVX(sv) > 0 ? SvNVX(sv) : -SvNVX(sv))) { + SvNOK_on(sv); /* Definitely small enough to preserve all bits */ + } else if (!(numtype & IS_NUMBER_IN_UV)) { /* Can't use strtol etc to convert this string, so don't try. sv_2iv and sv_2uv will use the NV to convert, not the PV. */ SvNOK_on(sv); } else { /* value has been set. It may not be precise. */ - if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) { - /* 2s complement assumption for (UV)IV_MIN */ + if ((numtype & IS_NUMBER_NEG) && (value >= (UV)IV_MIN)) { + /* 2s complement assumption for (UV)IV_MIN */ SvNOK_on(sv); /* Integer is too negative. */ } else { SvNOKp_on(sv); @@ -2738,11 +2738,11 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) assert(value != (UV)IV_MIN); SvIV_set(sv, -(IV)value); } else if (value <= (UV)IV_MAX) { - SvIV_set(sv, (IV)value); - } else { - SvUV_set(sv, value); - SvIsUV_on(sv); - } + SvIV_set(sv, (IV)value); + } else { + SvUV_set(sv, value); + SvIsUV_on(sv); + } if (numtype & IS_NUMBER_NOT_INT) { /* I believe that even if the original PV had decimals, @@ -2751,7 +2751,7 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) flags. NWC, 2000/11/25 */ /* Both already have p flags, so do nothing */ } else { - const NV nv = SvNVX(sv); + const NV nv = SvNVX(sv); /* XXX should this spot have NAN_COMPARE_BROKEN, too? */ if (SvNVX(sv) < (NV)IV_MAX + 0.5) { if (SvIVX(sv) == I_V(nv)) { @@ -2759,7 +2759,7 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) } else { /* It had no "." so it must be integer. */ } - SvIOK_on(sv); + SvIOK_on(sv); } else { /* between IV_MAX and NV(UV_MAX). Could be slightly > UV_MAX */ @@ -2767,45 +2767,45 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) if (numtype & IS_NUMBER_NOT_INT) { /* UV and NV both imprecise. */ } else { - const UV nv_as_uv = U_V(nv); + const UV nv_as_uv = U_V(nv); if (value == nv_as_uv && SvUVX(sv) != UV_MAX) { SvNOK_on(sv); } - SvIOK_on(sv); + SvIOK_on(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); + /* 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(MUTABLE_GV(sv)); - return 0.0; - } - - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - assert (SvTYPE(sv) >= SVt_NV); - /* Typically the caller expects that sv_any is not NULL now. */ - /* XXX Ilya implies that this is a bug in callers that assume this - and ideally should be fixed. */ - return 0.0; + if (isGV_with_GP(sv)) { + glob_2number(MUTABLE_GV(sv)); + return 0.0; + } + + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + assert (SvTYPE(sv) >= SVt_NV); + /* Typically the caller expects that sv_any is not NULL now. */ + /* XXX Ilya implies that this is a bug in callers that assume this + and ideally should be fixed. */ + return 0.0; } CLANG_DIAG_IGNORE_STMT(-Wthread-safety); DEBUG_c({ DECLARATION_FOR_LC_NUMERIC_MANIPULATION; STORE_LC_NUMERIC_SET_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n", - PTR2UV(sv), SvNVX(sv)); + PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2nv(%" NVgf ")\n", + PTR2UV(sv), SvNVX(sv)); RESTORE_LC_NUMERIC(); }); CLANG_DIAG_RESTORE_STMT; @@ -2828,12 +2828,12 @@ Perl_sv_2num(pTHX_ SV *const sv) PERL_ARGS_ASSERT_SV_2NUM; if (!SvROK(sv)) - return sv; + return sv; if (SvAMAGIC(sv)) { - SV * const tmpsv = AMG_CALLunary(sv, numer_amg); - TAINT_IF(tmpsv && SvTAINTED(tmpsv)); - if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) - return sv_2num(tmpsv); + SV * const tmpsv = AMG_CALLunary(sv, numer_amg); + TAINT_IF(tmpsv && SvTAINTED(tmpsv)); + if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) + return sv_2num(tmpsv); } return sv_2mortal(newSVuv(PTR2UV(SvRV(sv)))); } @@ -2890,14 +2890,14 @@ S_uiv_2buf(char *const buf, const IV iv, UV uv, const int is_uv, char **const pe word_table = (U16*)int2str_table.arr; if (UNLIKELY(is_uv)) - sign = 0; + sign = 0; else if (iv >= 0) { - uv = iv; - sign = 0; + uv = iv; + sign = 0; } else { /* Using 0- here to silence bogus warning from MS VC */ uv = (UV) (0 - (UV) iv); - sign = 1; + sign = 1; } while (uv > 99) { @@ -2982,179 +2982,179 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags) PERL_ARGS_ASSERT_SV_2PV_FLAGS; assert (SvTYPE(sv) != SVt_PVAV && SvTYPE(sv) != SVt_PVHV - && SvTYPE(sv) != SVt_PVFM); + && SvTYPE(sv) != SVt_PVFM); if (SvGMAGICAL(sv) && (flags & SV_GMAGIC)) - mg_get(sv); + mg_get(sv); if (SvROK(sv)) { - if (SvAMAGIC(sv)) { - SV *tmpstr; - if (flags & SV_SKIP_OVERLOAD) - return NULL; - tmpstr = AMG_CALLunary(sv, string_amg); - TAINT_IF(tmpstr && SvTAINTED(tmpstr)); - if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { - /* Unwrap this: */ - /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); - */ - - char *pv; - if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { - if (flags & SV_CONST_RETURN) { - pv = (char *) SvPVX_const(tmpstr); - } else { - pv = (flags & SV_MUTABLE_RETURN) - ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); - } - if (lp) - *lp = SvCUR(tmpstr); - } else { - pv = sv_2pv_flags(tmpstr, lp, flags); - } - if (SvUTF8(tmpstr)) - SvUTF8_on(sv); - else - SvUTF8_off(sv); - return pv; - } - } - { - STRLEN len; - char *retval; - char *buffer; - SV *const referent = SvRV(sv); - - if (!referent) { - len = 7; - retval = buffer = savepvn("NULLREF", len); - } else if (SvTYPE(referent) == SVt_REGEXP && - (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) || - amagic_is_enabled(string_amg))) { - REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); - - 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 (lp) - *lp = RX_WRAPLEN(re); - - return RX_WRAPPED(re); - } else { - const char *const typestring = sv_reftype(referent, 0); - const STRLEN typelen = strlen(typestring); - UV addr = PTR2UV(referent); - const char *stashname = NULL; - STRLEN stashnamelen = 0; /* hush, gcc */ - const char *buffer_end; - - if (SvOBJECT(referent)) { - const HEK *const name = HvNAME_HEK(SvSTASH(referent)); - - if (name) { - stashname = HEK_KEY(name); - stashnamelen = HEK_LEN(name); - - if (HEK_UTF8(name)) { - SvUTF8_on(sv); - } else { - SvUTF8_off(sv); - } - } else { - stashname = "__ANON__"; - stashnamelen = 8; - } - len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ - + 2 * sizeof(UV) + 2 /* )\0 */; - } else { - len = typelen + 3 /* (0x */ - + 2 * sizeof(UV) + 2 /* )\0 */; - } - - Newx(buffer, len, char); - buffer_end = retval = buffer + len; - - /* Working backwards */ - *--retval = '\0'; - *--retval = ')'; - do { - *--retval = PL_hexdigit[addr & 15]; - } while (addr >>= 4); - *--retval = 'x'; - *--retval = '0'; - *--retval = '('; - - retval -= typelen; - memcpy(retval, typestring, typelen); - - if (stashname) { - *--retval = '='; - retval -= stashnamelen; - memcpy(retval, stashname, stashnamelen); - } - /* retval may not necessarily have reached the start of the - buffer here. */ - assert (retval >= buffer); - - len = buffer_end - retval - 1; /* -1 for that \0 */ - } - if (lp) - *lp = len; - SAVEFREEPV(buffer); - return retval; - } + if (SvAMAGIC(sv)) { + SV *tmpstr; + if (flags & SV_SKIP_OVERLOAD) + return NULL; + tmpstr = AMG_CALLunary(sv, string_amg); + TAINT_IF(tmpstr && SvTAINTED(tmpstr)); + if (tmpstr && (!SvROK(tmpstr) || (SvRV(tmpstr) != SvRV(sv)))) { + /* Unwrap this: */ + /* char *pv = lp ? SvPV(tmpstr, *lp) : SvPV_nolen(tmpstr); + */ + + char *pv; + if ((SvFLAGS(tmpstr) & (SVf_POK)) == SVf_POK) { + if (flags & SV_CONST_RETURN) { + pv = (char *) SvPVX_const(tmpstr); + } else { + pv = (flags & SV_MUTABLE_RETURN) + ? SvPVX_mutable(tmpstr) : SvPVX(tmpstr); + } + if (lp) + *lp = SvCUR(tmpstr); + } else { + pv = sv_2pv_flags(tmpstr, lp, flags); + } + if (SvUTF8(tmpstr)) + SvUTF8_on(sv); + else + SvUTF8_off(sv); + return pv; + } + } + { + STRLEN len; + char *retval; + char *buffer; + SV *const referent = SvRV(sv); + + if (!referent) { + len = 7; + retval = buffer = savepvn("NULLREF", len); + } else if (SvTYPE(referent) == SVt_REGEXP && + (!(PL_curcop->cop_hints & HINT_NO_AMAGIC) || + amagic_is_enabled(string_amg))) { + REGEXP * const re = (REGEXP *)MUTABLE_PTR(referent); + + 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 (lp) + *lp = RX_WRAPLEN(re); + + return RX_WRAPPED(re); + } else { + const char *const typestring = sv_reftype(referent, 0); + const STRLEN typelen = strlen(typestring); + UV addr = PTR2UV(referent); + const char *stashname = NULL; + STRLEN stashnamelen = 0; /* hush, gcc */ + const char *buffer_end; + + if (SvOBJECT(referent)) { + const HEK *const name = HvNAME_HEK(SvSTASH(referent)); + + if (name) { + stashname = HEK_KEY(name); + stashnamelen = HEK_LEN(name); + + if (HEK_UTF8(name)) { + SvUTF8_on(sv); + } else { + SvUTF8_off(sv); + } + } else { + stashname = "__ANON__"; + stashnamelen = 8; + } + len = stashnamelen + 1 /* = */ + typelen + 3 /* (0x */ + + 2 * sizeof(UV) + 2 /* )\0 */; + } else { + len = typelen + 3 /* (0x */ + + 2 * sizeof(UV) + 2 /* )\0 */; + } + + Newx(buffer, len, char); + buffer_end = retval = buffer + len; + + /* Working backwards */ + *--retval = '\0'; + *--retval = ')'; + do { + *--retval = PL_hexdigit[addr & 15]; + } while (addr >>= 4); + *--retval = 'x'; + *--retval = '0'; + *--retval = '('; + + retval -= typelen; + memcpy(retval, typestring, typelen); + + if (stashname) { + *--retval = '='; + retval -= stashnamelen; + memcpy(retval, stashname, stashnamelen); + } + /* retval may not necessarily have reached the start of the + buffer here. */ + assert (retval >= buffer); + + len = buffer_end - retval - 1; /* -1 for that \0 */ + } + if (lp) + *lp = len; + SAVEFREEPV(buffer); + return retval; + } } if (SvPOKp(sv)) { - if (lp) - *lp = SvCUR(sv); - if (flags & SV_MUTABLE_RETURN) - return SvPVX_mutable(sv); - if (flags & SV_CONST_RETURN) - return (char *)SvPVX_const(sv); - return SvPVX(sv); + if (lp) + *lp = SvCUR(sv); + if (flags & SV_MUTABLE_RETURN) + return SvPVX_mutable(sv); + if (flags & SV_CONST_RETURN) + return (char *)SvPVX_const(sv); + return SvPVX(sv); } if (SvIOK(sv)) { - /* I'm assuming that if both IV and NV are equally valid then - converting the IV is going to be more efficient */ - const U32 isUIOK = SvIsUV(sv); + /* I'm assuming that if both IV and NV are equally valid then + converting the IV is going to be more efficient */ + const U32 isUIOK = SvIsUV(sv); /* The purpose of this union is to ensure that arr is aligned on a 2 byte boundary, because that is what uiv_2buf() requires */ union { char arr[TYPE_CHARS(UV)]; U16 dummy; } buf; - char *ebuf, *ptr; - STRLEN len; + char *ebuf, *ptr; + STRLEN len; - if (SvTYPE(sv) < SVt_PVIV) - sv_upgrade(sv, SVt_PVIV); + if (SvTYPE(sv) < SVt_PVIV) + sv_upgrade(sv, SVt_PVIV); ptr = uiv_2buf(buf.arr, SvIVX(sv), SvUVX(sv), isUIOK, &ebuf); - len = ebuf - ptr; - /* inlined from sv_setpvn */ - s = SvGROW_mutable(sv, len + 1); - Move(ptr, s, len, char); - s += len; - *s = '\0'; + len = ebuf - ptr; + /* inlined from sv_setpvn */ + s = SvGROW_mutable(sv, len + 1); + Move(ptr, s, len, char); + s += len; + *s = '\0'; SvPOK_on(sv); } else if (SvNOK(sv)) { - if (SvTYPE(sv) < SVt_PVNV) - sv_upgrade(sv, SVt_PVNV); - if (SvNVX(sv) == 0.0 + if (SvTYPE(sv) < SVt_PVNV) + sv_upgrade(sv, SVt_PVNV); + if (SvNVX(sv) == 0.0 #if defined(NAN_COMPARE_BROKEN) && defined(Perl_isnan) - && !Perl_isnan(SvNVX(sv)) + && !Perl_isnan(SvNVX(sv)) #endif - ) { - s = SvGROW_mutable(sv, 2); - *s++ = '0'; - *s = '\0'; - } else { + ) { + s = SvGROW_mutable(sv, 2); + *s++ = '0'; + *s = '\0'; + } else { STRLEN len; STRLEN size = 5; /* "-Inf\0" */ @@ -3217,48 +3217,48 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags) RESTORE_ERRNO; } while (*s) s++; - } + } } else if (isGV_with_GP(sv)) { - GV *const gv = MUTABLE_GV(sv); - SV *const buffer = sv_newmortal(); + GV *const gv = MUTABLE_GV(sv); + SV *const buffer = sv_newmortal(); - gv_efullname3(buffer, gv, "*"); + gv_efullname3(buffer, gv, "*"); - assert(SvPOK(buffer)); - if (SvUTF8(buffer)) - SvUTF8_on(sv); + assert(SvPOK(buffer)); + if (SvUTF8(buffer)) + SvUTF8_on(sv); else SvUTF8_off(sv); - if (lp) - *lp = SvCUR(buffer); - return SvPVX(buffer); + if (lp) + *lp = SvCUR(buffer); + return SvPVX(buffer); } else { - if (lp) - *lp = 0; - if (flags & SV_UNDEF_RETURNS_NULL) - return NULL; - if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) - report_uninit(sv); - /* Typically the caller expects that sv_any is not NULL now. */ - if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV) - sv_upgrade(sv, SVt_PV); - return (char *)""; + if (lp) + *lp = 0; + if (flags & SV_UNDEF_RETURNS_NULL) + return NULL; + if (!PL_localizing && ckWARN(WARN_UNINITIALIZED)) + report_uninit(sv); + /* Typically the caller expects that sv_any is not NULL now. */ + if (!SvREADONLY(sv) && SvTYPE(sv) < SVt_PV) + sv_upgrade(sv, SVt_PV); + return (char *)""; } { - const STRLEN len = s - SvPVX_const(sv); - if (lp) - *lp = len; - SvCUR_set(sv, len); + const STRLEN len = s - SvPVX_const(sv); + if (lp) + *lp = len; + SvCUR_set(sv, len); } DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n", - PTR2UV(sv),SvPVX_const(sv))); + PTR2UV(sv),SvPVX_const(sv))); if (flags & SV_CONST_RETURN) - return (char *)SvPVX_const(sv); + return (char *)SvPVX_const(sv); if (flags & SV_MUTABLE_RETURN) - return SvPVX_mutable(sv); + return SvPVX_mutable(sv); return SvPVX(sv); } @@ -3293,9 +3293,9 @@ Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) s = SvPV_flags_const(ssv,len,(flags & SV_GMAGIC)); sv_setpvn(dsv,s,len); if (SvUTF8(ssv)) - SvUTF8_on(dsv); + SvUTF8_on(dsv); else - SvUTF8_off(dsv); + SvUTF8_off(dsv); } /* @@ -3322,9 +3322,9 @@ Perl_sv_2pvbyte_flags(pTHX_ SV *sv, STRLEN *const lp, const U32 flags) mg_get(sv); if (((SvREADONLY(sv) || SvFAKE(sv)) && !SvIsCOW(sv)) || isGV_with_GP(sv) || SvROK(sv)) { - SV *sv2 = sv_newmortal(); - sv_copypv_nomg(sv2,sv); - sv = sv2; + SV *sv2 = sv_newmortal(); + sv_copypv_nomg(sv2,sv); + sv = sv2; } sv_utf8_downgrade_nomg(sv,0); return lp ? SvPV_nomg(sv,*lp) : SvPV_nomg_nolen(sv); @@ -3385,11 +3385,11 @@ Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags) if(flags & SV_GMAGIC) SvGETMAGIC(sv); if (!SvOK(sv)) - return 0; + return 0; if (SvROK(sv)) { - if (SvAMAGIC(sv)) { - SV * const tmpsv = AMG_CALLunary(sv, bool__amg); - if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) { + if (SvAMAGIC(sv)) { + SV * const tmpsv = AMG_CALLunary(sv, bool__amg); + if (tmpsv && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) { bool svb; sv = tmpsv; if(SvGMAGICAL(sv)) { @@ -3413,13 +3413,13 @@ Perl_sv_2bool_flags(pTHX_ SV *sv, I32 flags) } return cBOOL(svb); } - } - assert(SvRV(sv)); - return TRUE; + } + assert(SvRV(sv)); + return TRUE; } if (isREGEXP(sv)) - return - RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0'); + return + RX_WRAPLEN(sv) > 1 || (RX_WRAPLEN(sv) && *RX_WRAPPED(sv) != '0'); if (SvNOK(sv) && !SvPOK(sv)) return SvNVX(sv) != 0.0; @@ -3474,18 +3474,18 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr PERL_ARGS_ASSERT_SV_UTF8_UPGRADE_FLAGS_GROW; if (sv == &PL_sv_undef) - return 0; + return 0; if (!SvPOK_nog(sv)) { - STRLEN len = 0; - if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { - (void) sv_2pv_flags(sv,&len, flags); - if (SvUTF8(sv)) { - if (extra) SvGROW(sv, SvCUR(sv) + extra); - return len; - } - } else { - (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC); - } + STRLEN len = 0; + if (SvREADONLY(sv) && (SvPOKp(sv) || SvIOKp(sv) || SvNOKp(sv))) { + (void) sv_2pv_flags(sv,&len, flags); + if (SvUTF8(sv)) { + if (extra) SvGROW(sv, SvCUR(sv) + extra); + return len; + } + } else { + (void) SvPV_force_flags(sv,len,flags & SV_GMAGIC); + } } /* SVt_REGEXP's shouldn't be upgraded to UTF8 - they're already @@ -3494,8 +3494,8 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr * PVX of a REGEXP should be grown or we should just croak, I don't * know - DAPM */ if (SvUTF8(sv) || isREGEXP(sv)) { - if (extra) SvGROW(sv, SvCUR(sv) + extra); - return SvCUR(sv); + if (extra) SvGROW(sv, SvCUR(sv) + extra); + return SvCUR(sv); } if (SvIsCOW(sv)) { @@ -3506,12 +3506,12 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr if (extra) SvGROW(sv, extra + 1); /* Make sure is room for a trailing byte */ } else { /* Assume Latin-1/EBCDIC */ - /* This function could be much more efficient if we - * 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. */ - U8 * s = (U8 *) SvPVX_const(sv); - U8 *t = s; + /* This function could be much more efficient if we + * 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. */ + U8 * s = (U8 *) SvPVX_const(sv); + U8 *t = s; if (is_utf8_invariant_string_loc(s, SvCUR(sv), (const U8 **) &t)) { @@ -3528,9 +3528,9 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr * * Note that the incoming SV may not have a trailing '\0', as certain * code in pp_formline can send us partially built SVs. - * - * 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 + * + * 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. Going this * route, it's probably best to initially allocate enough space in the * string rather than possibly running out of space and having to @@ -3540,13 +3540,13 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr * space, one could use the worst case scenario, where every remaining * byte expands to two under UTF-8, or one could parse it and count * exactly how many do expand. - * + * * The other way is to unconditionally parse the remainder of the * string to figure out exactly how big the expanded string will be, * growing if needed. Then start at the end of the string and place * the character there at the end of the unfilled space in the expanded * one, working backwards until reaching 't'. - * + * * The problem with assuming the worst case scenario is that for very * long strings, we could allocate much more memory than actually * needed, which can create performance problems. If we have to parse @@ -3556,7 +3556,7 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr * ASCII platforms, the second method is used exclusively, eliminating * some code that no longer has to be maintained. */ - { + { /* Count the total number of variants there are. We can start * just beyond the first one, which is known to be at 't' */ const Size_t invariant_length = t - s; @@ -3600,21 +3600,21 @@ Perl_sv_utf8_upgrade_flags_grow(pTHX_ SV *const sv, const I32 flags, STRLEN extr e--; } - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - /* Update pos. We do it at the end rather than during - * the upgrade, to avoid slowing down the common case - * (upgrade without pos). - * pos can be stored as either bytes or characters. Since - * this was previously a byte string we can just turn off - * the bytes flag. */ - MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); - if (mg) { - mg->mg_flags &= ~MGf_BYTES; - } - if ((mg = mg_find(sv, PERL_MAGIC_utf8))) - magic_setutf8(sv,mg); /* clear UTF8 cache */ - } - } + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + /* Update pos. We do it at the end rather than during + * the upgrade, to avoid slowing down the common case + * (upgrade without pos). + * pos can be stored as either bytes or characters. Since + * this was previously a byte string we can just turn off + * the bytes flag. */ + MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); + if (mg) { + mg->mg_flags &= ~MGf_BYTES; + } + if ((mg = mg_find(sv, PERL_MAGIC_utf8))) + magic_setutf8(sv,mg); /* clear UTF8 cache */ + } + } } SvUTF8_on(sv); @@ -3652,40 +3652,40 @@ Perl_sv_utf8_downgrade_flags(pTHX_ SV *const sv, const bool fail_ok, const U32 f if (SvPOKp(sv) && SvUTF8(sv)) { if (SvCUR(sv)) { - U8 *s; - STRLEN len; + U8 *s; + STRLEN len; U32 mg_flags = flags & SV_GMAGIC; if (SvIsCOW(sv)) { S_sv_uncow(aTHX_ sv, 0); } - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - /* update pos */ - MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); - if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) { - mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len, - mg_flags|SV_CONST_RETURN); - mg_flags = 0; /* sv_pos_b2u does get magic */ - } - if ((mg = mg_find(sv, PERL_MAGIC_utf8))) - magic_setutf8(sv,mg); /* clear UTF8 cache */ - - } - s = (U8 *) SvPV_flags(sv, len, mg_flags); - - if (!utf8_to_bytes(s, &len)) { - if (fail_ok) - return FALSE; - else { - if (PL_op) - Perl_croak(aTHX_ "Wide character in %s", - OP_DESC(PL_op)); - else - Perl_croak(aTHX_ "Wide character"); - } - } - SvCUR_set(sv, len); - } + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + /* update pos */ + MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); + if (mg && mg->mg_len > 0 && mg->mg_flags & MGf_BYTES) { + mg->mg_len = sv_pos_b2u_flags(sv, mg->mg_len, + mg_flags|SV_CONST_RETURN); + mg_flags = 0; /* sv_pos_b2u does get magic */ + } + if ((mg = mg_find(sv, PERL_MAGIC_utf8))) + magic_setutf8(sv,mg); /* clear UTF8 cache */ + + } + s = (U8 *) SvPV_flags(sv, len, mg_flags); + + if (!utf8_to_bytes(s, &len)) { + if (fail_ok) + return FALSE; + else { + if (PL_op) + Perl_croak(aTHX_ "Wide character in %s", + OP_DESC(PL_op)); + else + Perl_croak(aTHX_ "Wide character"); + } + } + SvCUR_set(sv, len); + } } SvUTF8_off(sv); return TRUE; @@ -3706,7 +3706,7 @@ Perl_sv_utf8_encode(pTHX_ SV *const sv) PERL_ARGS_ASSERT_SV_UTF8_ENCODE; if (SvREADONLY(sv)) { - sv_force_normal_flags(sv, 0); + sv_force_normal_flags(sv, 0); } (void) sv_utf8_upgrade(sv); SvUTF8_off(sv); @@ -3732,11 +3732,11 @@ Perl_sv_utf8_decode(pTHX_ SV *const sv) if (SvPOKp(sv)) { const U8 *start, *c, *first_variant; - /* The octets may have got themselves encoded - get them back as - * bytes - */ - if (!sv_utf8_downgrade(sv, TRUE)) - return FALSE; + /* The octets may have got themselves encoded - get them back as + * bytes + */ + if (!sv_utf8_downgrade(sv, TRUE)) + return FALSE; /* it is actually just a matter of turning the utf8 flag on, but * we want to make sure everything inside is valid utf8 first. @@ -3747,25 +3747,25 @@ Perl_sv_utf8_decode(pTHX_ SV *const sv) return FALSE; SvUTF8_on(sv); } - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC - after this, clearing pos. Does anything on CPAN - need this? */ - /* adjust pos to the start of a UTF8 char sequence */ - MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); - if (mg) { - I32 pos = mg->mg_len; - if (pos > 0) { - for (c = start + pos; c > start; c--) { - if (UTF8_IS_START(*c)) - break; - } - mg->mg_len = c - start; - } - } - if ((mg = mg_find(sv, PERL_MAGIC_utf8))) - magic_setutf8(sv,mg); /* clear UTF8 cache */ - } + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + /* XXX Is this dead code? XS_utf8_decode calls SvSETMAGIC + after this, clearing pos. Does anything on CPAN + need this? */ + /* adjust pos to the start of a UTF8 char sequence */ + MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); + if (mg) { + I32 pos = mg->mg_len; + if (pos > 0) { + for (c = start + pos; c > start; c--) { + if (UTF8_IS_START(*c)) + break; + } + mg->mg_len = c - start; + } + } + if ((mg = mg_find(sv, PERL_MAGIC_utf8))) + magic_setutf8(sv,mg); /* clear UTF8 cache */ + } } return TRUE; } @@ -3815,25 +3815,25 @@ S_glob_assign_glob(pTHX_ SV *const dsv, SV *const ssv, const int dtype) PERL_ARGS_ASSERT_GLOB_ASSIGN_GLOB; if (dtype != SVt_PVGV && !isGV_with_GP(dsv)) { - const char * const name = GvNAME(ssv); - const STRLEN len = GvNAMELEN(ssv); - { - if (dtype >= SVt_PV) { - SvPV_free(dsv); - SvPV_set(dsv, 0); - SvLEN_set(dsv, 0); - SvCUR_set(dsv, 0); - } - SvUPGRADE(dsv, SVt_PVGV); - (void)SvOK_off(dsv); - isGV_with_GP_on(dsv); - } - GvSTASH(dsv) = GvSTASH(ssv); - if (GvSTASH(dsv)) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv); + const char * const name = GvNAME(ssv); + const STRLEN len = GvNAMELEN(ssv); + { + if (dtype >= SVt_PV) { + SvPV_free(dsv); + SvPV_set(dsv, 0); + SvLEN_set(dsv, 0); + SvCUR_set(dsv, 0); + } + SvUPGRADE(dsv, SVt_PVGV); + (void)SvOK_off(dsv); + isGV_with_GP_on(dsv); + } + GvSTASH(dsv) = GvSTASH(ssv); + if (GvSTASH(dsv)) + Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv); gv_name_set(MUTABLE_GV(dsv), name, len, GV_ADD | (GvNAMEUTF8(ssv) ? SVf_UTF8 : 0 )); - SvFAKE_on(dsv); /* can coerce to non-glob */ + SvFAKE_on(dsv); /* can coerce to non-glob */ } if(GvGP(MUTABLE_GV(ssv))) { @@ -3899,46 +3899,46 @@ S_glob_assign_glob(pTHX_ SV *const dsv, SV *const ssv, const int dtype) LEAVE; if (SvTAINTED(ssv)) - SvTAINT(dsv); + SvTAINT(dsv); if (GvIMPORTED(dsv) != GVf_IMPORTED - && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) - { - GvIMPORTED_on(dsv); - } + && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) + { + GvIMPORTED_on(dsv); + } GvMULTI_on(dsv); if(mro_changes == 2) { if (GvAV((const GV *)ssv)) { - MAGIC *mg; - SV * const sref = (SV *)GvAV((const GV *)dsv); - if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { - if (SvTYPE(mg->mg_obj) != SVt_PVAV) { - AV * const ary = newAV(); - av_push(ary, mg->mg_obj); /* takes the refcount */ - mg->mg_obj = (SV *)ary; - } - av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv)); - } - else sv_magic(sref, dsv, PERL_MAGIC_isa, NULL, 0); + MAGIC *mg; + SV * const sref = (SV *)GvAV((const GV *)dsv); + if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { + if (SvTYPE(mg->mg_obj) != SVt_PVAV) { + AV * const ary = newAV(); + av_push(ary, mg->mg_obj); /* takes the refcount */ + mg->mg_obj = (SV *)ary; + } + av_push((AV *)mg->mg_obj, SvREFCNT_inc_simple_NN(dsv)); + } + else sv_magic(sref, dsv, PERL_MAGIC_isa, NULL, 0); } mro_isa_changed_in(GvSTASH(dsv)); } else if(mro_changes == 3) { - HV * const stash = GvHV(dsv); - if(old_stash ? (HV *)HvENAME_get(old_stash) : stash) - mro_package_moved( - stash, old_stash, - (GV *)dsv, 0 - ); + HV * const stash = GvHV(dsv); + if(old_stash ? (HV *)HvENAME_get(old_stash) : stash) + mro_package_moved( + stash, old_stash, + (GV *)dsv, 0 + ); } else if(mro_changes) mro_method_changed_in(GvSTASH(dsv)); if (GvIO(dsv) && dtype == SVt_PVGV) { - DEBUG_o(Perl_deb(aTHX_ - "glob_assign_glob clearing PL_stashcache\n")); - /* It's a cache. It will rebuild itself quite happily. - It's a lot of effort to work out exactly which key (or keys) - might be invalidated by the creation of the this file handle. - */ - hv_clear(PL_stashcache); + DEBUG_o(Perl_deb(aTHX_ + "glob_assign_glob clearing PL_stashcache\n")); + /* It's a cache. It will rebuild itself quite happily. + It's a lot of effort to work out exactly which key (or keys) + might be invalidated by the creation of the this file handle. + */ + hv_clear(PL_stashcache); } return; } @@ -3956,174 +3956,174 @@ Perl_gv_setref(pTHX_ SV *const dsv, SV *const ssv) PERL_ARGS_ASSERT_GV_SETREF; if (intro) { - GvINTRO_off(dsv); /* one-shot flag */ - GvLINE(dsv) = CopLINE(PL_curcop); - GvEGV(dsv) = MUTABLE_GV(dsv); + GvINTRO_off(dsv); /* one-shot flag */ + GvLINE(dsv) = CopLINE(PL_curcop); + GvEGV(dsv) = MUTABLE_GV(dsv); } GvMULTI_on(dsv); switch (stype) { case SVt_PVCV: - location = (SV **) &(GvGP(dsv)->gp_cv); /* XXX bypassing GvCV_set */ - import_flag = GVf_IMPORTED_CV; - goto common; + location = (SV **) &(GvGP(dsv)->gp_cv); /* XXX bypassing GvCV_set */ + import_flag = GVf_IMPORTED_CV; + goto common; case SVt_PVHV: - location = (SV **) &GvHV(dsv); - import_flag = GVf_IMPORTED_HV; - goto common; + location = (SV **) &GvHV(dsv); + import_flag = GVf_IMPORTED_HV; + goto common; case SVt_PVAV: - location = (SV **) &GvAV(dsv); - import_flag = GVf_IMPORTED_AV; - goto common; + location = (SV **) &GvAV(dsv); + import_flag = GVf_IMPORTED_AV; + goto common; case SVt_PVIO: - location = (SV **) &GvIOp(dsv); - goto common; + location = (SV **) &GvIOp(dsv); + goto common; case SVt_PVFM: - location = (SV **) &GvFORM(dsv); - goto common; + location = (SV **) &GvFORM(dsv); + goto common; default: - location = &GvSV(dsv); - import_flag = GVf_IMPORTED_SV; + location = &GvSV(dsv); + import_flag = GVf_IMPORTED_SV; common: - if (intro) { - if (stype == SVt_PVCV) { - /*if (GvCVGEN(dsv) && (GvCV(dsv) != (const CV *)sref || GvCVGEN(dsv))) {*/ - if (GvCVGEN(dsv)) { - SvREFCNT_dec(GvCV(dsv)); - GvCV_set(dsv, NULL); - GvCVGEN(dsv) = 0; /* Switch off cacheness. */ - } - } - /* SAVEt_GVSLOT takes more room on the savestack and has more - overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs - leave_scope needs access to the GV so it can reset method - caches. We must use SAVEt_GVSLOT whenever the type is - SVt_PVCV, even if the stash is anonymous, as the stash may - gain a name somehow before leave_scope. */ - if (stype == SVt_PVCV) { - /* There is no save_pushptrptrptr. Creating it for this - one call site would be overkill. So inline the ss add - routines here. */ + if (intro) { + if (stype == SVt_PVCV) { + /*if (GvCVGEN(dsv) && (GvCV(dsv) != (const CV *)sref || GvCVGEN(dsv))) {*/ + if (GvCVGEN(dsv)) { + SvREFCNT_dec(GvCV(dsv)); + GvCV_set(dsv, NULL); + GvCVGEN(dsv) = 0; /* Switch off cacheness. */ + } + } + /* SAVEt_GVSLOT takes more room on the savestack and has more + overhead in leave_scope than SAVEt_GENERIC_SV. But for CVs + leave_scope needs access to the GV so it can reset method + caches. We must use SAVEt_GVSLOT whenever the type is + SVt_PVCV, even if the stash is anonymous, as the stash may + gain a name somehow before leave_scope. */ + if (stype == SVt_PVCV) { + /* There is no save_pushptrptrptr. Creating it for this + one call site would be overkill. So inline the ss add + routines here. */ dSS_ADD; - SS_ADD_PTR(dsv); - SS_ADD_PTR(location); - SS_ADD_PTR(SvREFCNT_inc(*location)); - SS_ADD_UV(SAVEt_GVSLOT); - SS_ADD_END(4); - } - else SAVEGENERICSV(*location); - } - dref = *location; - if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dsv))) { - CV* const cv = MUTABLE_CV(*location); - if (cv) { - if (!GvCVGEN((const GV *)dsv) && - (CvROOT(cv) || CvXSUB(cv)) && - /* redundant check that avoids creating the extra SV - most of the time: */ - (CvCONST(cv) || ckWARN(WARN_REDEFINE))) - { - SV * const new_const_sv = - CvCONST((const CV *)sref) - ? cv_const_sv((const CV *)sref) - : NULL; + SS_ADD_PTR(dsv); + SS_ADD_PTR(location); + SS_ADD_PTR(SvREFCNT_inc(*location)); + SS_ADD_UV(SAVEt_GVSLOT); + SS_ADD_END(4); + } + else SAVEGENERICSV(*location); + } + dref = *location; + if (stype == SVt_PVCV && (*location != sref || GvCVGEN(dsv))) { + CV* const cv = MUTABLE_CV(*location); + if (cv) { + if (!GvCVGEN((const GV *)dsv) && + (CvROOT(cv) || CvXSUB(cv)) && + /* redundant check that avoids creating the extra SV + most of the time: */ + (CvCONST(cv) || ckWARN(WARN_REDEFINE))) + { + SV * const new_const_sv = + CvCONST((const CV *)sref) + ? cv_const_sv((const CV *)sref) + : NULL; HV * const stash = GvSTASH((const GV *)dsv); - report_redefined_cv( - sv_2mortal( + report_redefined_cv( + sv_2mortal( stash ? Perl_newSVpvf(aTHX_ - "%" HEKf "::%" HEKf, - HEKfARG(HvNAME_HEK(stash)), - HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv)))) + "%" HEKf "::%" HEKf, + HEKfARG(HvNAME_HEK(stash)), + HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv)))) : Perl_newSVpvf(aTHX_ - "%" HEKf, - HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv)))) - ), - cv, - CvCONST((const CV *)sref) ? &new_const_sv : NULL - ); - } - if (!intro) - cv_ckproto_len_flags(cv, (const GV *)dsv, - SvPOK(sref) ? CvPROTO(sref) : NULL, - SvPOK(sref) ? CvPROTOLEN(sref) : 0, + "%" HEKf, + HEKfARG(GvENAME_HEK(MUTABLE_GV(dsv)))) + ), + cv, + CvCONST((const CV *)sref) ? &new_const_sv : NULL + ); + } + if (!intro) + cv_ckproto_len_flags(cv, (const GV *)dsv, + SvPOK(sref) ? CvPROTO(sref) : NULL, + SvPOK(sref) ? CvPROTOLEN(sref) : 0, SvPOK(sref) ? SvUTF8(sref) : 0); - } - GvCVGEN(dsv) = 0; /* Switch off cacheness. */ - GvASSUMECV_on(dsv); - if(GvSTASH(dsv)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ - if (intro && GvREFCNT(dsv) > 1) { - /* temporary remove extra savestack's ref */ - --GvREFCNT(dsv); - gv_method_changed(dsv); - ++GvREFCNT(dsv); - } - else gv_method_changed(dsv); - } - } - *location = SvREFCNT_inc_simple_NN(sref); - if (import_flag && !(GvFLAGS(dsv) & import_flag) - && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) { - GvFLAGS(dsv) |= import_flag; - } - - if (stype == SVt_PVHV) { - const char * const name = GvNAME((GV*)dsv); - const STRLEN len = GvNAMELEN(dsv); - if ( - ( - (len > 1 && name[len-2] == ':' && name[len-1] == ':') - || (len == 1 && name[0] == ':') - ) - && (!dref || HvENAME_get(dref)) - ) { - mro_package_moved( - (HV *)sref, (HV *)dref, - (GV *)dsv, 0 - ); - } - } - else if ( - stype == SVt_PVAV && sref != dref - && memEQs(GvNAME((GV*)dsv), GvNAMELEN((GV*)dsv), "ISA") - /* The stash may have been detached from the symbol table, so - check its name before doing anything. */ - && GvSTASH(dsv) && HvENAME(GvSTASH(dsv)) - ) { - MAGIC *mg; - MAGIC * const omg = dref && SvSMAGICAL(dref) - ? mg_find(dref, PERL_MAGIC_isa) - : NULL; - if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { - if (SvTYPE(mg->mg_obj) != SVt_PVAV) { - AV * const ary = newAV(); - av_push(ary, mg->mg_obj); /* takes the refcount */ - mg->mg_obj = (SV *)ary; - } - if (omg) { - if (SvTYPE(omg->mg_obj) == SVt_PVAV) { - SV **svp = AvARRAY((AV *)omg->mg_obj); - I32 items = AvFILLp((AV *)omg->mg_obj) + 1; - while (items--) - av_push( - (AV *)mg->mg_obj, - SvREFCNT_inc_simple_NN(*svp++) - ); - } - else - av_push( - (AV *)mg->mg_obj, - SvREFCNT_inc_simple_NN(omg->mg_obj) - ); - } - else - av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dsv)); - } - else - { + } + GvCVGEN(dsv) = 0; /* Switch off cacheness. */ + GvASSUMECV_on(dsv); + if(GvSTASH(dsv)) { /* sub foo { 1 } sub bar { 2 } *bar = \&foo */ + if (intro && GvREFCNT(dsv) > 1) { + /* temporary remove extra savestack's ref */ + --GvREFCNT(dsv); + gv_method_changed(dsv); + ++GvREFCNT(dsv); + } + else gv_method_changed(dsv); + } + } + *location = SvREFCNT_inc_simple_NN(sref); + if (import_flag && !(GvFLAGS(dsv) & import_flag) + && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) { + GvFLAGS(dsv) |= import_flag; + } + + if (stype == SVt_PVHV) { + const char * const name = GvNAME((GV*)dsv); + const STRLEN len = GvNAMELEN(dsv); + if ( + ( + (len > 1 && name[len-2] == ':' && name[len-1] == ':') + || (len == 1 && name[0] == ':') + ) + && (!dref || HvENAME_get(dref)) + ) { + mro_package_moved( + (HV *)sref, (HV *)dref, + (GV *)dsv, 0 + ); + } + } + else if ( + stype == SVt_PVAV && sref != dref + && memEQs(GvNAME((GV*)dsv), GvNAMELEN((GV*)dsv), "ISA") + /* The stash may have been detached from the symbol table, so + check its name before doing anything. */ + && GvSTASH(dsv) && HvENAME(GvSTASH(dsv)) + ) { + MAGIC *mg; + MAGIC * const omg = dref && SvSMAGICAL(dref) + ? mg_find(dref, PERL_MAGIC_isa) + : NULL; + if (SvSMAGICAL(sref) && (mg = mg_find(sref, PERL_MAGIC_isa))) { + if (SvTYPE(mg->mg_obj) != SVt_PVAV) { + AV * const ary = newAV(); + av_push(ary, mg->mg_obj); /* takes the refcount */ + mg->mg_obj = (SV *)ary; + } + if (omg) { + if (SvTYPE(omg->mg_obj) == SVt_PVAV) { + SV **svp = AvARRAY((AV *)omg->mg_obj); + I32 items = AvFILLp((AV *)omg->mg_obj) + 1; + while (items--) + av_push( + (AV *)mg->mg_obj, + SvREFCNT_inc_simple_NN(*svp++) + ); + } + else + av_push( + (AV *)mg->mg_obj, + SvREFCNT_inc_simple_NN(omg->mg_obj) + ); + } + else + av_push((AV *)mg->mg_obj,SvREFCNT_inc_simple_NN(dsv)); + } + else + { SSize_t i; - sv_magic( - sref, omg ? omg->mg_obj : dsv, PERL_MAGIC_isa, NULL, 0 - ); + sv_magic( + sref, omg ? omg->mg_obj : dsv, PERL_MAGIC_isa, NULL, 0 + ); for (i = 0; i <= AvFILL(sref); ++i) { SV **elem = av_fetch ((AV*)sref, i, 0); if (elem) { @@ -4132,16 +4132,16 @@ Perl_gv_setref(pTHX_ SV *const dsv, SV *const ssv) ); } } - mg = mg_find(sref, PERL_MAGIC_isa); - } - /* Since the *ISA assignment could have affected more than - one stash, don't call mro_isa_changed_in directly, but let - magic_clearisa do it for us, as it already has the logic for - dealing with globs vs arrays of globs. */ - assert(mg); - Perl_magic_clearisa(aTHX_ NULL, mg); - } - else if (stype == SVt_PVIO) { + mg = mg_find(sref, PERL_MAGIC_isa); + } + /* Since the *ISA assignment could have affected more than + one stash, don't call mro_isa_changed_in directly, but let + magic_clearisa do it for us, as it already has the logic for + dealing with globs vs arrays of globs. */ + assert(mg); + Perl_magic_clearisa(aTHX_ NULL, mg); + } + else if (stype == SVt_PVIO) { DEBUG_o(Perl_deb(aTHX_ "gv_setref clearing PL_stashcache\n")); /* It's a cache. It will rebuild itself quite happily. It's a lot of effort to work out exactly which key (or keys) @@ -4149,11 +4149,11 @@ Perl_gv_setref(pTHX_ SV *const dsv, SV *const ssv) */ hv_clear(PL_stashcache); } - break; + break; } if (!intro) SvREFCNT_dec(dref); if (SvTAINTED(ssv)) - SvTAINT(dsv); + SvTAINT(dsv); return; } @@ -4171,27 +4171,27 @@ void Perl_sv_buf_to_ro(pTHX_ SV *sv) { struct perl_memory_debug_header * const header = - (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE); + (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE); const MEM_SIZE len = header->size; PERL_ARGS_ASSERT_SV_BUF_TO_RO; # ifdef PERL_TRACK_MEMPOOL if (!header->readonly) header->readonly = 1; # endif if (mprotect(header, len, PROT_READ)) - Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d", - header, len, errno); + Perl_warn(aTHX_ "mprotect RW for COW string %p %lu failed with %d", + header, len, errno); } static void S_sv_buf_to_rw(pTHX_ SV *sv) { struct perl_memory_debug_header * const header = - (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE); + (struct perl_memory_debug_header *)(SvPVX(sv)-PERL_MEMORY_DEBUG_HEADER_SIZE); const MEM_SIZE len = header->size; PERL_ARGS_ASSERT_SV_BUF_TO_RW; if (mprotect(header, len, PROT_READ|PROT_WRITE)) - Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d", - header, len, errno); + Perl_warn(aTHX_ "mprotect for COW string %p %lu failed with %d", + header, len, errno); # ifdef PERL_TRACK_MEMPOOL header->readonly = 0; # endif @@ -4213,10 +4213,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) PERL_ARGS_ASSERT_SV_SETSV_FLAGS; if (UNLIKELY( ssv == dsv )) - return; + return; if (UNLIKELY( !ssv )) - ssv = &PL_sv_undef; + ssv = &PL_sv_undef; stype = SvTYPE(ssv); dtype = SvTYPE(dsv); @@ -4297,126 +4297,126 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) switch (stype) { case SVt_NULL: undef_sstr: - if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) { - (void)SvOK_off(dsv); - return; - } - break; + if (LIKELY( dtype != SVt_PVGV && dtype != SVt_PVLV )) { + (void)SvOK_off(dsv); + return; + } + break; case SVt_IV: - if (SvIOK(ssv)) { - switch (dtype) { - case SVt_NULL: - /* For performance, we inline promoting to type SVt_IV. */ - /* We're starting from SVt_NULL, so provided that define is - * actual 0, we don't have to unset any SV type flags - * to promote to SVt_IV. */ - STATIC_ASSERT_STMT(SVt_NULL == 0); - SET_SVANY_FOR_BODYLESS_IV(dsv); - SvFLAGS(dsv) |= SVt_IV; - break; - case SVt_NV: - case SVt_PV: - sv_upgrade(dsv, SVt_PVIV); - break; - case SVt_PVGV: - case SVt_PVLV: - goto end_of_first_switch; - } - (void)SvIOK_only(dsv); - SvIV_set(dsv, SvIVX(ssv)); - if (SvIsUV(ssv)) - SvIsUV_on(dsv); - /* SvTAINTED can only be true if the SV has taint magic, which in - turn means that the SV type is PVMG (or greater). This is the - case statement for SVt_IV, so this cannot be true (whatever gcov - may say). */ - assert(!SvTAINTED(ssv)); - return; - } - if (!SvROK(ssv)) - goto undef_sstr; - if (dtype < SVt_PV && dtype != SVt_IV) - sv_upgrade(dsv, SVt_IV); - break; + if (SvIOK(ssv)) { + switch (dtype) { + case SVt_NULL: + /* For performance, we inline promoting to type SVt_IV. */ + /* We're starting from SVt_NULL, so provided that define is + * actual 0, we don't have to unset any SV type flags + * to promote to SVt_IV. */ + STATIC_ASSERT_STMT(SVt_NULL == 0); + SET_SVANY_FOR_BODYLESS_IV(dsv); + SvFLAGS(dsv) |= SVt_IV; + break; + case SVt_NV: + case SVt_PV: + sv_upgrade(dsv, SVt_PVIV); + break; + case SVt_PVGV: + case SVt_PVLV: + goto end_of_first_switch; + } + (void)SvIOK_only(dsv); + SvIV_set(dsv, SvIVX(ssv)); + if (SvIsUV(ssv)) + SvIsUV_on(dsv); + /* SvTAINTED can only be true if the SV has taint magic, which in + turn means that the SV type is PVMG (or greater). This is the + case statement for SVt_IV, so this cannot be true (whatever gcov + may say). */ + assert(!SvTAINTED(ssv)); + return; + } + if (!SvROK(ssv)) + goto undef_sstr; + if (dtype < SVt_PV && dtype != SVt_IV) + sv_upgrade(dsv, SVt_IV); + break; case SVt_NV: - if (LIKELY( SvNOK(ssv) )) { - switch (dtype) { - case SVt_NULL: - case SVt_IV: - sv_upgrade(dsv, SVt_NV); - break; - case SVt_PV: - case SVt_PVIV: - sv_upgrade(dsv, SVt_PVNV); - break; - case SVt_PVGV: - case SVt_PVLV: - goto end_of_first_switch; - } - SvNV_set(dsv, SvNVX(ssv)); - (void)SvNOK_only(dsv); - /* SvTAINTED can only be true if the SV has taint magic, which in - turn means that the SV type is PVMG (or greater). This is the - case statement for SVt_NV, so this cannot be true (whatever gcov - may say). */ - assert(!SvTAINTED(ssv)); - return; - } - goto undef_sstr; + if (LIKELY( SvNOK(ssv) )) { + switch (dtype) { + case SVt_NULL: + case SVt_IV: + sv_upgrade(dsv, SVt_NV); + break; + case SVt_PV: + case SVt_PVIV: + sv_upgrade(dsv, SVt_PVNV); + break; + case SVt_PVGV: + case SVt_PVLV: + goto end_of_first_switch; + } + SvNV_set(dsv, SvNVX(ssv)); + (void)SvNOK_only(dsv); + /* SvTAINTED can only be true if the SV has taint magic, which in + turn means that the SV type is PVMG (or greater). This is the + case statement for SVt_NV, so this cannot be true (whatever gcov + may say). */ + assert(!SvTAINTED(ssv)); + return; + } + goto undef_sstr; case SVt_PV: - if (dtype < SVt_PV) - sv_upgrade(dsv, SVt_PV); - break; + if (dtype < SVt_PV) + sv_upgrade(dsv, SVt_PV); + break; case SVt_PVIV: - if (dtype < SVt_PVIV) - sv_upgrade(dsv, SVt_PVIV); - break; + if (dtype < SVt_PVIV) + sv_upgrade(dsv, SVt_PVIV); + break; case SVt_PVNV: - if (dtype < SVt_PVNV) - sv_upgrade(dsv, SVt_PVNV); - break; + if (dtype < SVt_PVNV) + sv_upgrade(dsv, SVt_PVNV); + break; case SVt_INVLIST: invlist_clone(ssv, dsv); break; default: - { - const char * const type = sv_reftype(ssv,0); - if (PL_op) - /* diag_listed_as: Bizarre copy of %s */ - Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op)); - else - Perl_croak(aTHX_ "Bizarre copy of %s", type); - } - NOT_REACHED; /* NOTREACHED */ + { + const char * const type = sv_reftype(ssv,0); + if (PL_op) + /* diag_listed_as: Bizarre copy of %s */ + Perl_croak(aTHX_ "Bizarre copy of %s in %s", type, OP_DESC(PL_op)); + else + Perl_croak(aTHX_ "Bizarre copy of %s", type); + } + NOT_REACHED; /* NOTREACHED */ case SVt_REGEXP: upgregexp: - if (dtype < SVt_REGEXP) - sv_upgrade(dsv, SVt_REGEXP); - break; + if (dtype < SVt_REGEXP) + sv_upgrade(dsv, SVt_REGEXP); + break; case SVt_PVLV: case SVt_PVGV: case SVt_PVMG: - if (SvGMAGICAL(ssv) && (flags & SV_GMAGIC)) { - mg_get(ssv); - if (SvTYPE(ssv) != stype) - stype = SvTYPE(ssv); - } - if (isGV_with_GP(ssv) && dtype <= SVt_PVLV) { - glob_assign_glob(dsv, ssv, dtype); - return; - } - if (stype == SVt_PVLV) - { - if (isREGEXP(ssv)) goto upgregexp; - SvUPGRADE(dsv, SVt_PVNV); - } - else - SvUPGRADE(dsv, (svtype)stype); + if (SvGMAGICAL(ssv) && (flags & SV_GMAGIC)) { + mg_get(ssv); + if (SvTYPE(ssv) != stype) + stype = SvTYPE(ssv); + } + if (isGV_with_GP(ssv) && dtype <= SVt_PVLV) { + glob_assign_glob(dsv, ssv, dtype); + return; + } + if (stype == SVt_PVLV) + { + if (isREGEXP(ssv)) goto upgregexp; + SvUPGRADE(dsv, SVt_PVNV); + } + else + SvUPGRADE(dsv, (svtype)stype); } end_of_first_switch: @@ -4425,175 +4425,175 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) sflags = SvFLAGS(ssv); if (UNLIKELY( dtype == SVt_PVCV )) { - /* Assigning to a subroutine sets the prototype. */ - if (SvOK(ssv)) { - STRLEN len; - const char *const ptr = SvPV_const(ssv, len); + /* Assigning to a subroutine sets the prototype. */ + if (SvOK(ssv)) { + STRLEN len; + const char *const ptr = SvPV_const(ssv, len); SvGROW(dsv, len + 1); Copy(ptr, SvPVX(dsv), len + 1, char); SvCUR_set(dsv, len); - SvPOK_only(dsv); - SvFLAGS(dsv) |= sflags & SVf_UTF8; - CvAUTOLOAD_off(dsv); - } else { - SvOK_off(dsv); - } + SvPOK_only(dsv); + SvFLAGS(dsv) |= sflags & SVf_UTF8; + CvAUTOLOAD_off(dsv); + } else { + SvOK_off(dsv); + } } else if (UNLIKELY(dtype == SVt_PVAV || dtype == SVt_PVHV || dtype == SVt_PVFM)) { - const char * const type = sv_reftype(dsv,0); - if (PL_op) - /* diag_listed_as: Cannot copy to %s */ - Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op)); - else - Perl_croak(aTHX_ "Cannot copy to %s", type); + const char * const type = sv_reftype(dsv,0); + if (PL_op) + /* diag_listed_as: Cannot copy to %s */ + Perl_croak(aTHX_ "Cannot copy to %s in %s", type, OP_DESC(PL_op)); + else + Perl_croak(aTHX_ "Cannot copy to %s", type); } else if (sflags & SVf_ROK) { - if (isGV_with_GP(dsv) - && SvTYPE(SvRV(ssv)) == SVt_PVGV && isGV_with_GP(SvRV(ssv))) { - ssv = SvRV(ssv); - if (ssv == dsv) { - if (GvIMPORTED(dsv) != GVf_IMPORTED - && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) - { - GvIMPORTED_on(dsv); - } - GvMULTI_on(dsv); - return; - } - glob_assign_glob(dsv, ssv, dtype); - return; - } - - if (dtype >= SVt_PV) { - if (isGV_with_GP(dsv)) { - gv_setref(dsv, ssv); - return; - } - if (SvPVX_const(dsv)) { - SvPV_free(dsv); - SvLEN_set(dsv, 0); + if (isGV_with_GP(dsv) + && SvTYPE(SvRV(ssv)) == SVt_PVGV && isGV_with_GP(SvRV(ssv))) { + ssv = SvRV(ssv); + if (ssv == dsv) { + if (GvIMPORTED(dsv) != GVf_IMPORTED + && CopSTASH_ne(PL_curcop, GvSTASH(dsv))) + { + GvIMPORTED_on(dsv); + } + GvMULTI_on(dsv); + return; + } + glob_assign_glob(dsv, ssv, dtype); + return; + } + + if (dtype >= SVt_PV) { + if (isGV_with_GP(dsv)) { + gv_setref(dsv, ssv); + return; + } + if (SvPVX_const(dsv)) { + SvPV_free(dsv); + SvLEN_set(dsv, 0); SvCUR_set(dsv, 0); - } - } - (void)SvOK_off(dsv); - SvRV_set(dsv, SvREFCNT_inc(SvRV(ssv))); - SvFLAGS(dsv) |= sflags & SVf_ROK; - assert(!(sflags & SVp_NOK)); - assert(!(sflags & SVp_IOK)); - assert(!(sflags & SVf_NOK)); - assert(!(sflags & SVf_IOK)); + } + } + (void)SvOK_off(dsv); + SvRV_set(dsv, SvREFCNT_inc(SvRV(ssv))); + SvFLAGS(dsv) |= sflags & SVf_ROK; + assert(!(sflags & SVp_NOK)); + assert(!(sflags & SVp_IOK)); + assert(!(sflags & SVf_NOK)); + assert(!(sflags & SVf_IOK)); } else if (isGV_with_GP(dsv)) { - if (!(sflags & SVf_OK)) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), - "Undefined value assigned to typeglob"); - } - else { - GV *gv = gv_fetchsv_nomg(ssv, GV_ADD, SVt_PVGV); - if (dsv != (const SV *)gv) { - const char * const name = GvNAME((const GV *)dsv); - const STRLEN len = GvNAMELEN(dsv); - HV *old_stash = NULL; - bool reset_isa = FALSE; - if ((len > 1 && name[len-2] == ':' && name[len-1] == ':') - || (len == 1 && name[0] == ':')) { - /* Set aside the old stash, so we can reset isa caches - on its subclasses. */ - if((old_stash = GvHV(dsv))) { - /* Make sure we do not lose it early. */ - SvREFCNT_inc_simple_void_NN( - sv_2mortal((SV *)old_stash) - ); - } - reset_isa = TRUE; - } - - if (GvGP(dsv)) { - SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv)); - gp_free(MUTABLE_GV(dsv)); - } - GvGP_set(dsv, gp_ref(GvGP(gv))); - - if (reset_isa) { - HV * const stash = GvHV(dsv); - if( - old_stash ? (HV *)HvENAME_get(old_stash) : stash - ) - mro_package_moved( - stash, old_stash, - (GV *)dsv, 0 - ); - } - } - } + if (!(sflags & SVf_OK)) { + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), + "Undefined value assigned to typeglob"); + } + else { + GV *gv = gv_fetchsv_nomg(ssv, GV_ADD, SVt_PVGV); + if (dsv != (const SV *)gv) { + const char * const name = GvNAME((const GV *)dsv); + const STRLEN len = GvNAMELEN(dsv); + HV *old_stash = NULL; + bool reset_isa = FALSE; + if ((len > 1 && name[len-2] == ':' && name[len-1] == ':') + || (len == 1 && name[0] == ':')) { + /* Set aside the old stash, so we can reset isa caches + on its subclasses. */ + if((old_stash = GvHV(dsv))) { + /* Make sure we do not lose it early. */ + SvREFCNT_inc_simple_void_NN( + sv_2mortal((SV *)old_stash) + ); + } + reset_isa = TRUE; + } + + if (GvGP(dsv)) { + SvREFCNT_inc_simple_void_NN(sv_2mortal(dsv)); + gp_free(MUTABLE_GV(dsv)); + } + GvGP_set(dsv, gp_ref(GvGP(gv))); + + if (reset_isa) { + HV * const stash = GvHV(dsv); + if( + old_stash ? (HV *)HvENAME_get(old_stash) : stash + ) + mro_package_moved( + stash, old_stash, + (GV *)dsv, 0 + ); + } + } + } } else if ((dtype == SVt_REGEXP || dtype == SVt_PVLV) - && (stype == SVt_REGEXP || isREGEXP(ssv))) { - reg_temp_copy((REGEXP*)dsv, (REGEXP*)ssv); + && (stype == SVt_REGEXP || isREGEXP(ssv))) { + reg_temp_copy((REGEXP*)dsv, (REGEXP*)ssv); } else if (sflags & SVp_POK) { - const STRLEN cur = SvCUR(ssv); - const STRLEN len = SvLEN(ssv); - - /* - * We have three basic ways to copy the string: - * - * 1. Swipe - * 2. Copy-on-write - * 3. Actual copy - * - * Which we choose is based on various factors. The following - * things are listed in order of speed, fastest to slowest: - * - Swipe - * - Copying a short string - * - Copy-on-write bookkeeping - * - malloc - * - Copying a long string - * - * We swipe the string (steal the string buffer) if the SV on the - * rhs is about to be freed anyway (TEMP and refcnt==1). This is a - * big win on long strings. It should be a win on short strings if - * SvPVX_const(dsv) has to be allocated. If not, it should not - * slow things down, as SvPVX_const(ssv) would have been freed - * soon anyway. - * - * We also steal the buffer from a PADTMP (operator target) if it - * is ‘long enough’. For short strings, a swipe does not help - * here, as it causes more malloc calls the next time the target - * is used. Benchmarks show that even if SvPVX_const(dsv) has to - * be allocated it is still not worth swiping PADTMPs for short - * strings, as the savings here are small. - * + const STRLEN cur = SvCUR(ssv); + const STRLEN len = SvLEN(ssv); + + /* + * We have three basic ways to copy the string: + * + * 1. Swipe + * 2. Copy-on-write + * 3. Actual copy + * + * Which we choose is based on various factors. The following + * things are listed in order of speed, fastest to slowest: + * - Swipe + * - Copying a short string + * - Copy-on-write bookkeeping + * - malloc + * - Copying a long string + * + * We swipe the string (steal the string buffer) if the SV on the + * rhs is about to be freed anyway (TEMP and refcnt==1). This is a + * big win on long strings. It should be a win on short strings if + * SvPVX_const(dsv) has to be allocated. If not, it should not + * slow things down, as SvPVX_const(ssv) would have been freed + * soon anyway. + * + * We also steal the buffer from a PADTMP (operator target) if it + * is ‘long enough’. For short strings, a swipe does not help + * here, as it causes more malloc calls the next time the target + * is used. Benchmarks show that even if SvPVX_const(dsv) has to + * be allocated it is still not worth swiping PADTMPs for short + * strings, as the savings here are small. + * * If swiping is not an option, then we see whether it is worth using * copy-on-write. If the lhs already has a buffer big enough and the * string is short, we skip it and fall back to method 3, since memcpy * is faster for short strings than the later bookkeeping overhead that * copy-on-write entails. - * If the rhs is not a copy-on-write string yet, then we also - * consider whether the buffer is too large relative to the string - * it holds. Some operations such as readline allocate a large - * buffer in the expectation of reusing it. But turning such into - * a COW buffer is counter-productive because it increases memory - * usage by making readline allocate a new large buffer the sec- - * ond time round. So, if the buffer is too large, again, we use - * method 3 (copy). - * - * Finally, if there is no buffer on the left, or the buffer is too - * small, then we use copy-on-write and make both SVs share the - * string buffer. - * - */ - - /* Whichever path we take through the next code, we want this true, - and doing it now facilitates the COW check. */ - (void)SvPOK_only(dsv); - - if ( + * If the rhs is not a copy-on-write string yet, then we also + * consider whether the buffer is too large relative to the string + * it holds. Some operations such as readline allocate a large + * buffer in the expectation of reusing it. But turning such into + * a COW buffer is counter-productive because it increases memory + * usage by making readline allocate a new large buffer the sec- + * ond time round. So, if the buffer is too large, again, we use + * method 3 (copy). + * + * Finally, if there is no buffer on the left, or the buffer is too + * small, then we use copy-on-write and make both SVs share the + * string buffer. + * + */ + + /* Whichever path we take through the next code, we want this true, + and doing it now facilitates the COW check. */ + (void)SvPOK_only(dsv); + + if ( ( /* Either ... */ - /* slated for free anyway (and not COW)? */ + /* slated for free anyway (and not COW)? */ (sflags & (SVs_TEMP|SVf_IsCOW)) == SVs_TEMP /* or a swipable TARG */ || ((sflags & @@ -4604,41 +4604,41 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) ) ) && !(sflags & SVf_OOK) && /* and not involved in OOK hack? */ - (!(flags & SV_NOSTEAL)) && - /* and we're allowed to steal temps */ + (!(flags & SV_NOSTEAL)) && + /* and we're allowed to steal temps */ SvREFCNT(ssv) == 1 && /* and no other references to it? */ len) /* and really is a string */ - { /* Passes the swipe test. */ - if (SvPVX_const(dsv)) /* we know that dtype >= SVt_PV */ - SvPV_free(dsv); - SvPV_set(dsv, SvPVX_mutable(ssv)); - SvLEN_set(dsv, SvLEN(ssv)); - SvCUR_set(dsv, SvCUR(ssv)); - - SvTEMP_off(dsv); - (void)SvOK_off(ssv); /* NOTE: nukes most SvFLAGS on ssv */ - SvPV_set(ssv, NULL); - SvLEN_set(ssv, 0); - SvCUR_set(ssv, 0); - SvTEMP_off(ssv); - } - else if (flags & SV_COW_SHARED_HASH_KEYS - && + { /* Passes the swipe test. */ + if (SvPVX_const(dsv)) /* we know that dtype >= SVt_PV */ + SvPV_free(dsv); + SvPV_set(dsv, SvPVX_mutable(ssv)); + SvLEN_set(dsv, SvLEN(ssv)); + SvCUR_set(dsv, SvCUR(ssv)); + + SvTEMP_off(dsv); + (void)SvOK_off(ssv); /* NOTE: nukes most SvFLAGS on ssv */ + SvPV_set(ssv, NULL); + SvLEN_set(ssv, 0); + SvCUR_set(ssv, 0); + SvTEMP_off(ssv); + } + else if (flags & SV_COW_SHARED_HASH_KEYS + && #ifdef PERL_COPY_ON_WRITE - (sflags & SVf_IsCOW - ? (!len || + (sflags & SVf_IsCOW + ? (!len || ( (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1) - /* If this is a regular (non-hek) COW, only so - many COW "copies" are possible. */ - && CowREFCNT(ssv) != SV_COW_REFCNT_MAX )) - : ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS - && !(SvFLAGS(dsv) & SVf_BREAK) + /* If this is a regular (non-hek) COW, only so + many COW "copies" are possible. */ + && CowREFCNT(ssv) != SV_COW_REFCNT_MAX )) + : ( (sflags & CAN_COW_MASK) == CAN_COW_FLAGS + && !(SvFLAGS(dsv) & SVf_BREAK) && CHECK_COW_THRESHOLD(cur,len) && cur+1 < len && (CHECK_COWBUF_THRESHOLD(cur,len) || SvLEN(dsv) < cur+1) - )) + )) #else - sflags & SVf_IsCOW - && !(SvFLAGS(dsv) & SVf_BREAK) + sflags & SVf_IsCOW + && !(SvFLAGS(dsv) & SVf_BREAK) #endif ) { /* Either it's a shared hash key, or it's suitable for @@ -4653,19 +4653,19 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) #ifdef PERL_ANY_COW if (!(sflags & SVf_IsCOW)) { SvIsCOW_on(ssv); - CowREFCNT(ssv) = 0; + CowREFCNT(ssv) = 0; } #endif - if (SvPVX_const(dsv)) { /* we know that dtype >= SVt_PV */ - SvPV_free(dsv); - } + if (SvPVX_const(dsv)) { /* we know that dtype >= SVt_PV */ + SvPV_free(dsv); + } #ifdef PERL_ANY_COW - if (len) { - if (sflags & SVf_IsCOW) { - sv_buf_to_rw(ssv); - } - CowREFCNT(ssv)++; + if (len) { + if (sflags & SVf_IsCOW) { + sv_buf_to_rw(ssv); + } + CowREFCNT(ssv)++; SvPV_set(dsv, SvPVX_mutable(ssv)); sv_buf_to_ro(ssv); } else @@ -4675,59 +4675,59 @@ Perl_sv_setsv_flags(pTHX_ SV *dsv, SV* ssv, const I32 flags) DEBUG_C(PerlIO_printf(Perl_debug_log, "Copy on write: Sharing hash\n")); - assert (SvTYPE(dsv) >= SVt_PV); + assert (SvTYPE(dsv) >= SVt_PV); SvPV_set(dsv, - HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv))))); - } - SvLEN_set(dsv, len); - SvCUR_set(dsv, cur); - SvIsCOW_on(dsv); - } else { - /* Failed the swipe test, and we cannot do copy-on-write either. - Have to copy the string. */ - SvGROW(dsv, cur + 1); /* inlined from sv_setpvn */ - Move(SvPVX_const(ssv),SvPVX(dsv),cur,char); - SvCUR_set(dsv, cur); - *SvEND(dsv) = '\0'; - } - if (sflags & SVp_NOK) { - SvNV_set(dsv, SvNVX(ssv)); - } - if (sflags & SVp_IOK) { - SvIV_set(dsv, SvIVX(ssv)); - if (sflags & SVf_IVisUV) - SvIsUV_on(dsv); - } - SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8); - { - const MAGIC * const smg = SvVSTRING_mg(ssv); - if (smg) { - sv_magic(dsv, NULL, PERL_MAGIC_vstring, - smg->mg_ptr, smg->mg_len); - SvRMAGICAL_on(dsv); - } - } + HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv))))); + } + SvLEN_set(dsv, len); + SvCUR_set(dsv, cur); + SvIsCOW_on(dsv); + } else { + /* Failed the swipe test, and we cannot do copy-on-write either. + Have to copy the string. */ + SvGROW(dsv, cur + 1); /* inlined from sv_setpvn */ + Move(SvPVX_const(ssv),SvPVX(dsv),cur,char); + SvCUR_set(dsv, cur); + *SvEND(dsv) = '\0'; + } + if (sflags & SVp_NOK) { + SvNV_set(dsv, SvNVX(ssv)); + } + if (sflags & SVp_IOK) { + SvIV_set(dsv, SvIVX(ssv)); + if (sflags & SVf_IVisUV) + SvIsUV_on(dsv); + } + SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_NOK|SVp_NOK|SVf_UTF8); + { + const MAGIC * const smg = SvVSTRING_mg(ssv); + if (smg) { + sv_magic(dsv, NULL, PERL_MAGIC_vstring, + smg->mg_ptr, smg->mg_len); + SvRMAGICAL_on(dsv); + } + } } else if (sflags & (SVp_IOK|SVp_NOK)) { - (void)SvOK_off(dsv); - SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK); - if (sflags & SVp_IOK) { - /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ - SvIV_set(dsv, SvIVX(ssv)); - } - if (sflags & SVp_NOK) { - SvNV_set(dsv, SvNVX(ssv)); - } + (void)SvOK_off(dsv); + SvFLAGS(dsv) |= sflags & (SVf_IOK|SVp_IOK|SVf_IVisUV|SVf_NOK|SVp_NOK); + if (sflags & SVp_IOK) { + /* XXXX Do we want to set IsUV for IV(ROK)? Be extra safe... */ + SvIV_set(dsv, SvIVX(ssv)); + } + if (sflags & SVp_NOK) { + SvNV_set(dsv, SvNVX(ssv)); + } } else { - if (isGV_with_GP(ssv)) { - gv_efullname3(dsv, MUTABLE_GV(ssv), "*"); - } - else - (void)SvOK_off(dsv); + if (isGV_with_GP(ssv)) { + gv_efullname3(dsv, MUTABLE_GV(ssv), "*"); + } + else + (void)SvOK_off(dsv); } if (SvTAINTED(ssv)) - SvTAINT(dsv); + SvTAINT(dsv); } @@ -4815,21 +4815,21 @@ Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv) PERL_ARGS_ASSERT_SV_SETSV_COW; #ifdef DEBUGGING if (DEBUG_C_TEST) { - PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", - (void*)ssv, (void*)dsv); - sv_dump(ssv); - if (dsv) - sv_dump(dsv); + PerlIO_printf(Perl_debug_log, "Fast copy on write: %p -> %p\n", + (void*)ssv, (void*)dsv); + sv_dump(ssv); + if (dsv) + sv_dump(dsv); } #endif if (dsv) { - if (SvTHINKFIRST(dsv)) - sv_force_normal_flags(dsv, SV_COW_DROP_PV); - else if (SvPVX_const(dsv)) - Safefree(SvPVX_mutable(dsv)); + if (SvTHINKFIRST(dsv)) + sv_force_normal_flags(dsv, SV_COW_DROP_PV); + else if (SvPVX_const(dsv)) + Safefree(SvPVX_mutable(dsv)); } else - new_SV(dsv); + new_SV(dsv); SvUPGRADE(dsv, SVt_COW); assert (SvPOK(ssv)); @@ -4837,22 +4837,22 @@ Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv) if (SvIsCOW(ssv)) { - if (SvLEN(ssv) == 0) { - /* source is a COW shared hash key. */ - DEBUG_C(PerlIO_printf(Perl_debug_log, - "Fast copy on write: Sharing hash\n")); - new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)))); - goto common_exit; - } - assert(SvCUR(ssv)+1 < SvLEN(ssv)); - assert(CowREFCNT(ssv) < SV_COW_REFCNT_MAX); + if (SvLEN(ssv) == 0) { + /* source is a COW shared hash key. */ + DEBUG_C(PerlIO_printf(Perl_debug_log, + "Fast copy on write: Sharing hash\n")); + new_pv = HEK_KEY(share_hek_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)))); + goto common_exit; + } + assert(SvCUR(ssv)+1 < SvLEN(ssv)); + assert(CowREFCNT(ssv) < SV_COW_REFCNT_MAX); } else { - assert ((SvFLAGS(ssv) & CAN_COW_MASK) == CAN_COW_FLAGS); - SvUPGRADE(ssv, SVt_COW); - SvIsCOW_on(ssv); - DEBUG_C(PerlIO_printf(Perl_debug_log, - "Fast copy on write: Converting ssv to COW\n")); - CowREFCNT(ssv) = 0; + assert ((SvFLAGS(ssv) & CAN_COW_MASK) == CAN_COW_FLAGS); + SvUPGRADE(ssv, SVt_COW); + SvIsCOW_on(ssv); + DEBUG_C(PerlIO_printf(Perl_debug_log, + "Fast copy on write: Converting ssv to COW\n")); + CowREFCNT(ssv) = 0; } # ifdef PERL_DEBUG_READONLY_COW if (already) sv_buf_to_rw(ssv); @@ -4865,12 +4865,12 @@ Perl_sv_setsv_cow(pTHX_ SV *dsv, SV *ssv) SvPV_set(dsv, new_pv); SvFLAGS(dsv) = (SVt_COW|SVf_POK|SVp_POK|SVf_IsCOW); if (SvUTF8(ssv)) - SvUTF8_on(dsv); + SvUTF8_on(dsv); SvLEN_set(dsv, len); SvCUR_set(dsv, cur); #ifdef DEBUGGING if (DEBUG_C_TEST) - sv_dump(dsv); + sv_dump(dsv); #endif return dsv; } @@ -4933,17 +4933,17 @@ Perl_sv_setpvn(pTHX_ SV *const sv, const char *const ptr, const STRLEN len) SV_CHECK_THINKFIRST_COW_DROP(sv); if (isGV_with_GP(sv)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); if (!ptr) { - (void)SvOK_off(sv); - return; + (void)SvOK_off(sv); + return; } else { /* len is STRLEN which is unsigned, need to copy to signed */ - const IV iv = len; - if (iv < 0) - Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %" - IVdf, iv); + const IV iv = len; + if (iv < 0) + Perl_croak(aTHX_ "panic: sv_setpvn called with negative strlen %" + IVdf, iv); } SvUPGRADE(sv, SVt_PV); @@ -4988,8 +4988,8 @@ Perl_sv_setpv(pTHX_ SV *const sv, const char *const ptr) SV_CHECK_THINKFIRST_COW_DROP(sv); if (!ptr) { - (void)SvOK_off(sv); - return; + (void)SvOK_off(sv); + return; } len = strlen(ptr); SvUPGRADE(sv, SVt_PV); @@ -5017,41 +5017,41 @@ Perl_sv_sethek(pTHX_ SV *const sv, const HEK *const hek) PERL_ARGS_ASSERT_SV_SETHEK; if (!hek) { - return; + return; } if (HEK_LEN(hek) == HEf_SVKEY) { - sv_setsv(sv, *(SV**)HEK_KEY(hek)); + sv_setsv(sv, *(SV**)HEK_KEY(hek)); return; } else { - const int flags = HEK_FLAGS(hek); - if (flags & HVhek_WASUTF8) { - STRLEN utf8_len = HEK_LEN(hek); - char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len); - sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL); - SvUTF8_on(sv); + const int flags = HEK_FLAGS(hek); + if (flags & HVhek_WASUTF8) { + STRLEN utf8_len = HEK_LEN(hek); + char *as_utf8 = (char *)bytes_to_utf8((U8*)HEK_KEY(hek), &utf8_len); + sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL); + SvUTF8_on(sv); return; } else if (flags & HVhek_UNSHARED) { - sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek)); - if (HEK_UTF8(hek)) - SvUTF8_on(sv); - else SvUTF8_off(sv); + sv_setpvn(sv, HEK_KEY(hek), HEK_LEN(hek)); + if (HEK_UTF8(hek)) + SvUTF8_on(sv); + else SvUTF8_off(sv); return; - } + } { - SV_CHECK_THINKFIRST_COW_DROP(sv); - SvUPGRADE(sv, SVt_PV); - SvPV_free(sv); - SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek))); - SvCUR_set(sv, HEK_LEN(hek)); - SvLEN_set(sv, 0); - SvIsCOW_on(sv); - SvPOK_on(sv); - if (HEK_UTF8(hek)) - SvUTF8_on(sv); - else SvUTF8_off(sv); + SV_CHECK_THINKFIRST_COW_DROP(sv); + SvUPGRADE(sv, SVt_PV); + SvPV_free(sv); + SvPV_set(sv,(char *)HEK_KEY(share_hek_hek(hek))); + SvCUR_set(sv, HEK_LEN(hek)); + SvLEN_set(sv, 0); + SvIsCOW_on(sv); + SvPOK_on(sv); + if (HEK_UTF8(hek)) + SvUTF8_on(sv); + else SvUTF8_off(sv); return; - } + } } } @@ -5094,39 +5094,39 @@ Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 SV_CHECK_THINKFIRST_COW_DROP(sv); SvUPGRADE(sv, SVt_PV); if (!ptr) { - (void)SvOK_off(sv); - if (flags & SV_SMAGIC) - SvSETMAGIC(sv); - return; + (void)SvOK_off(sv); + if (flags & SV_SMAGIC) + SvSETMAGIC(sv); + return; } if (SvPVX_const(sv)) - SvPV_free(sv); + SvPV_free(sv); #ifdef DEBUGGING if (flags & SV_HAS_TRAILING_NUL) - assert(ptr[len] == '\0'); + assert(ptr[len] == '\0'); #endif allocate = (flags & SV_HAS_TRAILING_NUL) - ? len + 1 : + ? len + 1 : #ifdef Perl_safesysmalloc_size - len + 1; + len + 1; #else - PERL_STRLEN_ROUNDUP(len + 1); + PERL_STRLEN_ROUNDUP(len + 1); #endif if (flags & SV_HAS_TRAILING_NUL) { - /* It's long enough - do nothing. - Specifically Perl_newCONSTSUB is relying on this. */ + /* It's long enough - do nothing. + Specifically Perl_newCONSTSUB is relying on this. */ } else { #ifdef DEBUGGING - /* Force a move to shake out bugs in callers. */ - char *new_ptr = (char*)safemalloc(allocate); - Copy(ptr, new_ptr, len, char); - PoisonFree(ptr,len,char); - Safefree(ptr); - ptr = new_ptr; + /* Force a move to shake out bugs in callers. */ + char *new_ptr = (char*)safemalloc(allocate); + Copy(ptr, new_ptr, len, char); + PoisonFree(ptr,len,char); + Safefree(ptr); + ptr = new_ptr; #else - ptr = (char*) saferealloc (ptr, allocate); + ptr = (char*) saferealloc (ptr, allocate); #endif } #ifdef Perl_safesysmalloc_size @@ -5137,12 +5137,12 @@ Perl_sv_usepvn_flags(pTHX_ SV *const sv, char *ptr, const STRLEN len, const U32 SvCUR_set(sv, len); SvPV_set(sv, ptr); if (!(flags & SV_HAS_TRAILING_NUL)) { - ptr[len] = '\0'; + ptr[len] = '\0'; } (void)SvPOK_only_UTF8(sv); /* validate pointer */ SvTAINT(sv); if (flags & SV_SMAGIC) - SvSETMAGIC(sv); + SvSETMAGIC(sv); } @@ -5152,9 +5152,9 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags) assert(SvIsCOW(sv)); { #ifdef PERL_ANY_COW - const char * const pvx = SvPVX_const(sv); - const STRLEN len = SvLEN(sv); - const STRLEN cur = SvCUR(sv); + const char * const pvx = SvPVX_const(sv); + const STRLEN len = SvLEN(sv); + const STRLEN cur = SvCUR(sv); #ifdef DEBUGGING if (DEBUG_C_TEST) { @@ -5166,25 +5166,25 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags) #endif SvIsCOW_off(sv); # ifdef PERL_COPY_ON_WRITE - if (len) { - /* Must do this first, since the CowREFCNT uses SvPVX and - we need to write to CowREFCNT, or de-RO the whole buffer if we are - the only owner left of the buffer. */ - sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */ - { - U8 cowrefcnt = CowREFCNT(sv); - if(cowrefcnt != 0) { - cowrefcnt--; - CowREFCNT(sv) = cowrefcnt; - sv_buf_to_ro(sv); - goto copy_over; - } - } - /* Else we are the only owner of the buffer. */ - } - else + if (len) { + /* Must do this first, since the CowREFCNT uses SvPVX and + we need to write to CowREFCNT, or de-RO the whole buffer if we are + the only owner left of the buffer. */ + sv_buf_to_rw(sv); /* NOOP if RO-ing not supported */ + { + U8 cowrefcnt = CowREFCNT(sv); + if(cowrefcnt != 0) { + cowrefcnt--; + CowREFCNT(sv) = cowrefcnt; + sv_buf_to_ro(sv); + goto copy_over; + } + } + /* Else we are the only owner of the buffer. */ + } + else # endif - { + { /* This SV doesn't own the buffer, so need to Newx() a new one: */ copy_over: SvPV_set(sv, NULL); @@ -5199,29 +5199,29 @@ S_sv_uncow(pTHX_ SV * const sv, const U32 flags) SvCUR_set(sv, cur); *SvEND(sv) = '\0'; } - if (! len) { - unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); - } + if (! len) { + unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); + } #ifdef DEBUGGING if (DEBUG_C_TEST) sv_dump(sv); #endif - } + } #else - const char * const pvx = SvPVX_const(sv); - const STRLEN len = SvCUR(sv); - SvIsCOW_off(sv); - SvPV_set(sv, NULL); - SvLEN_set(sv, 0); - if (flags & SV_COW_DROP_PV) { - /* OK, so we don't need to copy our buffer. */ - SvPOK_off(sv); - } else { - SvGROW(sv, len + 1); - Move(pvx,SvPVX(sv),len,char); - *SvEND(sv) = '\0'; - } - unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); + const char * const pvx = SvPVX_const(sv); + const STRLEN len = SvCUR(sv); + SvIsCOW_off(sv); + SvPV_set(sv, NULL); + SvLEN_set(sv, 0); + if (flags & SV_COW_DROP_PV) { + /* OK, so we don't need to copy our buffer. */ + SvPOK_off(sv); + } else { + SvGROW(sv, len + 1); + Move(pvx,SvPVX(sv),len,char); + *SvEND(sv) = '\0'; + } + unshare_hek(SvSHARED_HEK_FROM_PV(pvx)); #endif } } @@ -5258,32 +5258,32 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) PERL_ARGS_ASSERT_SV_FORCE_NORMAL_FLAGS; if (SvREADONLY(sv)) - Perl_croak_no_modify(); + Perl_croak_no_modify(); else if (SvIsCOW(sv) && LIKELY(SvTYPE(sv) != SVt_PVHV)) - S_sv_uncow(aTHX_ sv, flags); + S_sv_uncow(aTHX_ sv, flags); if (SvROK(sv)) - sv_unref_flags(sv, flags); + sv_unref_flags(sv, flags); else if (SvFAKE(sv) && isGV_with_GP(sv)) - sv_unglob(sv, flags); + sv_unglob(sv, flags); else if (SvFAKE(sv) && isREGEXP(sv)) { - /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous - to sv_unglob. We only need it here, so inline it. */ - const bool islv = SvTYPE(sv) == SVt_PVLV; - const svtype new_type = - islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; - SV *const temp = newSV_type(new_type); - regexp *old_rx_body; - - if (new_type == SVt_PVMG) { - SvMAGIC_set(temp, SvMAGIC(sv)); - SvMAGIC_set(sv, NULL); - SvSTASH_set(temp, SvSTASH(sv)); - SvSTASH_set(sv, NULL); - } - if (!islv) + /* Need to downgrade the REGEXP to a simple(r) scalar. This is analogous + to sv_unglob. We only need it here, so inline it. */ + const bool islv = SvTYPE(sv) == SVt_PVLV; + const svtype new_type = + islv ? SVt_NULL : SvMAGIC(sv) || SvSTASH(sv) ? SVt_PVMG : SVt_PV; + SV *const temp = newSV_type(new_type); + regexp *old_rx_body; + + if (new_type == SVt_PVMG) { + SvMAGIC_set(temp, SvMAGIC(sv)); + SvMAGIC_set(sv, NULL); + SvSTASH_set(temp, SvSTASH(sv)); + SvSTASH_set(sv, NULL); + } + if (!islv) SvCUR_set(temp, SvCUR(sv)); - /* Remember that SvPVX is in the head, not the body. */ - assert(ReANY((REGEXP *)sv)->mother_re); + /* Remember that SvPVX is in the head, not the body. */ + assert(ReANY((REGEXP *)sv)->mother_re); if (islv) { /* LV-as-regex has sv->sv_any pointing to an XPVLV body, @@ -5295,34 +5295,34 @@ Perl_sv_force_normal_flags(pTHX_ SV *const sv, const U32 flags) else old_rx_body = ReANY((REGEXP *)sv); - /* Their buffer is already owned by someone else. */ - if (flags & SV_COW_DROP_PV) { - /* SvLEN is already 0. For SVt_REGEXP, we have a brand new - zeroed body. For SVt_PVLV, we zeroed it above (len field + /* Their buffer is already owned by someone else. */ + if (flags & SV_COW_DROP_PV) { + /* SvLEN is already 0. For SVt_REGEXP, we have a brand new + zeroed body. For SVt_PVLV, we zeroed it above (len field a union with xpvlenu_rx) */ - assert(!SvLEN(islv ? sv : temp)); - sv->sv_u.svu_pv = 0; - } - else { - sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv)); - SvLEN_set(islv ? sv : temp, SvCUR(sv)+1); - SvPOK_on(sv); - } - - /* Now swap the rest of the bodies. */ - - SvFAKE_off(sv); - if (!islv) { - SvFLAGS(sv) &= ~SVTYPEMASK; - SvFLAGS(sv) |= new_type; - SvANY(sv) = SvANY(temp); - } - - SvFLAGS(temp) &= ~(SVTYPEMASK); - SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE; - SvANY(temp) = old_rx_body; - - SvREFCNT_dec_NN(temp); + assert(!SvLEN(islv ? sv : temp)); + sv->sv_u.svu_pv = 0; + } + else { + sv->sv_u.svu_pv = savepvn(RX_WRAPPED((REGEXP *)sv), SvCUR(sv)); + SvLEN_set(islv ? sv : temp, SvCUR(sv)+1); + SvPOK_on(sv); + } + + /* Now swap the rest of the bodies. */ + + SvFAKE_off(sv); + if (!islv) { + SvFLAGS(sv) &= ~SVTYPEMASK; + SvFLAGS(sv) |= new_type; + SvANY(sv) = SvANY(temp); + } + + SvFLAGS(temp) &= ~(SVTYPEMASK); + SvFLAGS(temp) |= SVt_REGEXP|SVf_FAKE; + SvANY(temp) = old_rx_body; + + SvREFCNT_dec_NN(temp); } else if (SvVOK(sv)) sv_unmagic(sv, PERL_MAGIC_vstring); } @@ -5361,32 +5361,32 @@ Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr) PERL_ARGS_ASSERT_SV_CHOP; if (!ptr || !SvPOKp(sv)) - return; + return; delta = ptr - SvPVX_const(sv); if (!delta) { - /* Nothing to do. */ - return; + /* Nothing to do. */ + return; } max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv); if (delta > max_delta) - Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p", - ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta); + Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p", + ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta); /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), so don't use ptr any more */ SV_CHECK_THINKFIRST(sv); SvPOK_only_UTF8(sv); if (!SvOOK(sv)) { - if (!SvLEN(sv)) { /* make copy of shared string */ - const char *pvx = SvPVX_const(sv); - const STRLEN len = SvCUR(sv); - SvGROW(sv, len + 1); - Move(pvx,SvPVX(sv),len,char); - *SvEND(sv) = '\0'; - } - SvOOK_on(sv); - old_delta = 0; + if (!SvLEN(sv)) { /* make copy of shared string */ + const char *pvx = SvPVX_const(sv); + const STRLEN len = SvCUR(sv); + SvGROW(sv, len + 1); + Move(pvx,SvPVX(sv),len,char); + *SvEND(sv) = '\0'; + } + SvOOK_on(sv); + old_delta = 0; } else { - SvOOK_offset(sv, old_delta); + SvOOK_offset(sv, old_delta); } SvLEN_set(sv, SvLEN(sv) - delta); SvCUR_set(sv, SvCUR(sv) - delta); @@ -5399,7 +5399,7 @@ Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr) bytes, except for the part holding the new offset of course. */ evacn = delta; if (old_delta) - evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN)); + evacn += (old_delta < 0x100 ? 1 : 1 + sizeof(STRLEN)); assert(evacn); assert(evacn <= delta + old_delta); evacp = p - evacn; @@ -5414,19 +5414,19 @@ Perl_sv_chop(pTHX_ SV *const sv, const char *const ptr) * to that, using as many bytes as a STRLEN occupies. Thus it overwrites a * portion of the chopped part of the string */ if (delta < 0x100) { - *--p = (U8) delta; + *--p = (U8) delta; } else { - *--p = 0; - p -= sizeof(STRLEN); - Copy((U8*)&delta, p, sizeof(STRLEN), U8); + *--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 > evacp) { - --p; - *p = (U8)PTR2UV(p); + --p; + *p = (U8)PTR2UV(p); } #endif } @@ -5479,39 +5479,39 @@ Perl_sv_catpvn_flags(pTHX_ SV *const dsv, const char *sstr, const STRLEN slen, c if (!(flags & SV_CATBYTES) || !SvUTF8(dsv)) { if (flags & SV_CATUTF8 && !SvUTF8(dsv)) { - sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1); - dlen = SvCUR(dsv); + sv_utf8_upgrade_flags_grow(dsv, 0, slen + 1); + dlen = SvCUR(dsv); } else SvGROW(dsv, dlen + slen + 3); if (sstr == dstr) - sstr = SvPVX_const(dsv); + sstr = SvPVX_const(dsv); Move(sstr, SvPVX(dsv) + dlen, slen, char); SvCUR_set(dsv, SvCUR(dsv) + slen); } else { - /* We inline bytes_to_utf8, to avoid an extra malloc. */ - const char * const send = sstr + slen; - U8 *d; + /* We inline bytes_to_utf8, to avoid an extra malloc. */ + const char * const send = sstr + slen; + U8 *d; - /* Something this code does not account for, which I think is - impossible; it would require the same pv to be treated as - bytes *and* utf8, which would indicate a bug elsewhere. */ - assert(sstr != dstr); + /* Something this code does not account for, which I think is + impossible; it would require the same pv to be treated as + bytes *and* utf8, which would indicate a bug elsewhere. */ + assert(sstr != dstr); - SvGROW(dsv, dlen + slen * 2 + 3); - d = (U8 *)SvPVX(dsv) + dlen; + SvGROW(dsv, dlen + slen * 2 + 3); + d = (U8 *)SvPVX(dsv) + dlen; - while (sstr < send) { + while (sstr < send) { append_utf8_from_native_byte(*sstr, &d); - sstr++; - } - SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv)); + sstr++; + } + SvCUR_set(dsv, d-(const U8 *)SvPVX(dsv)); } *SvEND(dsv) = '\0'; (void)SvPOK_only_UTF8(dsv); /* validate pointer */ SvTAINT(dsv); if (flags & SV_SMAGIC) - SvSETMAGIC(dsv); + SvSETMAGIC(dsv); } /* @@ -5548,12 +5548,12 @@ Perl_sv_catsv_flags(pTHX_ SV *const dsv, SV *const sstr, const I32 flags) PERL_ARGS_ASSERT_SV_CATSV_FLAGS; if (sstr) { - STRLEN slen; - const char *spv = SvPV_flags_const(sstr, slen, flags); + STRLEN slen; + const char *spv = SvPV_flags_const(sstr, slen, flags); if (flags & SV_GMAGIC) SvGETMAGIC(dsv); sv_catpvn_flags(dsv, spv, slen, - DO_UTF8(sstr) ? SV_CATUTF8 : SV_CATBYTES); + DO_UTF8(sstr) ? SV_CATUTF8 : SV_CATBYTES); if (flags & SV_SMAGIC) SvSETMAGIC(dsv); } @@ -5598,12 +5598,12 @@ Perl_sv_catpv(pTHX_ SV *const dsv, const char *sstr) PERL_ARGS_ASSERT_SV_CATPV; if (!sstr) - return; + return; junk = SvPV_force(dsv, tlen); len = strlen(sstr); SvGROW(dsv, tlen + len + 1); if (sstr == junk) - sstr = SvPVX_const(dsv); + sstr = SvPVX_const(dsv); Move(sstr,SvPVX(dsv)+tlen,len+1,char); SvCUR_set(dsv, SvCUR(dsv) + len); (void)SvPOK_only_UTF8(dsv); /* validate pointer */ @@ -5650,7 +5650,7 @@ Perl_newSV(pTHX_ const STRLEN len) new_SV(sv); if (len) { - sv_grow(sv, len + 1); + sv_grow(sv, len + 1); } return sv; } @@ -5696,20 +5696,20 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, */ if (!obj || obj == sv || - how == PERL_MAGIC_arylen || + how == PERL_MAGIC_arylen || how == PERL_MAGIC_regdata || how == PERL_MAGIC_regdatum || how == PERL_MAGIC_symtab || - (SvTYPE(obj) == SVt_PVGV && - (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))) + (SvTYPE(obj) == SVt_PVGV && + (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; + mg->mg_obj = obj; } else { - mg->mg_obj = SvREFCNT_inc_simple(obj); - mg->mg_flags |= MGf_REFCOUNTED; + mg->mg_obj = SvREFCNT_inc_simple(obj); + mg->mg_flags |= MGf_REFCOUNTED; } /* Normal self-ties simply pass a null object, and instead of @@ -5729,16 +5729,16 @@ Perl_sv_magicext(pTHX_ SV *const sv, SV *const obj, const int how, mg->mg_type = how; mg->mg_len = namlen; if (name) { - if (namlen > 0) - mg->mg_ptr = savepvn(name, namlen); - 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 aberation 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; + if (namlen > 0) + mg->mg_ptr = savepvn(name, namlen); + 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 aberation 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; @@ -5751,13 +5751,13 @@ Perl_sv_magicext_mglob(pTHX_ SV *sv) { PERL_ARGS_ASSERT_SV_MAGICEXT_MGLOB; if (SvTYPE(sv) == SVt_PVLV && LvTYPE(sv) == 'y') { - /* This sv is only a delegate. //g magic must be attached to - its target. */ - vivify_defelem(sv); - sv = LvTARG(sv); + /* This sv is only a delegate. //g magic must be attached to + its target. */ + vivify_defelem(sv); + sv = LvTARG(sv); } return sv_magicext(sv, NULL, PERL_MAGIC_regex_global, - &PL_vtbl_mglob, 0, 0); + &PL_vtbl_mglob, 0, 0); } /* @@ -5788,10 +5788,10 @@ Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, PERL_ARGS_ASSERT_SV_MAGIC; if (how < 0 || (unsigned)how >= C_ARRAY_LENGTH(PL_magic_data) - || ((flags = PL_magic_data[how]), - (vtable_index = flags & PERL_MAGIC_VTABLE_MASK) - > magic_vtable_max)) - Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); + || ((flags = PL_magic_data[how]), + (vtable_index = flags & PERL_MAGIC_VTABLE_MASK) + > magic_vtable_max)) + Perl_croak(aTHX_ "Don't know how to handle magic of type \\%o", how); /* PERL_MAGIC_ext is reserved for use by extensions not perl internals. Useful for attaching extension internal data to perl vars. @@ -5799,25 +5799,25 @@ Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, etc holding private data from one are passed to another. */ vtable = (vtable_index == magic_vtable_max) - ? NULL : PL_magic_vtables + vtable_index; + ? NULL : PL_magic_vtables + vtable_index; if (SvREADONLY(sv)) { - if ( - !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how) - ) - { - Perl_croak_no_modify(); - } + if ( + !PERL_MAGIC_TYPE_READONLY_ACCEPTABLE(how) + ) + { + Perl_croak_no_modify(); + } } if (SvMAGICAL(sv) || (how == PERL_MAGIC_taint && SvTYPE(sv) >= SVt_PVMG)) { - if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { - /* sv_magic() refuses to add a magic of the same 'how' as an - existing one - */ - if (how == PERL_MAGIC_taint) - mg->mg_len |= 1; - return; - } + if (SvMAGIC(sv) && (mg = mg_find(sv, how))) { + /* sv_magic() refuses to add a magic of the same 'how' as an + existing one + */ + if (how == PERL_MAGIC_taint) + mg->mg_len |= 1; + return; + } } /* Force pos to be stored as characters, not bytes. */ @@ -5825,9 +5825,9 @@ Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, && (mg = mg_find(sv, PERL_MAGIC_regex_global)) && mg->mg_len != -1 && mg->mg_flags & MGf_BYTES) { - mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len, - SV_CONST_RETURN); - mg->mg_flags &= ~MGf_BYTES; + mg->mg_len = (SSize_t)sv_pos_b2u_flags(sv, (STRLEN)mg->mg_len, + SV_CONST_RETURN); + mg->mg_flags &= ~MGf_BYTES; } /* Rest of work is done else where */ @@ -5835,12 +5835,12 @@ Perl_sv_magic(pTHX_ SV *const sv, SV *const obj, const int how, switch (how) { case PERL_MAGIC_taint: - mg->mg_len = 1; - break; + mg->mg_len = 1; + break; case PERL_MAGIC_ext: case PERL_MAGIC_dbfile: - SvRMAGICAL_on(sv); - break; + SvRMAGICAL_on(sv); + break; } } @@ -5853,35 +5853,35 @@ S_sv_unmagicext_flags(pTHX_ SV *const sv, const int type, MGVTBL *vtbl, const U3 assert(flags <= 1); if (SvTYPE(sv) < SVt_PVMG || !SvMAGIC(sv)) - return 0; + return 0; mgp = &(((XPVMG*) SvANY(sv))->xmg_u.xmg_magic); for (mg = *mgp; mg; mg = *mgp) { - const MGVTBL* const virt = mg->mg_virtual; - if (mg->mg_type == type && (!flags || virt == vtbl)) { - *mgp = mg->mg_moremagic; - if (virt && virt->svt_free) - virt->svt_free(aTHX_ sv, mg); - if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { - if (mg->mg_len > 0) - Safefree(mg->mg_ptr); - else if (mg->mg_len == HEf_SVKEY) - SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); - else if (mg->mg_type == PERL_MAGIC_utf8) - Safefree(mg->mg_ptr); + const MGVTBL* const virt = mg->mg_virtual; + if (mg->mg_type == type && (!flags || virt == vtbl)) { + *mgp = mg->mg_moremagic; + if (virt && virt->svt_free) + virt->svt_free(aTHX_ sv, mg); + if (mg->mg_ptr && mg->mg_type != PERL_MAGIC_regex_global) { + if (mg->mg_len > 0) + Safefree(mg->mg_ptr); + else if (mg->mg_len == HEf_SVKEY) + SvREFCNT_dec(MUTABLE_SV(mg->mg_ptr)); + else if (mg->mg_type == PERL_MAGIC_utf8) + Safefree(mg->mg_ptr); } - if (mg->mg_flags & MGf_REFCOUNTED) - SvREFCNT_dec(mg->mg_obj); - Safefree(mg); - } - else - mgp = &mg->mg_moremagic; + if (mg->mg_flags & MGf_REFCOUNTED) + SvREFCNT_dec(mg->mg_obj); + Safefree(mg); + } + else + mgp = &mg->mg_moremagic; } if (SvMAGIC(sv)) { - if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ - mg_magical(sv); /* else fix the flags now */ + if (SvMAGICAL(sv)) /* if we're under save_magic, wait for restore_magic; */ + mg_magical(sv); /* else fix the flags now */ } else - SvMAGICAL_off(sv); + SvMAGICAL_off(sv); return 0; } @@ -5937,12 +5937,12 @@ Perl_sv_rvweaken(pTHX_ SV *const sv) PERL_ARGS_ASSERT_SV_RVWEAKEN; if (!SvOK(sv)) /* let undefs pass */ - return sv; + return sv; if (!SvROK(sv)) - Perl_croak(aTHX_ "Can't weaken a nonreference"); + Perl_croak(aTHX_ "Can't weaken a nonreference"); else if (SvWEAKREF(sv)) { - Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak"); - return sv; + Perl_ck_warner(aTHX_ packWARN(WARN_MISC), "Reference is already weak"); + return sv; } else if (SvREADONLY(sv)) croak_no_modify(); tsv = SvRV(sv); @@ -6066,36 +6066,36 @@ Perl_sv_add_backref(pTHX_ SV *const tsv, SV *const sv) /* find slot to store array or singleton backref */ if (SvTYPE(tsv) == SVt_PVHV) { - svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); + svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); } else { if (SvMAGICAL(tsv)) mg = mg_find(tsv, PERL_MAGIC_backref); - if (!mg) + if (!mg) mg = sv_magicext(tsv, NULL, PERL_MAGIC_backref, &PL_vtbl_backref, NULL, 0); - svp = &(mg->mg_obj); + svp = &(mg->mg_obj); } /* create or retrieve the array */ if ( (!*svp && SvTYPE(sv) == SVt_PVAV) - || (*svp && SvTYPE(*svp) != SVt_PVAV) + || (*svp && SvTYPE(*svp) != SVt_PVAV) ) { - /* create array */ - if (mg) - mg->mg_flags |= MGf_REFCOUNTED; - av = newAV(); - AvREAL_off(av); - SvREFCNT_inc_simple_void_NN(av); - /* av now has a refcnt of 2; see discussion above */ - av_extend(av, *svp ? 2 : 1); - if (*svp) { - /* move single existing backref to the array */ - AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */ - } - *svp = (SV*)av; + /* create array */ + if (mg) + mg->mg_flags |= MGf_REFCOUNTED; + av = newAV(); + AvREAL_off(av); + SvREFCNT_inc_simple_void_NN(av); + /* av now has a refcnt of 2; see discussion above */ + av_extend(av, *svp ? 2 : 1); + if (*svp) { + /* move single existing backref to the array */ + AvARRAY(av)[++AvFILLp(av)] = *svp; /* av_push() */ + } + *svp = (SV*)av; } else { - av = MUTABLE_AV(*svp); + av = MUTABLE_AV(*svp); if (!av) { /* optimisation: store single backref directly in HvAUX or mg_obj */ *svp = sv; @@ -6122,111 +6122,111 @@ Perl_sv_del_backref(pTHX_ SV *const tsv, SV *const sv) PERL_ARGS_ASSERT_SV_DEL_BACKREF; if (SvTYPE(tsv) == SVt_PVHV) { - if (SvOOK(tsv)) - svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); + if (SvOOK(tsv)) + svp = (SV**)Perl_hv_backreferences_p(aTHX_ MUTABLE_HV(tsv)); } else if (SvIS_FREED(tsv) && PL_phase == PERL_PHASE_DESTRUCT) { - /* It's possible for the the last (strong) reference to tsv to have - become freed *before* the last thing holding a weak reference. - If both survive longer than the backreferences array, then when - the referent's reference count drops to 0 and it is freed, it's - not able to chase the backreferences, so they aren't NULLed. - - For example, a CV holds a weak reference to its stash. If both the - CV and the stash survive longer than the backreferences array, - and the CV gets picked for the SvBREAK() treatment first, - *and* it turns out that the stash is only being kept alive because - of an our variable in the pad of the CV, then midway during CV - destruction the stash gets freed, but CvSTASH() isn't set to NULL. - It ends up pointing to the freed HV. Hence it's chased in here, and - if this block wasn't here, it would hit the !svp panic just below. - - I don't believe that "better" destruction ordering is going to help - here - during global destruction there's always going to be the - chance that something goes out of order. We've tried to make it - foolproof before, and it only resulted in evolutionary pressure on - fools. Which made us look foolish for our hubris. :-( - */ - return; + /* It's possible for the the last (strong) reference to tsv to have + become freed *before* the last thing holding a weak reference. + If both survive longer than the backreferences array, then when + the referent's reference count drops to 0 and it is freed, it's + not able to chase the backreferences, so they aren't NULLed. + + For example, a CV holds a weak reference to its stash. If both the + CV and the stash survive longer than the backreferences array, + and the CV gets picked for the SvBREAK() treatment first, + *and* it turns out that the stash is only being kept alive because + of an our variable in the pad of the CV, then midway during CV + destruction the stash gets freed, but CvSTASH() isn't set to NULL. + It ends up pointing to the freed HV. Hence it's chased in here, and + if this block wasn't here, it would hit the !svp panic just below. + + I don't believe that "better" destruction ordering is going to help + here - during global destruction there's always going to be the + chance that something goes out of order. We've tried to make it + foolproof before, and it only resulted in evolutionary pressure on + fools. Which made us look foolish for our hubris. :-( + */ + return; } else { - MAGIC *const mg - = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; - svp = mg ? &(mg->mg_obj) : NULL; + MAGIC *const mg + = SvMAGICAL(tsv) ? mg_find(tsv, PERL_MAGIC_backref) : NULL; + svp = mg ? &(mg->mg_obj) : NULL; } if (!svp) - Perl_croak(aTHX_ "panic: del_backref, svp=0"); + Perl_croak(aTHX_ "panic: del_backref, svp=0"); if (!*svp) { - /* It's possible that sv is being freed recursively part way through the - freeing of tsv. If this happens, the backreferences array of tsv has - already been freed, and so svp will be NULL. If this is the case, - we should not panic. Instead, nothing needs doing, so return. */ - if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0) - return; - Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf, - (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv)); + /* It's possible that sv is being freed recursively part way through the + freeing of tsv. If this happens, the backreferences array of tsv has + already been freed, and so svp will be NULL. If this is the case, + we should not panic. Instead, nothing needs doing, so return. */ + if (PL_phase == PERL_PHASE_DESTRUCT && SvREFCNT(tsv) == 0) + return; + Perl_croak(aTHX_ "panic: del_backref, *svp=%p phase=%s refcnt=%" UVuf, + (void*)*svp, PL_phase_names[PL_phase], (UV)SvREFCNT(tsv)); } if (SvTYPE(*svp) == SVt_PVAV) { #ifdef DEBUGGING - int count = 1; + int count = 1; #endif - AV * const av = (AV*)*svp; - SSize_t fill; - assert(!SvIS_FREED(av)); - fill = AvFILLp(av); - assert(fill > -1); - svp = AvARRAY(av); - /* for an SV with N weak references to it, if all those - * weak refs are deleted, then sv_del_backref will be called - * N times and O(N^2) compares will be done within the backref - * array. To ameliorate this potential slowness, we: - * 1) make sure this code is as tight as possible; - * 2) when looking for SV, look for it at both the head and tail of the - * array first before searching the rest, since some create/destroy - * patterns will cause the backrefs to be freed in order. - */ - if (*svp == sv) { - AvARRAY(av)++; - AvMAX(av)--; - } - else { - SV **p = &svp[fill]; - SV *const topsv = *p; - if (topsv != sv) { + AV * const av = (AV*)*svp; + SSize_t fill; + assert(!SvIS_FREED(av)); + fill = AvFILLp(av); + assert(fill > -1); + svp = AvARRAY(av); + /* for an SV with N weak references to it, if all those + * weak refs are deleted, then sv_del_backref will be called + * N times and O(N^2) compares will be done within the backref + * array. To ameliorate this potential slowness, we: + * 1) make sure this code is as tight as possible; + * 2) when looking for SV, look for it at both the head and tail of the + * array first before searching the rest, since some create/destroy + * patterns will cause the backrefs to be freed in order. + */ + if (*svp == sv) { + AvARRAY(av)++; + AvMAX(av)--; + } + else { + SV **p = &svp[fill]; + SV *const topsv = *p; + if (topsv != sv) { #ifdef DEBUGGING - count = 0; + count = 0; #endif - while (--p > svp) { - if (*p == sv) { - /* We weren't the last entry. - An unordered list has this property that you - can take the last element off the end to fill - the hole, and it's still an unordered list :-) - */ - *p = topsv; + while (--p > svp) { + if (*p == sv) { + /* We weren't the last entry. + An unordered list has this property that you + can take the last element off the end to fill + the hole, and it's still an unordered list :-) + */ + *p = topsv; #ifdef DEBUGGING - count++; + count++; #else - break; /* should only be one */ + break; /* should only be one */ #endif - } - } - } - } - assert(count ==1); - AvFILLp(av) = fill-1; + } + } + } + } + assert(count ==1); + AvFILLp(av) = fill-1; } else if (SvIS_FREED(*svp) && PL_phase == PERL_PHASE_DESTRUCT) { - /* freed AV; skip */ + /* freed AV; skip */ } else { - /* optimisation: only a single backref, stored directly */ - if (*svp != sv) - Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", + /* optimisation: only a single backref, stored directly */ + if (*svp != sv) + Perl_croak(aTHX_ "panic: del_backref, *svp=%p, sv=%p", (void*)*svp, (void*)sv); - *svp = NULL; + *svp = NULL; } } @@ -6241,82 +6241,82 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) PERL_ARGS_ASSERT_SV_KILL_BACKREFS; if (!av) - return; + return; /* after multiple passes through Perl_sv_clean_all() for a thingy * that has badly leaked, the backref array may have gotten freed, * since we only protect it against 1 round of cleanup */ if (SvIS_FREED(av)) { - if (PL_in_clean_all) /* All is fair */ - return; - Perl_croak(aTHX_ - "panic: magic_killbackrefs (freed backref AV/SV)"); + if (PL_in_clean_all) /* All is fair */ + return; + Perl_croak(aTHX_ + "panic: magic_killbackrefs (freed backref AV/SV)"); } is_array = (SvTYPE(av) == SVt_PVAV); if (is_array) { - assert(!SvIS_FREED(av)); - svp = AvARRAY(av); - if (svp) - last = svp + AvFILLp(av); + assert(!SvIS_FREED(av)); + svp = AvARRAY(av); + if (svp) + last = svp + AvFILLp(av); } else { - /* optimisation: only a single backref, stored directly */ - svp = (SV**)&av; - last = svp; + /* optimisation: only a single backref, stored directly */ + svp = (SV**)&av; + last = svp; } if (svp) { - while (svp <= last) { - if (*svp) { - SV *const referrer = *svp; - if (SvWEAKREF(referrer)) { - /* XXX Should we check that it hasn't changed? */ - assert(SvROK(referrer)); - SvRV_set(referrer, 0); - SvOK_off(referrer); - SvWEAKREF_off(referrer); - SvSETMAGIC(referrer); - } else if (SvTYPE(referrer) == SVt_PVGV || - SvTYPE(referrer) == SVt_PVLV) { - assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */ - /* You lookin' at me? */ - assert(GvSTASH(referrer)); - assert(GvSTASH(referrer) == (const HV *)sv); - GvSTASH(referrer) = 0; - } else if (SvTYPE(referrer) == SVt_PVCV || - SvTYPE(referrer) == SVt_PVFM) { - if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */ - /* You lookin' at me? */ - assert(CvSTASH(referrer)); - assert(CvSTASH(referrer) == (const HV *)sv); - SvANY(MUTABLE_CV(referrer))->xcv_stash = 0; - } - else { - assert(SvTYPE(sv) == SVt_PVGV); - /* You lookin' at me? */ - assert(CvGV(referrer)); - assert(CvGV(referrer) == (const GV *)sv); - anonymise_cv_maybe(MUTABLE_GV(sv), - MUTABLE_CV(referrer)); - } - - } else { - Perl_croak(aTHX_ - "panic: magic_killbackrefs (flags=%" UVxf ")", - (UV)SvFLAGS(referrer)); - } - - if (is_array) - *svp = NULL; - } - svp++; - } + while (svp <= last) { + if (*svp) { + SV *const referrer = *svp; + if (SvWEAKREF(referrer)) { + /* XXX Should we check that it hasn't changed? */ + assert(SvROK(referrer)); + SvRV_set(referrer, 0); + SvOK_off(referrer); + SvWEAKREF_off(referrer); + SvSETMAGIC(referrer); + } else if (SvTYPE(referrer) == SVt_PVGV || + SvTYPE(referrer) == SVt_PVLV) { + assert(SvTYPE(sv) == SVt_PVHV); /* stash backref */ + /* You lookin' at me? */ + assert(GvSTASH(referrer)); + assert(GvSTASH(referrer) == (const HV *)sv); + GvSTASH(referrer) = 0; + } else if (SvTYPE(referrer) == SVt_PVCV || + SvTYPE(referrer) == SVt_PVFM) { + if (SvTYPE(sv) == SVt_PVHV) { /* stash backref */ + /* You lookin' at me? */ + assert(CvSTASH(referrer)); + assert(CvSTASH(referrer) == (const HV *)sv); + SvANY(MUTABLE_CV(referrer))->xcv_stash = 0; + } + else { + assert(SvTYPE(sv) == SVt_PVGV); + /* You lookin' at me? */ + assert(CvGV(referrer)); + assert(CvGV(referrer) == (const GV *)sv); + anonymise_cv_maybe(MUTABLE_GV(sv), + MUTABLE_CV(referrer)); + } + + } else { + Perl_croak(aTHX_ + "panic: magic_killbackrefs (flags=%" UVxf ")", + (UV)SvFLAGS(referrer)); + } + + if (is_array) + *svp = NULL; + } + svp++; + } } if (is_array) { - AvFILLp(av) = -1; - SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */ + AvFILLp(av) = -1; + SvREFCNT_dec_NN(av); /* remove extra count added by sv_add_backref() */ } return; } @@ -6362,30 +6362,30 @@ Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN l } if (offset + len > curlen) { - SvGROW(bigstr, offset+len+1); - Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); - SvCUR_set(bigstr, offset+len); + SvGROW(bigstr, offset+len+1); + Zero(SvPVX(bigstr)+curlen, offset+len-curlen, char); + SvCUR_set(bigstr, offset+len); } SvTAINT(bigstr); i = littlelen - len; if (i > 0) { /* string might grow */ - big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); - mid = big + offset + len; - midend = bigend = big + SvCUR(bigstr); - bigend += i; - *bigend = '\0'; - while (midend > mid) /* shove everything down */ - *--bigend = *--midend; - Move(little,big+offset,littlelen,char); - SvCUR_set(bigstr, SvCUR(bigstr) + i); - SvSETMAGIC(bigstr); - return; + big = SvGROW(bigstr, SvCUR(bigstr) + i + 1); + mid = big + offset + len; + midend = bigend = big + SvCUR(bigstr); + bigend += i; + *bigend = '\0'; + while (midend > mid) /* shove everything down */ + *--bigend = *--midend; + Move(little,big+offset,littlelen,char); + SvCUR_set(bigstr, SvCUR(bigstr) + i); + SvSETMAGIC(bigstr); + return; } else if (i == 0) { - Move(little,SvPVX(bigstr)+offset,len,char); - SvSETMAGIC(bigstr); - return; + Move(little,SvPVX(bigstr)+offset,len,char); + SvSETMAGIC(bigstr); + return; } big = SvPVX(bigstr); @@ -6394,37 +6394,37 @@ Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN l bigend = big + SvCUR(bigstr); if (midend > bigend) - Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p", - midend, bigend); + Perl_croak(aTHX_ "panic: sv_insert, midend=%p, bigend=%p", + midend, bigend); if (mid - big > bigend - midend) { /* faster to shorten from end */ - if (littlelen) { - Move(little, mid, littlelen,char); - mid += littlelen; - } - i = bigend - midend; - if (i > 0) { - Move(midend, mid, i,char); - mid += i; - } - *mid = '\0'; - SvCUR_set(bigstr, mid - big); + if (littlelen) { + Move(little, mid, littlelen,char); + mid += littlelen; + } + i = bigend - midend; + if (i > 0) { + Move(midend, mid, i,char); + mid += i; + } + *mid = '\0'; + SvCUR_set(bigstr, mid - big); } else if ((i = mid - big)) { /* faster from front */ - midend -= littlelen; - mid = midend; - Move(big, midend - i, i, char); - sv_chop(bigstr,midend-i); - if (littlelen) - Move(little, mid, littlelen,char); + midend -= littlelen; + mid = midend; + Move(big, midend - i, i, char); + sv_chop(bigstr,midend-i); + if (littlelen) + Move(little, mid, littlelen,char); } else if (littlelen) { - midend -= littlelen; - sv_chop(bigstr,midend); - Move(little,midend,littlelen,char); + midend -= littlelen; + sv_chop(bigstr,midend); + Move(little,midend,littlelen,char); } else { - sv_chop(bigstr,midend); + sv_chop(bigstr,midend); } SvSETMAGIC(bigstr); } @@ -6451,18 +6451,18 @@ Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv) SV_CHECK_THINKFIRST_COW_DROP(sv); if (SvREFCNT(nsv) != 1) { - Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()" - " (%" UVuf " != 1)", (UV) SvREFCNT(nsv)); + Perl_croak(aTHX_ "panic: reference miscount on nsv in sv_replace()" + " (%" UVuf " != 1)", (UV) SvREFCNT(nsv)); } if (SvMAGICAL(sv)) { - if (SvMAGICAL(nsv)) - mg_free(nsv); - else - sv_upgrade(nsv, SVt_PVMG); - SvMAGIC_set(nsv, SvMAGIC(sv)); - SvFLAGS(nsv) |= SvMAGICAL(sv); - SvMAGICAL_off(sv); - SvMAGIC_set(sv, NULL); + if (SvMAGICAL(nsv)) + mg_free(nsv); + else + sv_upgrade(nsv, SVt_PVMG); + SvMAGIC_set(nsv, SvMAGIC(sv)); + SvFLAGS(nsv) |= SvMAGICAL(sv); + SvMAGICAL_off(sv); + SvMAGIC_set(sv, NULL); } SvREFCNT(sv) = 0; sv_clear(sv); @@ -6476,7 +6476,7 @@ Perl_sv_replace(pTHX_ SV *const sv, SV *const nsv) StructCopy(nsv,sv,SV); #endif if(SvTYPE(sv) == SVt_IV) { - SET_SVANY_FOR_BODYLESS_IV(sv); + SET_SVANY_FOR_BODYLESS_IV(sv); } @@ -6508,8 +6508,8 @@ S_anonymise_cv_maybe(pTHX_ GV *gv, CV* cv) /* will the CV shortly be freed by gp_free() ? */ if (GvCV(gv) == cv && GvGP(gv)->gp_refcnt < 2 && SvREFCNT(cv) < 2) { - SvANY(cv)->xcv_gv_u.xcv_gv = NULL; - return; + SvANY(cv)->xcv_gv_u.xcv_gv = NULL; + return; } /* if not, anonymise: */ @@ -6560,146 +6560,146 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) while (sv) { - type = SvTYPE(sv); - - assert(SvREFCNT(sv) == 0); - assert(SvTYPE(sv) != (svtype)SVTYPEMASK); - - if (type <= SVt_IV) { - /* See the comment in sv.h about the collusion between this - * early return and the overloading of the NULL slots in the - * size table. */ - if (SvROK(sv)) - goto free_rv; - SvFLAGS(sv) &= SVf_BREAK; - SvFLAGS(sv) |= SVTYPEMASK; - goto free_head; - } - - /* objs are always >= MG, but pad names use the SVs_OBJECT flag - for another purpose */ - assert(!SvOBJECT(sv) || type >= SVt_PVMG); - - if (type >= SVt_PVMG) { - if (SvOBJECT(sv)) { - if (!curse(sv, 1)) goto get_next_sv; - type = SvTYPE(sv); /* destructor may have changed it */ - } - /* Free back-references before magic, in case the magic calls - * Perl code that has weak references to sv. */ - if (type == SVt_PVHV) { - Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); - if (SvMAGIC(sv)) - mg_free(sv); - } - else if (SvMAGIC(sv)) { - /* Free back-references before other types of magic. */ - sv_unmagic(sv, PERL_MAGIC_backref); - mg_free(sv); - } - SvMAGICAL_off(sv); - } - switch (type) { - /* case SVt_INVLIST: */ - case SVt_PVIO: - if (IoIFP(sv) && - IoIFP(sv) != PerlIO_stdin() && - IoIFP(sv) != PerlIO_stdout() && - IoIFP(sv) != PerlIO_stderr() && - !(IoFLAGS(sv) & IOf_FAKE_DIRP)) - { - io_close(MUTABLE_IO(sv), NULL, FALSE, - (IoTYPE(sv) == IoTYPE_WRONLY || - IoTYPE(sv) == IoTYPE_RDWR || - IoTYPE(sv) == IoTYPE_APPEND)); - } - if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) - PerlDir_close(IoDIRP(sv)); - IoDIRP(sv) = (DIR*)NULL; - Safefree(IoTOP_NAME(sv)); - Safefree(IoFMT_NAME(sv)); - Safefree(IoBOTTOM_NAME(sv)); - if ((const GV *)sv == PL_statgv) - PL_statgv = NULL; - goto freescalar; - case SVt_REGEXP: - /* FIXME for plugins */ - pregfree2((REGEXP*) sv); - goto freescalar; - case SVt_PVCV: - case SVt_PVFM: - cv_undef(MUTABLE_CV(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 ((stash = CvSTASH(sv))) - sv_del_backref(MUTABLE_SV(stash), sv); - goto freescalar; - case SVt_PVHV: - if (HvTOTALKEYS((HV*)sv) > 0) { - const HEK *hek; - /* this statement should match the one at the beginning of - * hv_undef_flags() */ - if ( PL_phase != PERL_PHASE_DESTRUCT - && (hek = HvNAME_HEK((HV*)sv))) - { - if (PL_stashcache) { - DEBUG_o(Perl_deb(aTHX_ - "sv_clear clearing PL_stashcache for '%" HEKf - "'\n", - HEKfARG(hek))); - (void)hv_deletehek(PL_stashcache, + type = SvTYPE(sv); + + assert(SvREFCNT(sv) == 0); + assert(SvTYPE(sv) != (svtype)SVTYPEMASK); + + if (type <= SVt_IV) { + /* See the comment in sv.h about the collusion between this + * early return and the overloading of the NULL slots in the + * size table. */ + if (SvROK(sv)) + goto free_rv; + SvFLAGS(sv) &= SVf_BREAK; + SvFLAGS(sv) |= SVTYPEMASK; + goto free_head; + } + + /* objs are always >= MG, but pad names use the SVs_OBJECT flag + for another purpose */ + assert(!SvOBJECT(sv) || type >= SVt_PVMG); + + if (type >= SVt_PVMG) { + if (SvOBJECT(sv)) { + if (!curse(sv, 1)) goto get_next_sv; + type = SvTYPE(sv); /* destructor may have changed it */ + } + /* Free back-references before magic, in case the magic calls + * Perl code that has weak references to sv. */ + if (type == SVt_PVHV) { + Perl_hv_kill_backrefs(aTHX_ MUTABLE_HV(sv)); + if (SvMAGIC(sv)) + mg_free(sv); + } + else if (SvMAGIC(sv)) { + /* Free back-references before other types of magic. */ + sv_unmagic(sv, PERL_MAGIC_backref); + mg_free(sv); + } + SvMAGICAL_off(sv); + } + switch (type) { + /* case SVt_INVLIST: */ + case SVt_PVIO: + if (IoIFP(sv) && + IoIFP(sv) != PerlIO_stdin() && + IoIFP(sv) != PerlIO_stdout() && + IoIFP(sv) != PerlIO_stderr() && + !(IoFLAGS(sv) & IOf_FAKE_DIRP)) + { + io_close(MUTABLE_IO(sv), NULL, FALSE, + (IoTYPE(sv) == IoTYPE_WRONLY || + IoTYPE(sv) == IoTYPE_RDWR || + IoTYPE(sv) == IoTYPE_APPEND)); + } + if (IoDIRP(sv) && !(IoFLAGS(sv) & IOf_FAKE_DIRP)) + PerlDir_close(IoDIRP(sv)); + IoDIRP(sv) = (DIR*)NULL; + Safefree(IoTOP_NAME(sv)); + Safefree(IoFMT_NAME(sv)); + Safefree(IoBOTTOM_NAME(sv)); + if ((const GV *)sv == PL_statgv) + PL_statgv = NULL; + goto freescalar; + case SVt_REGEXP: + /* FIXME for plugins */ + pregfree2((REGEXP*) sv); + goto freescalar; + case SVt_PVCV: + case SVt_PVFM: + cv_undef(MUTABLE_CV(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 ((stash = CvSTASH(sv))) + sv_del_backref(MUTABLE_SV(stash), sv); + goto freescalar; + case SVt_PVHV: + if (HvTOTALKEYS((HV*)sv) > 0) { + const HEK *hek; + /* this statement should match the one at the beginning of + * hv_undef_flags() */ + if ( PL_phase != PERL_PHASE_DESTRUCT + && (hek = HvNAME_HEK((HV*)sv))) + { + if (PL_stashcache) { + DEBUG_o(Perl_deb(aTHX_ + "sv_clear clearing PL_stashcache for '%" HEKf + "'\n", + HEKfARG(hek))); + (void)hv_deletehek(PL_stashcache, hek, G_DISCARD); } - hv_name_set((HV*)sv, NULL, 0, 0); - } - - /* save old iter_sv in unused SvSTASH field */ - assert(!SvOBJECT(sv)); - SvSTASH(sv) = (HV*)iter_sv; - iter_sv = sv; - - /* save old hash_index in unused SvMAGIC field */ - assert(!SvMAGICAL(sv)); - assert(!SvMAGIC(sv)); - ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index; - hash_index = 0; - - next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index); - goto get_next_sv; /* process this new sv */ - } - /* free empty hash */ - Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); - assert(!HvARRAY((HV*)sv)); - break; - case SVt_PVAV: - { - AV* av = MUTABLE_AV(sv); - if (PL_comppad == av) { - PL_comppad = NULL; - PL_curpad = NULL; - } - if (AvREAL(av) && AvFILLp(av) > -1) { - next_sv = AvARRAY(av)[AvFILLp(av)--]; - /* save old iter_sv in top-most slot of AV, - * and pray that it doesn't get wiped in the meantime */ - AvARRAY(av)[AvMAX(av)] = iter_sv; - iter_sv = sv; - goto get_next_sv; /* process this new sv */ - } - Safefree(AvALLOC(av)); - } - - break; - case SVt_PVLV: - if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ - SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv))); - HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh; - PL_hv_fetch_ent_mh = (HE*)LvTARG(sv); - } - else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ - SvREFCNT_dec(LvTARG(sv)); - if (isREGEXP(sv)) { + hv_name_set((HV*)sv, NULL, 0, 0); + } + + /* save old iter_sv in unused SvSTASH field */ + assert(!SvOBJECT(sv)); + SvSTASH(sv) = (HV*)iter_sv; + iter_sv = sv; + + /* save old hash_index in unused SvMAGIC field */ + assert(!SvMAGICAL(sv)); + assert(!SvMAGIC(sv)); + ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index = hash_index; + hash_index = 0; + + next_sv = Perl_hfree_next_entry(aTHX_ (HV*)sv, &hash_index); + goto get_next_sv; /* process this new sv */ + } + /* free empty hash */ + Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); + assert(!HvARRAY((HV*)sv)); + break; + case SVt_PVAV: + { + AV* av = MUTABLE_AV(sv); + if (PL_comppad == av) { + PL_comppad = NULL; + PL_curpad = NULL; + } + if (AvREAL(av) && AvFILLp(av) > -1) { + next_sv = AvARRAY(av)[AvFILLp(av)--]; + /* save old iter_sv in top-most slot of AV, + * and pray that it doesn't get wiped in the meantime */ + AvARRAY(av)[AvMAX(av)] = iter_sv; + iter_sv = sv; + goto get_next_sv; /* process this new sv */ + } + Safefree(AvALLOC(av)); + } + + break; + case SVt_PVLV: + if (LvTYPE(sv) == 'T') { /* for tie: return HE to pool */ + SvREFCNT_dec(HeKEY_sv((HE*)LvTARG(sv))); + HeNEXT((HE*)LvTARG(sv)) = PL_hv_fetch_ent_mh; + PL_hv_fetch_ent_mh = (HE*)LvTARG(sv); + } + else if (LvTYPE(sv) != 't') /* unless tie: unrefcnted fake SV** */ + SvREFCNT_dec(LvTARG(sv)); + if (isREGEXP(sv)) { /* SvLEN points to a regex body. Free the body, then * set SvLEN to whatever value was in the now-freed * regex body. The PVX buffer is shared by multiple re's @@ -6710,188 +6710,188 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) goto freescalar; } /* FALLTHROUGH */ - case SVt_PVGV: - if (isGV_with_GP(sv)) { - if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) - && HvENAME_get(stash)) - mro_method_changed_in(stash); - 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 ((stash = GvSTASH(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: */ - /* See also S_sv_unglob, which does the same thing. */ - if ((const GV *)sv == PL_last_in_gv) - PL_last_in_gv = NULL; - else if ((const GV *)sv == PL_statgv) - PL_statgv = NULL; + case SVt_PVGV: + if (isGV_with_GP(sv)) { + if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) + && HvENAME_get(stash)) + mro_method_changed_in(stash); + 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 ((stash = GvSTASH(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: */ + /* See also S_sv_unglob, which does the same thing. */ + if ((const GV *)sv == PL_last_in_gv) + PL_last_in_gv = NULL; + else if ((const GV *)sv == PL_statgv) + PL_statgv = NULL; else if ((const GV *)sv == PL_stderrgv) PL_stderrgv = NULL; /* FALLTHROUGH */ - case SVt_PVMG: - case SVt_PVNV: - case SVt_PVIV: - case SVt_INVLIST: - case SVt_PV: - freescalar: - /* Don't bother with SvOOK_off(sv); as we're only going to - * free it. */ - if (SvOOK(sv)) { - STRLEN offset; - SvOOK_offset(sv, offset); - SvPV_set(sv, SvPVX_mutable(sv) - offset); - /* Don't even bother with turning off the OOK flag. */ - } - if (SvROK(sv)) { - free_rv: - { - SV * const target = SvRV(sv); - if (SvWEAKREF(sv)) - sv_del_backref(target, sv); - else - next_sv = target; - } - } + case SVt_PVMG: + case SVt_PVNV: + case SVt_PVIV: + case SVt_INVLIST: + case SVt_PV: + freescalar: + /* Don't bother with SvOOK_off(sv); as we're only going to + * free it. */ + if (SvOOK(sv)) { + STRLEN offset; + SvOOK_offset(sv, offset); + SvPV_set(sv, SvPVX_mutable(sv) - offset); + /* Don't even bother with turning off the OOK flag. */ + } + if (SvROK(sv)) { + free_rv: + { + SV * const target = SvRV(sv); + if (SvWEAKREF(sv)) + sv_del_backref(target, sv); + else + next_sv = target; + } + } #ifdef PERL_ANY_COW - else if (SvPVX_const(sv) - && !(SvTYPE(sv) == SVt_PVIO - && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) - { - if (SvIsCOW(sv)) { + else if (SvPVX_const(sv) + && !(SvTYPE(sv) == SVt_PVIO + && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) + { + if (SvIsCOW(sv)) { #ifdef DEBUGGING - if (DEBUG_C_TEST) { - PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); - sv_dump(sv); - } + if (DEBUG_C_TEST) { + PerlIO_printf(Perl_debug_log, "Copy on write: clear\n"); + sv_dump(sv); + } #endif - if (SvLEN(sv)) { - if (CowREFCNT(sv)) { - sv_buf_to_rw(sv); - CowREFCNT(sv)--; - sv_buf_to_ro(sv); - SvLEN_set(sv, 0); - } - } else { - unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); - } - - } - if (SvLEN(sv)) { - Safefree(SvPVX_mutable(sv)); - } - } + if (SvLEN(sv)) { + if (CowREFCNT(sv)) { + sv_buf_to_rw(sv); + CowREFCNT(sv)--; + sv_buf_to_ro(sv); + SvLEN_set(sv, 0); + } + } else { + unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); + } + + } + if (SvLEN(sv)) { + Safefree(SvPVX_mutable(sv)); + } + } #else - else if (SvPVX_const(sv) && SvLEN(sv) - && !(SvTYPE(sv) == SVt_PVIO - && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) - Safefree(SvPVX_mutable(sv)); - else if (SvPVX_const(sv) && SvIsCOW(sv)) { - unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); - } + else if (SvPVX_const(sv) && SvLEN(sv) + && !(SvTYPE(sv) == SVt_PVIO + && !(IoFLAGS(sv) & IOf_FAKE_DIRP))) + Safefree(SvPVX_mutable(sv)); + else if (SvPVX_const(sv) && SvIsCOW(sv)) { + unshare_hek(SvSHARED_HEK_FROM_PV(SvPVX_const(sv))); + } #endif - break; - case SVt_NV: - break; - } + break; + case SVt_NV: + break; + } free_body: - SvFLAGS(sv) &= SVf_BREAK; - SvFLAGS(sv) |= SVTYPEMASK; + SvFLAGS(sv) &= SVf_BREAK; + SvFLAGS(sv) |= SVTYPEMASK; - sv_type_details = bodies_by_type + type; - if (sv_type_details->arena) { - del_body(((char *)SvANY(sv) + sv_type_details->offset), - &PL_body_roots[type]); - } - else if (sv_type_details->body_size) { - safefree(SvANY(sv)); - } + sv_type_details = bodies_by_type + type; + if (sv_type_details->arena) { + del_body(((char *)SvANY(sv) + sv_type_details->offset), + &PL_body_roots[type]); + } + else if (sv_type_details->body_size) { + safefree(SvANY(sv)); + } free_head: - /* caller is responsible for freeing the head of the original sv */ - if (sv != orig_sv && !SvREFCNT(sv)) - del_SV(sv); + /* caller is responsible for freeing the head of the original sv */ + if (sv != orig_sv && !SvREFCNT(sv)) + del_SV(sv); - /* grab and free next sv, if any */ + /* grab and free next sv, if any */ get_next_sv: - while (1) { - sv = NULL; - if (next_sv) { - sv = next_sv; - next_sv = NULL; - } - else if (!iter_sv) { - break; - } else if (SvTYPE(iter_sv) == SVt_PVAV) { - AV *const av = (AV*)iter_sv; - if (AvFILLp(av) > -1) { - sv = AvARRAY(av)[AvFILLp(av)--]; - } - else { /* no more elements of current AV to free */ - sv = iter_sv; - type = SvTYPE(sv); - /* restore previous value, squirrelled away */ - iter_sv = AvARRAY(av)[AvMAX(av)]; - Safefree(AvALLOC(av)); - goto free_body; - } - } else if (SvTYPE(iter_sv) == SVt_PVHV) { - sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index); - if (!sv && !HvTOTALKEYS((HV *)iter_sv)) { - /* no more elements of current HV to free */ - sv = iter_sv; - type = SvTYPE(sv); - /* Restore previous values of iter_sv and hash_index, - * squirrelled away */ - assert(!SvOBJECT(sv)); - iter_sv = (SV*)SvSTASH(sv); - assert(!SvMAGICAL(sv)); - hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index; + while (1) { + sv = NULL; + if (next_sv) { + sv = next_sv; + next_sv = NULL; + } + else if (!iter_sv) { + break; + } else if (SvTYPE(iter_sv) == SVt_PVAV) { + AV *const av = (AV*)iter_sv; + if (AvFILLp(av) > -1) { + sv = AvARRAY(av)[AvFILLp(av)--]; + } + else { /* no more elements of current AV to free */ + sv = iter_sv; + type = SvTYPE(sv); + /* restore previous value, squirrelled away */ + iter_sv = AvARRAY(av)[AvMAX(av)]; + Safefree(AvALLOC(av)); + goto free_body; + } + } else if (SvTYPE(iter_sv) == SVt_PVHV) { + sv = Perl_hfree_next_entry(aTHX_ (HV*)iter_sv, &hash_index); + if (!sv && !HvTOTALKEYS((HV *)iter_sv)) { + /* no more elements of current HV to free */ + sv = iter_sv; + type = SvTYPE(sv); + /* Restore previous values of iter_sv and hash_index, + * squirrelled away */ + assert(!SvOBJECT(sv)); + iter_sv = (SV*)SvSTASH(sv); + assert(!SvMAGICAL(sv)); + hash_index = ((XPVMG*) SvANY(sv))->xmg_u.xmg_hash_index; #ifdef DEBUGGING - /* perl -DA does not like rubbish in SvMAGIC. */ - SvMAGIC_set(sv, 0); + /* perl -DA does not like rubbish in SvMAGIC. */ + SvMAGIC_set(sv, 0); #endif - /* free any remaining detritus from the hash struct */ - Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); - assert(!HvARRAY((HV*)sv)); - goto free_body; - } - } - - /* unrolled SvREFCNT_dec and sv_free2 follows: */ - - if (!sv) - continue; - if (!SvREFCNT(sv)) { - sv_free(sv); - continue; - } - if (--(SvREFCNT(sv))) - continue; + /* free any remaining detritus from the hash struct */ + Perl_hv_undef_flags(aTHX_ MUTABLE_HV(sv), HV_NAME_SETALL); + assert(!HvARRAY((HV*)sv)); + goto free_body; + } + } + + /* unrolled SvREFCNT_dec and sv_free2 follows: */ + + if (!sv) + continue; + if (!SvREFCNT(sv)) { + sv_free(sv); + continue; + } + if (--(SvREFCNT(sv))) + continue; #ifdef DEBUGGING - if (SvTEMP(sv)) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), - "Attempt to free temp prematurely: SV 0x%" UVxf - pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); - continue; - } + if (SvTEMP(sv)) { + Perl_ck_warner_d(aTHX_ packWARN(WARN_DEBUGGING), + "Attempt to free temp prematurely: SV 0x%" UVxf + pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE); + continue; + } #endif - if (SvIMMORTAL(sv)) { - /* make sure SvREFCNT(sv)==0 happens very seldom */ - SvREFCNT(sv) = SvREFCNT_IMMORTAL; - continue; - } - break; - } /* while 1 */ + if (SvIMMORTAL(sv)) { + /* make sure SvREFCNT(sv)==0 happens very seldom */ + SvREFCNT(sv) = SvREFCNT_IMMORTAL; + continue; + } + break; + } /* while 1 */ } /* while sv */ } @@ -6905,18 +6905,18 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) { assert(SvOBJECT(sv)); if (PL_defstash && /* Still have a symbol table? */ - SvDESTROYABLE(sv)) + SvDESTROYABLE(sv)) { - dSP; - HV* stash; - do { - stash = SvSTASH(sv); - assert(SvTYPE(stash) == SVt_PVHV); - if (HvNAME(stash)) { - CV* destructor = NULL; + dSP; + HV* stash; + do { + stash = SvSTASH(sv); + assert(SvTYPE(stash) == SVt_PVHV); + if (HvNAME(stash)) { + CV* destructor = NULL; struct mro_meta *meta; - assert (SvOOK(stash)); + assert (SvOOK(stash)); DEBUG_o( Perl_deb(aTHX_ "Looking for DESTROY method for %s\n", HvNAME(stash)) ); @@ -6931,9 +6931,9 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) { } else { bool autoload = FALSE; - GV *gv = + GV *gv = gv_fetchmeth_pvn(stash, S_destroy, S_destroy_len, -1, 0); - if (gv) + if (gv) destructor = GvCV(gv); if (!destructor) { gv = gv_autoload_pvn(stash, S_destroy, S_destroy_len, @@ -6957,68 +6957,68 @@ S_curse(pTHX_ SV * const sv, const bool check_refcnt) { DEBUG_o( Perl_deb(aTHX_ "Not caching AUTOLOAD for DESTROY method for %s\n", HvNAME(stash)) ); } - } - assert(!destructor || SvTYPE(destructor) == SVt_PVCV); - if (destructor - /* A constant subroutine can have no side effects, so - don't bother calling it. */ - && !CvCONST(destructor) - /* Don't bother calling an empty destructor or one that - returns immediately. */ - && (CvISXSUB(destructor) - || (CvSTART(destructor) - && (CvSTART(destructor)->op_next->op_type - != OP_LEAVESUB) - && (CvSTART(destructor)->op_next->op_type - != OP_PUSHMARK - || CvSTART(destructor)->op_next->op_next->op_type - != OP_RETURN - ) - )) - ) - { - SV* const tmpref = newRV(sv); - SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ - ENTER; - PUSHSTACKi(PERLSI_DESTROY); - EXTEND(SP, 2); - PUSHMARK(SP); - PUSHs(tmpref); - PUTBACK; - call_sv(MUTABLE_SV(destructor), - G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); - POPSTACK; - SPAGAIN; - LEAVE; - if(SvREFCNT(tmpref) < 2) { - /* tmpref is not kept alive! */ - SvREFCNT(sv)--; - SvRV_set(tmpref, NULL); - SvROK_off(tmpref); - } - SvREFCNT_dec_NN(tmpref); - } - } - } while (SvOBJECT(sv) && SvSTASH(sv) != stash); - - - if (check_refcnt && SvREFCNT(sv)) { - if (PL_in_clean_objs) - Perl_croak(aTHX_ - "DESTROY created new reference to dead object '%" HEKf "'", - HEKfARG(HvNAME_HEK(stash))); - /* DESTROY gave object new lease on life */ - return FALSE; - } + } + assert(!destructor || SvTYPE(destructor) == SVt_PVCV); + if (destructor + /* A constant subroutine can have no side effects, so + don't bother calling it. */ + && !CvCONST(destructor) + /* Don't bother calling an empty destructor or one that + returns immediately. */ + && (CvISXSUB(destructor) + || (CvSTART(destructor) + && (CvSTART(destructor)->op_next->op_type + != OP_LEAVESUB) + && (CvSTART(destructor)->op_next->op_type + != OP_PUSHMARK + || CvSTART(destructor)->op_next->op_next->op_type + != OP_RETURN + ) + )) + ) + { + SV* const tmpref = newRV(sv); + SvREADONLY_on(tmpref); /* DESTROY() could be naughty */ + ENTER; + PUSHSTACKi(PERLSI_DESTROY); + EXTEND(SP, 2); + PUSHMARK(SP); + PUSHs(tmpref); + PUTBACK; + call_sv(MUTABLE_SV(destructor), + G_DISCARD|G_EVAL|G_KEEPERR|G_VOID); + POPSTACK; + SPAGAIN; + LEAVE; + if(SvREFCNT(tmpref) < 2) { + /* tmpref is not kept alive! */ + SvREFCNT(sv)--; + SvRV_set(tmpref, NULL); + SvROK_off(tmpref); + } + SvREFCNT_dec_NN(tmpref); + } + } + } while (SvOBJECT(sv) && SvSTASH(sv) != stash); + + + if (check_refcnt && SvREFCNT(sv)) { + if (PL_in_clean_objs) + Perl_croak(aTHX_ + "DESTROY created new reference to dead object '%" HEKf "'", + HEKfARG(HvNAME_HEK(stash))); + /* DESTROY gave object new lease on life */ + return FALSE; + } } if (SvOBJECT(sv)) { - HV * const stash = SvSTASH(sv); - /* Curse before freeing the stash, as freeing the stash could cause - a recursive call into S_curse. */ - SvOBJECT_off(sv); /* Curse the object. */ - SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */ - SvREFCNT_dec(stash); /* possibly of changed persuasion */ + HV * const stash = SvSTASH(sv); + /* Curse before freeing the stash, as freeing the stash could cause + a recursive call into S_curse. */ + SvOBJECT_off(sv); /* Curse the object. */ + SvSTASH_set(sv,0); /* SvREFCNT_dec may try to read this */ + SvREFCNT_dec(stash); /* possibly of changed persuasion */ } return TRUE; } @@ -7037,7 +7037,7 @@ Perl_sv_newref(pTHX_ SV *const sv) { PERL_UNUSED_CONTEXT; if (sv) - (SvREFCNT(sv))++; + (SvREFCNT(sv))++; return sv; } @@ -7149,7 +7149,7 @@ Perl_sv_len(pTHX_ SV *const sv) STRLEN len; if (!sv) - return 0; + return 0; (void)SvPV_const(sv, len); return len; @@ -7177,7 +7177,7 @@ STRLEN Perl_sv_len_utf8(pTHX_ SV *const sv) { if (!sv) - return 0; + return 0; SvGETMAGIC(sv); return sv_len_utf8_nomg(sv); @@ -7192,31 +7192,31 @@ Perl_sv_len_utf8_nomg(pTHX_ SV * const sv) PERL_ARGS_ASSERT_SV_LEN_UTF8_NOMG; if (PL_utf8cache && SvUTF8(sv)) { - STRLEN ulen; - MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; - - if (mg && (mg->mg_len != -1 || mg->mg_ptr)) { - if (mg->mg_len != -1) - ulen = mg->mg_len; - else { - /* We can use the offset cache for a headstart. - The longer value is stored in the first pair. */ - STRLEN *cache = (STRLEN *) mg->mg_ptr; - - ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1], - s + len); - } - - if (PL_utf8cache < 0) { - const STRLEN real = Perl_utf8_length(aTHX_ s, s + len); - assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv); - } - } - else { - ulen = Perl_utf8_length(aTHX_ s, s + len); - utf8_mg_len_cache_update(sv, &mg, ulen); - } - return ulen; + STRLEN ulen; + MAGIC *mg = SvMAGICAL(sv) ? mg_find(sv, PERL_MAGIC_utf8) : NULL; + + if (mg && (mg->mg_len != -1 || mg->mg_ptr)) { + if (mg->mg_len != -1) + ulen = mg->mg_len; + else { + /* We can use the offset cache for a headstart. + The longer value is stored in the first pair. */ + STRLEN *cache = (STRLEN *) mg->mg_ptr; + + ulen = cache[0] + Perl_utf8_length(aTHX_ s + cache[1], + s + len); + } + + if (PL_utf8cache < 0) { + const STRLEN real = Perl_utf8_length(aTHX_ s, s + len); + assert_uft8_cache_coherent("sv_len_utf8", ulen, real, sv); + } + } + else { + ulen = Perl_utf8_length(aTHX_ s, s + len); + utf8_mg_len_cache_update(sv, &mg, ulen); + } + return ulen; } return SvUTF8(sv) ? Perl_utf8_length(aTHX_ s, s + len) : len; } @@ -7225,7 +7225,7 @@ Perl_sv_len_utf8_nomg(pTHX_ SV * const sv) offset. */ static STRLEN S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, - STRLEN *const uoffset_p, bool *const at_end) + STRLEN *const uoffset_p, bool *const at_end) { const U8 *s = start; STRLEN uoffset = *uoffset_p; @@ -7233,17 +7233,17 @@ S_sv_pos_u2b_forwards(const U8 *const start, const U8 *const send, PERL_ARGS_ASSERT_SV_POS_U2B_FORWARDS; while (s < send && uoffset) { - --uoffset; - s += UTF8SKIP(s); + --uoffset; + s += UTF8SKIP(s); } if (s == send) { - *at_end = TRUE; + *at_end = TRUE; } else if (s > send) { - *at_end = TRUE; - /* This is the existing behaviour. Possibly it should be a croak, as - it's actually a bounds error */ - s = send; + *at_end = TRUE; + /* This is the existing behaviour. Possibly it should be a croak, as + it's actually a bounds error */ + s = send; } *uoffset_p -= uoffset; return s - start; @@ -7254,30 +7254,30 @@ 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, const STRLEN uend) + 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). - (The real figure of course depends on the UTF-8 data.) */ - const U8 *s = start; + /* The assumption is that going forwards is twice the speed of going + forward (that's where the 2 * backw comes from). + (The real figure of course depends on the UTF-8 data.) */ + const U8 *s = start; - while (s < send && uoffset--) - s += UTF8SKIP(s); - assert (s <= send); - if (s > send) - s = send; - return s - start; + while (s < send && uoffset--) + s += UTF8SKIP(s); + assert (s <= send); + if (s > send) + s = send; + return s - start; } while (backw--) { - send--; - while (UTF8_IS_CONTINUATION(*send)) - send--; + send--; + while (UTF8_IS_CONTINUATION(*send)) + send--; } return send - start; } @@ -7292,8 +7292,8 @@ S_sv_pos_u2b_midway(const U8 *const start, const U8 *send, created if necessary, and the found value offered to it for update. */ static STRLEN S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start, - const U8 *const send, STRLEN uoffset, - STRLEN uoffset0, STRLEN boffset0) + const U8 *const send, STRLEN uoffset, + STRLEN uoffset0, STRLEN boffset0) { STRLEN boffset = 0; /* Actually always set, but let's keep gcc happy. */ bool found = FALSE; @@ -7304,96 +7304,96 @@ S_sv_pos_u2b_cached(pTHX_ SV *const sv, MAGIC **const mgp, const U8 *const start assert (uoffset >= uoffset0); if (!uoffset) - return 0; + return 0; if (!SvREADONLY(sv) && !SvGMAGICAL(sv) && SvPOK(sv) - && PL_utf8cache - && (*mgp || (SvTYPE(sv) >= SVt_PVMG && - (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) { - if ((*mgp)->mg_ptr) { - STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr; - if (cache[0] == uoffset) { - /* An exact match. */ - return cache[1]; - } - if (cache[2] == uoffset) { - /* An exact match. */ - return cache[3]; - } - - if (cache[0] < uoffset) { - /* The cache already knows part of the way. */ - if (cache[0] > uoffset0) { - /* The cache knows more than the passed in pair */ - uoffset0 = cache[0]; - boffset0 = cache[1]; - } - if ((*mgp)->mg_len != -1) { - /* And we know the end too. */ - boffset = boffset0 - + sv_pos_u2b_midway(start + boffset0, send, - uoffset - uoffset0, - (*mgp)->mg_len - uoffset0); - } else { - uoffset -= uoffset0; - boffset = boffset0 - + sv_pos_u2b_forwards(start + boffset0, - send, &uoffset, &at_end); - uoffset += uoffset0; - } - } - else if (cache[2] < uoffset) { - /* We're between the two cache entries. */ - if (cache[2] > uoffset0) { - /* and the cache knows more than the passed in pair */ - uoffset0 = cache[2]; - boffset0 = cache[3]; - } - - boffset = boffset0 - + sv_pos_u2b_midway(start + boffset0, - start + cache[1], - uoffset - uoffset0, - cache[0] - uoffset0); - } else { - boffset = boffset0 - + sv_pos_u2b_midway(start + boffset0, - start + cache[3], - uoffset - uoffset0, - cache[2] - uoffset0); - } - found = TRUE; - } - else if ((*mgp)->mg_len != -1) { - /* If we can take advantage of a passed in offset, do so. */ - /* In fact, offset0 is either 0, or less than offset, so don't - need to worry about the other possibility. */ - boffset = boffset0 - + sv_pos_u2b_midway(start + boffset0, send, - uoffset - uoffset0, - (*mgp)->mg_len - uoffset0); - found = TRUE; - } + && PL_utf8cache + && (*mgp || (SvTYPE(sv) >= SVt_PVMG && + (*mgp = mg_find(sv, PERL_MAGIC_utf8))))) { + if ((*mgp)->mg_ptr) { + STRLEN *cache = (STRLEN *) (*mgp)->mg_ptr; + if (cache[0] == uoffset) { + /* An exact match. */ + return cache[1]; + } + if (cache[2] == uoffset) { + /* An exact match. */ + return cache[3]; + } + + if (cache[0] < uoffset) { + /* The cache already knows part of the way. */ + if (cache[0] > uoffset0) { + /* The cache knows more than the passed in pair */ + uoffset0 = cache[0]; + boffset0 = cache[1]; + } + if ((*mgp)->mg_len != -1) { + /* And we know the end too. */ + boffset = boffset0 + + sv_pos_u2b_midway(start + boffset0, send, + uoffset - uoffset0, + (*mgp)->mg_len - uoffset0); + } else { + uoffset -= uoffset0; + boffset = boffset0 + + sv_pos_u2b_forwards(start + boffset0, + send, &uoffset, &at_end); + uoffset += uoffset0; + } + } + else if (cache[2] < uoffset) { + /* We're between the two cache entries. */ + if (cache[2] > uoffset0) { + /* and the cache knows more than the passed in pair */ + uoffset0 = cache[2]; + boffset0 = cache[3]; + } + + boffset = boffset0 + + sv_pos_u2b_midway(start + boffset0, + start + cache[1], + uoffset - uoffset0, + cache[0] - uoffset0); + } else { + boffset = boffset0 + + sv_pos_u2b_midway(start + boffset0, + start + cache[3], + uoffset - uoffset0, + cache[2] - uoffset0); + } + found = TRUE; + } + else if ((*mgp)->mg_len != -1) { + /* If we can take advantage of a passed in offset, do so. */ + /* In fact, offset0 is either 0, or less than offset, so don't + need to worry about the other possibility. */ + boffset = boffset0 + + sv_pos_u2b_midway(start + boffset0, send, + uoffset - uoffset0, + (*mgp)->mg_len - uoffset0); + found = TRUE; + } } if (!found || PL_utf8cache < 0) { - STRLEN real_boffset; - uoffset -= uoffset0; - real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0, - send, &uoffset, &at_end); - uoffset += uoffset0; + STRLEN real_boffset; + uoffset -= uoffset0; + real_boffset = boffset0 + sv_pos_u2b_forwards(start + boffset0, + send, &uoffset, &at_end); + uoffset += uoffset0; - if (found && PL_utf8cache < 0) - assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset, - real_boffset, sv); - boffset = real_boffset; + if (found && PL_utf8cache < 0) + assert_uft8_cache_coherent("sv_pos_u2b_cache", boffset, + real_boffset, sv); + boffset = real_boffset; } if (PL_utf8cache && !SvGMAGICAL(sv) && SvPOK(sv)) { - if (at_end) - utf8_mg_len_cache_update(sv, mgp, uoffset); - else - utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start); + if (at_end) + utf8_mg_len_cache_update(sv, mgp, uoffset); + else + utf8_mg_pos_cache_update(sv, mgp, boffset, uoffset, send - start); } return boffset; } @@ -7422,7 +7422,7 @@ C to handle magic. STRLEN Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp, - U32 flags) + U32 flags) { const U8 *start; STRLEN len; @@ -7432,25 +7432,25 @@ Perl_sv_pos_u2b_flags(pTHX_ SV *const sv, STRLEN uoffset, STRLEN *const lenp, start = (U8*)SvPV_flags(sv, len, flags); if (len) { - const U8 * const send = start + len; - MAGIC *mg = NULL; - boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0); - - if (lenp - && *lenp /* don't bother doing work for 0, as its bytes equivalent - is 0, and *lenp is already set to that. */) { - /* Convert the relative offset to absolute. */ - const STRLEN uoffset2 = uoffset + *lenp; - const STRLEN boffset2 - = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, - uoffset, boffset) - boffset; - - *lenp = boffset2; - } + const U8 * const send = start + len; + MAGIC *mg = NULL; + boffset = sv_pos_u2b_cached(sv, &mg, start, send, uoffset, 0, 0); + + if (lenp + && *lenp /* don't bother doing work for 0, as its bytes equivalent + is 0, and *lenp is already set to that. */) { + /* Convert the relative offset to absolute. */ + const STRLEN uoffset2 = uoffset + *lenp; + const STRLEN boffset2 + = sv_pos_u2b_cached(sv, &mg, start, send, uoffset2, + uoffset, boffset) - boffset; + + *lenp = boffset2; + } } else { - if (lenp) - *lenp = 0; - boffset = 0; + if (lenp) + *lenp = 0; + boffset = 0; } return boffset; @@ -7486,27 +7486,27 @@ Perl_sv_pos_u2b(pTHX_ SV *const sv, I32 *const offsetp, I32 *const lenp) PERL_ARGS_ASSERT_SV_POS_U2B; if (lenp) { - STRLEN ulen = (STRLEN)*lenp; - *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen, - SV_GMAGIC|SV_CONST_RETURN); - *lenp = (I32)ulen; + STRLEN ulen = (STRLEN)*lenp; + *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, &ulen, + SV_GMAGIC|SV_CONST_RETURN); + *lenp = (I32)ulen; } else { - *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL, - SV_GMAGIC|SV_CONST_RETURN); + *offsetp = (I32)sv_pos_u2b_flags(sv, (STRLEN)*offsetp, NULL, + SV_GMAGIC|SV_CONST_RETURN); } } static void S_utf8_mg_len_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, - const STRLEN ulen) + const STRLEN ulen) { PERL_ARGS_ASSERT_UTF8_MG_LEN_CACHE_UPDATE; if (SvREADONLY(sv) || SvGMAGICAL(sv) || !SvPOK(sv)) - return; + return; if (!*mgp && (SvTYPE(sv) < SVt_PVMG || - !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { - *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0); + !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { + *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, &PL_vtbl_utf8, 0, 0); } assert(*mgp); @@ -7545,31 +7545,31 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b PERL_ARGS_ASSERT_UTF8_MG_POS_CACHE_UPDATE; if (SvREADONLY(sv)) - return; + return; if (!*mgp && (SvTYPE(sv) < SVt_PVMG || - !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { - *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, - 0); - (*mgp)->mg_len = -1; + !(*mgp = mg_find(sv, PERL_MAGIC_utf8)))) { + *mgp = sv_magicext(sv, 0, PERL_MAGIC_utf8, (MGVTBL*)&PL_vtbl_utf8, 0, + 0); + (*mgp)->mg_len = -1; } assert(*mgp); if (!(cache = (STRLEN *)(*mgp)->mg_ptr)) { - Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); - (*mgp)->mg_ptr = (char *) cache; + Newxz(cache, PERL_MAGIC_UTF8_CACHESIZE * 2, STRLEN); + (*mgp)->mg_ptr = (char *) cache; } assert(cache); if (PL_utf8cache < 0 && SvPOKp(sv)) { - /* SvPOKp() because, if sv is a reference, then SvPVX() is actually - a pointer. Note that we no longer cache utf8 offsets on refer- - ences, but this check is still a good idea, for robustness. */ - const U8 *start = (const U8 *) SvPVX_const(sv); - const STRLEN realutf8 = utf8_length(start, start + byte); + /* SvPOKp() because, if sv is a reference, then SvPVX() is actually + a pointer. Note that we no longer cache utf8 offsets on refer- + ences, but this check is still a good idea, for robustness. */ + const U8 *start = (const U8 *) SvPVX_const(sv); + const STRLEN realutf8 = utf8_length(start, start + byte); - assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8, - sv); + assert_uft8_cache_coherent("utf8_mg_pos_cache_update", utf8, realutf8, + sv); } /* Cache is held with the later position first, to simplify the code @@ -7577,78 +7577,78 @@ S_utf8_mg_pos_cache_update(pTHX_ SV *const sv, MAGIC **const mgp, const STRLEN b ASSERT_UTF8_CACHE(cache); if (cache[1] == 0) { - /* Cache is totally empty */ - cache[0] = utf8; - cache[1] = byte; + /* Cache is totally empty */ + cache[0] = utf8; + cache[1] = byte; } else if (cache[3] == 0) { - if (byte > cache[1]) { - /* New one is larger, so goes first. */ - cache[2] = cache[0]; - cache[3] = cache[1]; - cache[0] = utf8; - cache[1] = byte; - } else { - cache[2] = utf8; - cache[3] = byte; - } + if (byte > cache[1]) { + /* New one is larger, so goes first. */ + cache[2] = cache[0]; + cache[3] = cache[1]; + cache[0] = utf8; + cache[1] = byte; + } else { + cache[2] = utf8; + cache[3] = byte; + } } else { /* float casts necessary? XXX */ #define THREEWAY_SQUARE(a,b,c,d) \ - ((float)((d) - (c))) * ((float)((d) - (c))) \ - + ((float)((c) - (b))) * ((float)((c) - (b))) \ - + ((float)((b) - (a))) * ((float)((b) - (a))) - - /* Cache has 2 slots in use, and we know three potential pairs. - Keep the two that give the lowest RMS distance. Do the - calculation in bytes simply because we always know the byte - length. squareroot has the same ordering as the positive value, - so don't bother with the actual square root. */ - if (byte > cache[1]) { - /* New position is after the existing pair of pairs. */ - const float keep_earlier - = THREEWAY_SQUARE(0, cache[3], byte, blen); - const float keep_later - = THREEWAY_SQUARE(0, cache[1], byte, blen); - - if (keep_later < keep_earlier) { + ((float)((d) - (c))) * ((float)((d) - (c))) \ + + ((float)((c) - (b))) * ((float)((c) - (b))) \ + + ((float)((b) - (a))) * ((float)((b) - (a))) + + /* Cache has 2 slots in use, and we know three potential pairs. + Keep the two that give the lowest RMS distance. Do the + calculation in bytes simply because we always know the byte + length. squareroot has the same ordering as the positive value, + so don't bother with the actual square root. */ + if (byte > cache[1]) { + /* New position is after the existing pair of pairs. */ + const float keep_earlier + = THREEWAY_SQUARE(0, cache[3], byte, blen); + const float keep_later + = THREEWAY_SQUARE(0, cache[1], byte, blen); + + if (keep_later < keep_earlier) { cache[2] = cache[0]; cache[3] = cache[1]; - } + } cache[0] = utf8; cache[1] = byte; - } - else { - const float keep_later = THREEWAY_SQUARE(0, byte, cache[1], blen); - float b, c, keep_earlier; - if (byte > cache[3]) { - /* New position is between the existing pair of pairs. */ - b = (float)cache[3]; - c = (float)byte; - } else { - /* New position is before the existing pair of pairs. */ - b = (float)byte; - c = (float)cache[3]; - } - keep_earlier = THREEWAY_SQUARE(0, b, c, blen); - if (byte > cache[3]) { - if (keep_later < keep_earlier) { - cache[2] = utf8; - cache[3] = byte; - } - else { - cache[0] = utf8; - cache[1] = byte; - } - } - else { - if (! (keep_later < keep_earlier)) { - cache[0] = cache[2]; - cache[1] = cache[3]; - } - cache[2] = utf8; - cache[3] = byte; - } - } + } + else { + const float keep_later = THREEWAY_SQUARE(0, byte, cache[1], blen); + float b, c, keep_earlier; + if (byte > cache[3]) { + /* New position is between the existing pair of pairs. */ + b = (float)cache[3]; + c = (float)byte; + } else { + /* New position is before the existing pair of pairs. */ + b = (float)byte; + c = (float)cache[3]; + } + keep_earlier = THREEWAY_SQUARE(0, b, c, blen); + if (byte > cache[3]) { + if (keep_later < keep_earlier) { + cache[2] = utf8; + cache[3] = byte; + } + else { + cache[0] = utf8; + cache[1] = byte; + } + } + else { + if (! (keep_later < keep_earlier)) { + cache[0] = cache[2]; + cache[1] = cache[3]; + } + cache[2] = utf8; + cache[3] = byte; + } + } } ASSERT_UTF8_CACHE(cache); } @@ -7666,15 +7666,15 @@ S_sv_pos_b2u_midway(pTHX_ const U8 *const s, const U8 *const target, PERL_ARGS_ASSERT_SV_POS_B2U_MIDWAY; if (forw < 2 * backw) { - return utf8_length(s, target); + return utf8_length(s, target); } while (end > target) { - end--; - while (UTF8_IS_CONTINUATION(*end)) { - end--; - } - endu--; + end--; + while (UTF8_IS_CONTINUATION(*end)) { + end--; + } + endu--; } return endu; } @@ -7711,73 +7711,73 @@ Perl_sv_pos_b2u_flags(pTHX_ SV *const sv, STRLEN const offset, U32 flags) s = (const U8*)SvPV_flags(sv, blen, flags); if (blen < offset) - Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%" UVuf - ", byte=%" UVuf, (UV)blen, (UV)offset); + Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset, blen=%" UVuf + ", byte=%" UVuf, (UV)blen, (UV)offset); send = s + offset; if (!SvREADONLY(sv) - && PL_utf8cache - && SvTYPE(sv) >= SVt_PVMG - && (mg = mg_find(sv, PERL_MAGIC_utf8))) + && PL_utf8cache + && SvTYPE(sv) >= SVt_PVMG + && (mg = mg_find(sv, PERL_MAGIC_utf8))) { - if (mg->mg_ptr) { - STRLEN * const cache = (STRLEN *) mg->mg_ptr; - if (cache[1] == offset) { - /* An exact match. */ - return cache[0]; - } - if (cache[3] == offset) { - /* An exact match. */ - return cache[2]; - } - - if (cache[1] < offset) { - /* We already know part of the way. */ - if (mg->mg_len != -1) { - /* Actually, we know the end too. */ - len = cache[0] - + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send, - s + blen, mg->mg_len - cache[0]); - } else { - len = cache[0] + utf8_length(s + cache[1], send); - } - } - else if (cache[3] < offset) { - /* We're between the two cached pairs, so we do the calculation - offset by the byte/utf-8 positions for the earlier pair, - then add the utf-8 characters from the string start to - there. */ - len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send, - s + cache[1], cache[0] - cache[2]) - + cache[2]; - - } - else { /* cache[3] > offset */ - len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3], - cache[2]); - - } - ASSERT_UTF8_CACHE(cache); - found = TRUE; - } else if (mg->mg_len != -1) { - len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len); - found = TRUE; - } + if (mg->mg_ptr) { + STRLEN * const cache = (STRLEN *) mg->mg_ptr; + if (cache[1] == offset) { + /* An exact match. */ + return cache[0]; + } + if (cache[3] == offset) { + /* An exact match. */ + return cache[2]; + } + + if (cache[1] < offset) { + /* We already know part of the way. */ + if (mg->mg_len != -1) { + /* Actually, we know the end too. */ + len = cache[0] + + S_sv_pos_b2u_midway(aTHX_ s + cache[1], send, + s + blen, mg->mg_len - cache[0]); + } else { + len = cache[0] + utf8_length(s + cache[1], send); + } + } + else if (cache[3] < offset) { + /* We're between the two cached pairs, so we do the calculation + offset by the byte/utf-8 positions for the earlier pair, + then add the utf-8 characters from the string start to + there. */ + len = S_sv_pos_b2u_midway(aTHX_ s + cache[3], send, + s + cache[1], cache[0] - cache[2]) + + cache[2]; + + } + else { /* cache[3] > offset */ + len = S_sv_pos_b2u_midway(aTHX_ s, send, s + cache[3], + cache[2]); + + } + ASSERT_UTF8_CACHE(cache); + found = TRUE; + } else if (mg->mg_len != -1) { + len = S_sv_pos_b2u_midway(aTHX_ s, send, s + blen, mg->mg_len); + found = TRUE; + } } if (!found || PL_utf8cache < 0) { - const STRLEN real_len = utf8_length(s, send); + const STRLEN real_len = utf8_length(s, send); - if (found && PL_utf8cache < 0) - assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv); - len = real_len; + if (found && PL_utf8cache < 0) + assert_uft8_cache_coherent("sv_pos_b2u", len, real_len, sv); + len = real_len; } if (PL_utf8cache) { - if (blen == offset) - utf8_mg_len_cache_update(sv, &mg, len); - else - utf8_mg_pos_cache_update(sv, &mg, offset, len, blen); + if (blen == offset) + utf8_mg_len_cache_update(sv, &mg, len); + else + utf8_mg_pos_cache_update(sv, &mg, offset, len, blen); } return len; @@ -7808,29 +7808,29 @@ Perl_sv_pos_b2u(pTHX_ SV *const sv, I32 *const offsetp) PERL_ARGS_ASSERT_SV_POS_B2U; if (!sv) - return; + return; *offsetp = (I32)sv_pos_b2u_flags(sv, (STRLEN)*offsetp, - SV_GMAGIC|SV_CONST_RETURN); + SV_GMAGIC|SV_CONST_RETURN); } static void S_assert_uft8_cache_coherent(pTHX_ const char *const func, STRLEN from_cache, - STRLEN real, SV *const sv) + STRLEN real, SV *const sv) { PERL_ARGS_ASSERT_ASSERT_UFT8_CACHE_COHERENT; /* As this is debugging only code, save space by keeping this test here, rather than inlining it in all the callers. */ if (from_cache == real) - return; + return; /* Need to turn the assertions off otherwise we may recurse infinitely while printing error messages. */ SAVEI8(PL_utf8cache); PL_utf8cache = 0; Perl_croak(aTHX_ "panic: %s cache %" UVuf " real %" UVuf " for %" SVf, - func, (UV) from_cache, (UV) real, SVfARG(sv)); + func, (UV) from_cache, (UV) real, SVfARG(sv)); } /* @@ -7858,46 +7858,46 @@ Perl_sv_eq_flags(pTHX_ SV *sv1, SV *sv2, const U32 flags) STRLEN cur2; if (!sv1) { - pv1 = ""; - cur1 = 0; + pv1 = ""; + cur1 = 0; } else { - /* if pv1 and pv2 are the same, second SvPV_const call may - * invalidate pv1 (if we are handling magic), so we may need to - * make a copy */ - if (sv1 == sv2 && flags & SV_GMAGIC - && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { - pv1 = SvPV_const(sv1, cur1); - sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2)); - } - pv1 = SvPV_flags_const(sv1, cur1, flags); + /* if pv1 and pv2 are the same, second SvPV_const call may + * invalidate pv1 (if we are handling magic), so we may need to + * make a copy */ + if (sv1 == sv2 && flags & SV_GMAGIC + && (SvTHINKFIRST(sv1) || SvGMAGICAL(sv1))) { + pv1 = SvPV_const(sv1, cur1); + sv1 = newSVpvn_flags(pv1, cur1, SVs_TEMP | SvUTF8(sv2)); + } + pv1 = SvPV_flags_const(sv1, cur1, flags); } if (!sv2){ - pv2 = ""; - cur2 = 0; + pv2 = ""; + cur2 = 0; } else - pv2 = SvPV_flags_const(sv2, cur2, flags); + pv2 = SvPV_flags_const(sv2, cur2, flags); if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { /* Differing utf8ness. */ - if (SvUTF8(sv1)) { - /* sv1 is the UTF-8 one */ - return bytes_cmp_utf8((const U8*)pv2, cur2, - (const U8*)pv1, cur1) == 0; - } - else { - /* sv2 is the UTF-8 one */ - return bytes_cmp_utf8((const U8*)pv1, cur1, - (const U8*)pv2, cur2) == 0; - } + if (SvUTF8(sv1)) { + /* sv1 is the UTF-8 one */ + return bytes_cmp_utf8((const U8*)pv2, cur2, + (const U8*)pv1, cur1) == 0; + } + else { + /* sv2 is the UTF-8 one */ + return bytes_cmp_utf8((const U8*)pv1, cur1, + (const U8*)pv2, cur2) == 0; + } } if (cur1 == cur2) - return (pv1 == pv2) || memEQ(pv1, pv2, cur1); + return (pv1 == pv2) || memEQ(pv1, pv2, cur1); else - return 0; + return 0; } /* @@ -7927,7 +7927,7 @@ Perl_sv_cmp(pTHX_ SV *const sv1, SV *const sv2) I32 Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, - const U32 flags) + const U32 flags) { STRLEN cur1, cur2; const char *pv1, *pv2; @@ -7935,39 +7935,39 @@ Perl_sv_cmp_flags(pTHX_ SV *const sv1, SV *const sv2, SV *svrecode = NULL; if (!sv1) { - pv1 = ""; - cur1 = 0; + pv1 = ""; + cur1 = 0; } else - pv1 = SvPV_flags_const(sv1, cur1, flags); + pv1 = SvPV_flags_const(sv1, cur1, flags); if (!sv2) { - pv2 = ""; - cur2 = 0; + pv2 = ""; + cur2 = 0; } else - pv2 = SvPV_flags_const(sv2, cur2, flags); + pv2 = SvPV_flags_const(sv2, cur2, flags); if (cur1 && cur2 && SvUTF8(sv1) != SvUTF8(sv2) && !IN_BYTES) { /* Differing utf8ness. */ - if (SvUTF8(sv1)) { - const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2, - (const U8*)pv1, cur1); - return retval ? retval < 0 ? -1 : +1 : 0; - } - else { - const int retval = bytes_cmp_utf8((const U8*)pv1, cur1, - (const U8*)pv2, cur2); - return retval ? retval < 0 ? -1 : +1 : 0; - } + if (SvUTF8(sv1)) { + const int retval = -bytes_cmp_utf8((const U8*)pv2, cur2, + (const U8*)pv1, cur1); + return retval ? retval < 0 ? -1 : +1 : 0; + } + else { + const int retval = bytes_cmp_utf8((const U8*)pv1, cur1, + (const U8*)pv2, cur2); + return retval ? retval < 0 ? -1 : +1 : 0; + } } /* Here, if both are non-NULL, then they have the same UTF8ness. */ if (!cur1) { - cmp = cur2 ? -1 : 0; + cmp = cur2 ? -1 : 0; } else if (!cur2) { - cmp = 1; + cmp = 1; } else { STRLEN shortest_len = cur1 < cur2 ? cur1 : cur2; @@ -8155,7 +8155,7 @@ Perl_sv_cmp_locale(pTHX_ SV *const sv1, SV *const sv2) I32 Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, - const U32 flags) + const U32 flags) { #ifdef USE_LOCALE_COLLATE @@ -8164,7 +8164,7 @@ Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, I32 retval; if (PL_collation_standard) - goto raw_compare; + goto raw_compare; len1 = len2 = 0; @@ -8186,20 +8186,20 @@ Perl_sv_cmp_locale_flags(pTHX_ SV *const sv1, SV *const sv2, } if (!pv1 || !len1) { - if (pv2 && len2) - return -1; - else - goto raw_compare; + if (pv2 && len2) + return -1; + else + goto raw_compare; } else { - if (!pv2 || !len2) - return 1; + if (!pv2 || !len2) + return 1; } retval = memcmp((void*)pv1, (void*)pv2, len1 < len2 ? len1 : len2); if (retval) - return retval < 0 ? -1 : 1; + return retval < 0 ? -1 : 1; /* * When the result of collation is equality, that doesn't mean @@ -8252,39 +8252,39 @@ Perl_sv_collxfrm_flags(pTHX_ SV *const sv, STRLEN *const nxp, const I32 flags) /* If we don't have collation magic on 'sv', or the locale has changed * since the last time we calculated it, get it and save it now */ if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != PL_collation_ix) { - const char *s; - char *xf; - STRLEN len, xlen; + const char *s; + char *xf; + STRLEN len, xlen; /* Free the old space */ - if (mg) - Safefree(mg->mg_ptr); - - s = SvPV_flags_const(sv, len, flags); - if ((xf = mem_collxfrm_(s, len, &xlen, cBOOL(SvUTF8(sv))))) { - if (! mg) { - mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm, - 0, 0); - assert(mg); - } - mg->mg_ptr = xf; - mg->mg_len = xlen; - } - else { - if (mg) { - mg->mg_ptr = NULL; - mg->mg_len = -1; - } - } + if (mg) + Safefree(mg->mg_ptr); + + s = SvPV_flags_const(sv, len, flags); + if ((xf = mem_collxfrm_(s, len, &xlen, cBOOL(SvUTF8(sv))))) { + if (! mg) { + mg = sv_magicext(sv, 0, PERL_MAGIC_collxfrm, &PL_vtbl_collxfrm, + 0, 0); + assert(mg); + } + mg->mg_ptr = xf; + mg->mg_len = xlen; + } + else { + if (mg) { + mg->mg_ptr = NULL; + mg->mg_len = -1; + } + } } if (mg && mg->mg_ptr) { - *nxp = mg->mg_len; - return mg->mg_ptr + sizeof(PL_collation_ix); + *nxp = mg->mg_len; + return mg->mg_ptr + sizeof(PL_collation_ix); } else { - *nxp = 0; - return NULL; + *nxp = 0; + return NULL; } } @@ -8325,96 +8325,96 @@ S_sv_gets_read_record(pTHX_ SV *const sv, PerlIO *const fp, I32 append) */ fd = PerlIO_fileno(fp); if (fd != -1 - && PerlLIO_fstat(fd, &st) == 0 - && (st.st_fab_rfm == FAB$C_VAR - || st.st_fab_rfm == FAB$C_VFC - || st.st_fab_rfm == FAB$C_FIX)) { + && PerlLIO_fstat(fd, &st) == 0 + && (st.st_fab_rfm == FAB$C_VAR + || st.st_fab_rfm == FAB$C_VFC + || st.st_fab_rfm == FAB$C_FIX)) { - bytesread = PerlLIO_read(fd, buffer, recsize); + bytesread = PerlLIO_read(fd, buffer, recsize); } else /* in-memory file from PerlIO::Scalar * or not a record-oriented file */ #endif { - bytesread = PerlIO_read(fp, buffer, recsize); - - /* At this point, the logic in sv_get() means that sv will - be treated as utf-8 if the handle is utf8. - */ - if (PerlIO_isutf8(fp) && bytesread > 0) { - char *bend = buffer + bytesread; - char *bufp = buffer; - size_t charcount = 0; - bool charstart = TRUE; - STRLEN skip = 0; - - while (charcount < recsize) { - /* count accumulated characters */ - while (bufp < bend) { - if (charstart) { - skip = UTF8SKIP(bufp); - } - if (bufp + skip > bend) { - /* partial at the end */ - charstart = FALSE; - break; - } - else { - ++charcount; - bufp += skip; - charstart = TRUE; - } - } - - if (charcount < recsize) { - STRLEN readsize; - STRLEN bufp_offset = bufp - buffer; - SSize_t morebytesread; - - /* originally I read enough to fill any incomplete - character and the first byte of the next - character if needed, but if there's many - multi-byte encoded characters we're going to be - making a read call for every character beyond - the original read size. - - So instead, read the rest of the character if - any, and enough bytes to match at least the - start bytes for each character we're going to - read. - */ - if (charstart) - readsize = recsize - charcount; - else - readsize = skip - (bend - bufp) + recsize - charcount - 1; - buffer = SvGROW(sv, append + bytesread + readsize + 1) + append; - bend = buffer + bytesread; - morebytesread = PerlIO_read(fp, bend, readsize); - if (morebytesread <= 0) { - /* we're done, if we still have incomplete - characters the check code in sv_gets() will - warn about them. - - I'd originally considered doing - PerlIO_ungetc() on all but the lead - character of the incomplete character, but - read() doesn't do that, so I don't. - */ - break; - } - - /* prepare to scan some more */ - bytesread += morebytesread; - bend = buffer + bytesread; - bufp = buffer + bufp_offset; - } - } - } + bytesread = PerlIO_read(fp, buffer, recsize); + + /* At this point, the logic in sv_get() means that sv will + be treated as utf-8 if the handle is utf8. + */ + if (PerlIO_isutf8(fp) && bytesread > 0) { + char *bend = buffer + bytesread; + char *bufp = buffer; + size_t charcount = 0; + bool charstart = TRUE; + STRLEN skip = 0; + + while (charcount < recsize) { + /* count accumulated characters */ + while (bufp < bend) { + if (charstart) { + skip = UTF8SKIP(bufp); + } + if (bufp + skip > bend) { + /* partial at the end */ + charstart = FALSE; + break; + } + else { + ++charcount; + bufp += skip; + charstart = TRUE; + } + } + + if (charcount < recsize) { + STRLEN readsize; + STRLEN bufp_offset = bufp - buffer; + SSize_t morebytesread; + + /* originally I read enough to fill any incomplete + character and the first byte of the next + character if needed, but if there's many + multi-byte encoded characters we're going to be + making a read call for every character beyond + the original read size. + + So instead, read the rest of the character if + any, and enough bytes to match at least the + start bytes for each character we're going to + read. + */ + if (charstart) + readsize = recsize - charcount; + else + readsize = skip - (bend - bufp) + recsize - charcount - 1; + buffer = SvGROW(sv, append + bytesread + readsize + 1) + append; + bend = buffer + bytesread; + morebytesread = PerlIO_read(fp, bend, readsize); + if (morebytesread <= 0) { + /* we're done, if we still have incomplete + characters the check code in sv_gets() will + warn about them. + + I'd originally considered doing + PerlIO_ungetc() on all but the lead + character of the incomplete character, but + read() doesn't do that, so I don't. + */ + break; + } + + /* prepare to scan some more */ + bytesread += morebytesread; + bend = buffer + bytesread; + bufp = buffer + bufp_offset; + } + } + } } if (bytesread < 0) - bytesread = 0; + bytesread = 0; SvCUR_set(sv, bytesread + append); buffer[bytesread] = '\0'; return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; @@ -8446,7 +8446,7 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) PERL_ARGS_ASSERT_SV_GETS; if (SvTHINKFIRST(sv)) - sv_force_normal_flags(sv, append ? 0 : SV_COW_DROP_PV); + 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 from <>. However, perlbench says it's slower, because the existing swipe code @@ -8456,14 +8456,14 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) if (append) { /* line is going to be appended to the existing buffer in the sv */ - if (PerlIO_isutf8(fp)) { - if (!SvUTF8(sv)) { - sv_utf8_upgrade_nomg(sv); - sv_pos_u2b(sv,&append,0); - } - } else if (SvUTF8(sv)) { - return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append); - } + if (PerlIO_isutf8(fp)) { + if (!SvUTF8(sv)) { + sv_utf8_upgrade_nomg(sv); + sv_pos_u2b(sv,&append,0); + } + } else if (SvUTF8(sv)) { + return S_sv_gets_append_to_utf8(aTHX_ sv, fp, append); + } } SvPOK_only(sv); @@ -8473,58 +8473,58 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) SvCUR_set(sv,0); } if (PerlIO_isutf8(fp)) - SvUTF8_on(sv); + SvUTF8_on(sv); if (IN_PERL_COMPILETIME) { - /* we always read code in line mode */ - rsptr = "\n"; - rslen = 1; + /* we always read code in line mode */ + rsptr = "\n"; + rslen = 1; } else if (RsSNARF(PL_rs)) { - /* If it is a regular disk file use size from stat() as estimate - of amount we are going to read -- may result in mallocing - more memory than we really need if the layers below reduce - the size we read (e.g. CRLF or a gzip layer). - */ - Stat_t st; + /* If it is a regular disk file use size from stat() as estimate + of amount we are going to read -- may result in mallocing + more memory than we really need if the layers below reduce + the size we read (e.g. CRLF or a gzip layer). + */ + Stat_t st; int fd = PerlIO_fileno(fp); - if (fd >= 0 && (PerlLIO_fstat(fd, &st) == 0) && S_ISREG(st.st_mode)) { - const Off_t offset = PerlIO_tell(fp); - if (offset != (Off_t) -1 && st.st_size + append > offset) { + if (fd >= 0 && (PerlLIO_fstat(fd, &st) == 0) && S_ISREG(st.st_mode)) { + const Off_t offset = PerlIO_tell(fp); + if (offset != (Off_t) -1 && st.st_size + append > offset) { #ifdef PERL_COPY_ON_WRITE /* Add an extra byte for the sake of copy-on-write's * buffer reference count. */ - (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 2)); + (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 2)); #else - (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); + (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); #endif - } - } - rsptr = NULL; - rslen = 0; + } + } + rsptr = NULL; + rslen = 0; } else if (RsRECORD(PL_rs)) { - return S_sv_gets_read_record(aTHX_ sv, fp, append); + return S_sv_gets_read_record(aTHX_ sv, fp, append); } else if (RsPARA(PL_rs)) { - rsptr = "\n\n"; - rslen = 2; - rspara = 1; + rsptr = "\n\n"; + rslen = 2; + rspara = 1; } else { - /* Get $/ i.e. PL_rs into same encoding as stream wants */ - if (PerlIO_isutf8(fp)) { - rsptr = SvPVutf8(PL_rs, rslen); - } - else { - if (SvUTF8(PL_rs)) { - if (!sv_utf8_downgrade(PL_rs, TRUE)) { - Perl_croak(aTHX_ "Wide character in $/"); - } - } + /* Get $/ i.e. PL_rs into same encoding as stream wants */ + if (PerlIO_isutf8(fp)) { + rsptr = SvPVutf8(PL_rs, rslen); + } + else { + if (SvUTF8(PL_rs)) { + if (!sv_utf8_downgrade(PL_rs, TRUE)) { + Perl_croak(aTHX_ "Wide character in $/"); + } + } /* extract the raw pointer to the record separator */ - rsptr = SvPV_const(PL_rs, rslen); - } + rsptr = SvPV_const(PL_rs, rslen); + } } /* rslast is the last character in the record separator @@ -8641,25 +8641,25 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) /* make sure we have the room */ if ((I32)(SvLEN(sv) - append) <= cnt + 1) { - /* Not room for all of it - if we are looking for a separator and room for some - */ - if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) { - /* just process what we have room for */ - shortbuffered = cnt - SvLEN(sv) + append + 1; - cnt -= shortbuffered; - } - else { + /* Not room for all of it + if we are looking for a separator and room for some + */ + if (rslen && cnt > 80 && (I32)SvLEN(sv) > append) { + /* just process what we have room for */ + shortbuffered = cnt - SvLEN(sv) + append + 1; + cnt -= shortbuffered; + } + else { /* ensure that the target sv has enough room to hold * the rest of the read-ahead buffer */ - shortbuffered = 0; - /* remember that cnt can be negative */ - SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1)))); - } + shortbuffered = 0; + /* remember that cnt can be negative */ + SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1)))); + } } else { /* we have enough room to hold the full buffer, lets scream */ - shortbuffered = 0; + shortbuffered = 0; } /* extract the pointer to sv's string buffer, offset by append as necessary */ @@ -8669,19 +8669,19 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) /* some trace debug output */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering, ptr=%" UVuf ", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); + "Screamer: entering, ptr=%" UVuf ", cnt=%ld\n",PTR2UV(ptr),(long)cnt)); DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: entering: PerlIO * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" - UVuf "\n", - PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), - PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); + "Screamer: entering: PerlIO * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" + UVuf "\n", + PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base(fp) ? PerlIO_get_base(fp) : 0))); for (;;) { screamer: /* if there is stuff left in the read-ahead buffer */ - if (cnt > 0) { + if (cnt > 0) { /* if there is a separator */ - if (rslen) { + if (rslen) { /* find next rslast */ STDCHAR *p; @@ -8703,43 +8703,43 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) ptr += cnt; bp += cnt; cnt = 0; - } - else { + } + else { /* no separator, slurp the full buffer */ - Copy(ptr, bp, cnt, char); /* this | eat */ - bp += cnt; /* screams | dust */ - ptr += cnt; /* louder | sed :-) */ - cnt = 0; - assert (!shortbuffered); - goto cannot_be_shortbuffered; - } - } - - if (shortbuffered) { /* oh well, must extend */ + Copy(ptr, bp, cnt, char); /* this | eat */ + bp += cnt; /* screams | dust */ + ptr += cnt; /* louder | sed :-) */ + cnt = 0; + assert (!shortbuffered); + goto cannot_be_shortbuffered; + } + } + + if (shortbuffered) { /* oh well, must extend */ /* we didnt have enough room to fit the line into the target buffer * so we must extend the target buffer and keep going */ - cnt = shortbuffered; - shortbuffered = 0; - bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ - SvCUR_set(sv, bpx); + cnt = shortbuffered; + shortbuffered = 0; + bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ + SvCUR_set(sv, bpx); /* extned the target sv's buffer so it can hold the full read-ahead buffer */ - SvGROW(sv, SvLEN(sv) + append + cnt + 2); - bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ - continue; - } + SvGROW(sv, SvLEN(sv) + append + cnt + 2); + bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ + continue; + } cannot_be_shortbuffered: /* we need to refill the read-ahead buffer if possible */ - DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: going to getc, ptr=%" UVuf ", cnt=%" IVdf "\n", - PTR2UV(ptr),(IV)cnt)); - PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */ + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: going to getc, ptr=%" UVuf ", cnt=%" IVdf "\n", + PTR2UV(ptr),(IV)cnt)); + PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* deregisterize cnt and ptr */ - DEBUG_Pv(PerlIO_printf(Perl_debug_log, - "Screamer: pre: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n", - PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), - PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); + DEBUG_Pv(PerlIO_printf(Perl_debug_log, + "Screamer: pre: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n", + PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); /* call PerlIO_getc() to let it prefill the lookahead buffer @@ -8752,123 +8752,123 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) */ bpx = bp - (STDCHAR*)SvPVX_const(sv); /* signals might be called here, possibly modifying sv */ - i = PerlIO_getc(fp); /* get more characters */ + i = PerlIO_getc(fp); /* get more characters */ bp = (STDCHAR*)SvPVX_const(sv) + bpx; - DEBUG_Pv(PerlIO_printf(Perl_debug_log, - "Screamer: post: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n", - PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), - PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); + DEBUG_Pv(PerlIO_printf(Perl_debug_log, + "Screamer: post: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf "\n", + PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); /* find out how much is left in the read-ahead buffer, and rextract its pointer */ - cnt = PerlIO_get_cnt(fp); - ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ - DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: after getc, ptr=%" UVuf ", cnt=%" IVdf "\n", - PTR2UV(ptr),(IV)cnt)); + cnt = PerlIO_get_cnt(fp); + ptr = (STDCHAR*)PerlIO_get_ptr(fp); /* reregisterize cnt and ptr */ + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: after getc, ptr=%" UVuf ", cnt=%" IVdf "\n", + PTR2UV(ptr),(IV)cnt)); - if (i == EOF) /* all done for ever? */ - goto thats_really_all_folks; + if (i == EOF) /* all done for ever? */ + goto thats_really_all_folks; /* make sure we have enough space in the target sv */ - bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ - SvCUR_set(sv, bpx); - SvGROW(sv, bpx + cnt + 2); - bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ + bpx = bp - (STDCHAR*)SvPVX_const(sv); /* box up before relocation */ + SvCUR_set(sv, bpx); + SvGROW(sv, bpx + cnt + 2); + bp = (STDCHAR*)SvPVX_const(sv) + bpx; /* unbox after relocation */ /* copy of the char we got from getc() */ - *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */ + *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */ /* make sure we deal with the i being the last character of a separator */ - if (rslen && (STDCHAR)i == rslast) /* all done for now? */ - goto thats_all_folks; + if (rslen && (STDCHAR)i == rslast) /* all done for now? */ + goto thats_all_folks; } thats_all_folks: /* check if we have actually found the separator - only really applies * when rslen > 1 */ if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX_const(sv)) < rslen) || - memNE((char*)bp - rslen, rsptr, rslen)) - goto screamer; /* go back to the fray */ + memNE((char*)bp - rslen, rsptr, rslen)) + goto screamer; /* go back to the fray */ thats_really_all_folks: if (shortbuffered) - cnt += shortbuffered; - DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: quitting, ptr=%" UVuf ", cnt=%" IVdf "\n",PTR2UV(ptr),(IV)cnt)); + cnt += shortbuffered; + DEBUG_P(PerlIO_printf(Perl_debug_log, + "Screamer: quitting, ptr=%" UVuf ", cnt=%" IVdf "\n",PTR2UV(ptr),(IV)cnt)); PerlIO_set_ptrcnt(fp, (STDCHAR*)ptr, cnt); /* put these back or we're in trouble */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: end: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf - "\n", - PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), - PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); + "Screamer: end: FILE * thinks ptr=%" UVuf ", cnt=%" IVdf ", base=%" UVuf + "\n", + PTR2UV(PerlIO_get_ptr(fp)), (IV)PerlIO_get_cnt(fp), + PTR2UV(PerlIO_has_base (fp) ? PerlIO_get_base(fp) : 0))); *bp = '\0'; SvCUR_set(sv, bp - (STDCHAR*)SvPVX_const(sv)); /* set length */ DEBUG_P(PerlIO_printf(Perl_debug_log, - "Screamer: done, len=%ld, string=|%.*s|\n", - (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv))); + "Screamer: done, len=%ld, string=|%.*s|\n", + (long)SvCUR(sv),(int)SvCUR(sv),SvPVX_const(sv))); } else { /*The big, slow, and stupid way. */ - STDCHAR buf[8192]; + STDCHAR buf[8192]; screamer2: - if (rslen) { + if (rslen) { const STDCHAR * const bpe = buf + sizeof(buf); - bp = buf; - while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) - ; /* keep reading */ - cnt = bp - buf; - } - else { - cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); - /* Accommodate broken VAXC compiler, which applies U8 cast to - * both args of ?: operator, causing EOF to change into 255 - */ - if (cnt > 0) - i = (U8)buf[cnt - 1]; - else - i = EOF; - } - - if (cnt < 0) - cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */ - if (append) + bp = buf; + while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) + ; /* keep reading */ + cnt = bp - buf; + } + else { + cnt = PerlIO_read(fp,(char*)buf, sizeof(buf)); + /* Accommodate broken VAXC compiler, which applies U8 cast to + * both args of ?: operator, causing EOF to change into 255 + */ + if (cnt > 0) + i = (U8)buf[cnt - 1]; + else + i = EOF; + } + + if (cnt < 0) + cnt = 0; /* we do need to re-set the sv even when cnt <= 0 */ + if (append) sv_catpvn_nomg(sv, (char *) buf, cnt); - else + else sv_setpvn(sv, (char *) buf, cnt); /* "nomg" is implied */ - if (i != EOF && /* joy */ - (!rslen || - SvCUR(sv) < rslen || - memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen))) - { - append = -1; - /* - * If we're reading from a TTY and we get a short read, - * indicating that the user hit his EOF character, we need - * to notice it now, because if we try to read from the TTY - * again, the EOF condition will disappear. - * - * The comparison of cnt to sizeof(buf) is an optimization - * that prevents unnecessary calls to feof(). - * - * - jik 9/25/96 - */ - if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp))) - goto screamer2; - } + if (i != EOF && /* joy */ + (!rslen || + SvCUR(sv) < rslen || + memNE(SvPVX_const(sv) + SvCUR(sv) - rslen, rsptr, rslen))) + { + append = -1; + /* + * If we're reading from a TTY and we get a short read, + * indicating that the user hit his EOF character, we need + * to notice it now, because if we try to read from the TTY + * again, the EOF condition will disappear. + * + * The comparison of cnt to sizeof(buf) is an optimization + * that prevents unnecessary calls to feof(). + * + * - jik 9/25/96 + */ + if (!(cnt < (I32)sizeof(buf) && PerlIO_eof(fp))) + goto screamer2; + } } if (rspara) { /* have to do this both before and after */ while (i != EOF) { /* to make sure file boundaries work right */ - i = PerlIO_getc(fp); - if (i != '\n') { - PerlIO_ungetc(fp,i); - break; - } - } + i = PerlIO_getc(fp); + if (i != '\n') { + PerlIO_ungetc(fp,i); + break; + } + } } return (SvCUR(sv) - append) ? SvPVX(sv) : NULL; @@ -8891,7 +8891,7 @@ void Perl_sv_inc(pTHX_ SV *const sv) { if (!sv) - return; + return; SvGETMAGIC(sv); sv_inc_nomg(sv); } @@ -8903,52 +8903,52 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) int flags; if (!sv) - return; + return; if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) { - Perl_croak_no_modify(); - } - if (SvROK(sv)) { - IV i; - if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg)) - return; - i = PTR2IV(SvRV(sv)); - sv_unref(sv); - sv_setiv(sv, i); - } - else sv_force_normal_flags(sv, 0); + if (SvREADONLY(sv)) { + Perl_croak_no_modify(); + } + if (SvROK(sv)) { + IV i; + if (SvAMAGIC(sv) && AMG_CALLunary(sv, inc_amg)) + return; + i = PTR2IV(SvRV(sv)); + sv_unref(sv); + sv_setiv(sv, i); + } + else sv_force_normal_flags(sv, 0); } flags = SvFLAGS(sv); if ((flags & (SVp_NOK|SVp_IOK)) == SVp_NOK) { - /* It's (privately or publicly) a float, but not tested as an - integer, so test it to see. */ - (void) SvIV(sv); - flags = SvFLAGS(sv); + /* It's (privately or publicly) a float, but not tested as an + integer, so test it to see. */ + (void) SvIV(sv); + flags = SvFLAGS(sv); } if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { - /* It's publicly an integer, or privately an integer-not-float */ + /* It's publicly an integer, or privately an integer-not-float */ #ifdef PERL_PRESERVE_IVUV oops_its_int: #endif - if (SvIsUV(sv)) { - if (SvUVX(sv) == UV_MAX) - sv_setnv(sv, UV_MAX_P1); + if (SvIsUV(sv)) { + if (SvUVX(sv) == UV_MAX) + sv_setnv(sv, UV_MAX_P1); else { - (void)SvIOK_only_UV(sv); - SvUV_set(sv, SvUVX(sv) + 1); + (void)SvIOK_only_UV(sv); + SvUV_set(sv, SvUVX(sv) + 1); } - } else { - if (SvIVX(sv) == IV_MAX) - sv_setuv(sv, (UV)IV_MAX + 1); - else { - (void)SvIOK_only(sv); - SvIV_set(sv, SvIVX(sv) + 1); - } - } - return; + } else { + if (SvIVX(sv) == IV_MAX) + sv_setuv(sv, (UV)IV_MAX + 1); + else { + (void)SvIOK_only(sv); + SvIV_set(sv, SvIVX(sv) + 1); + } + } + return; } if (flags & SVp_NOK) { - const NV was = SvNVX(sv); + const NV was = SvNVX(sv); if (NV_OVERFLOWS_INTEGERS_AT != 0.0 && /* If NVX was NaN, the following comparisons return always false */ UNLIKELY(was >= NV_OVERFLOWS_INTEGERS_AT || @@ -8959,14 +8959,14 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) LIKELY(!Perl_isinf(was)) #endif ) { - /* diag_listed_as: Lost precision when %s %f by 1 */ - Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), - "Lost precision when incrementing %" NVff " by 1", - was); - } - (void)SvNOK_only(sv); + /* diag_listed_as: Lost precision when %s %f by 1 */ + Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), + "Lost precision when incrementing %" NVff " by 1", + was); + } + (void)SvNOK_only(sv); SvNV_set(sv, was + 1.0); - return; + return; } /* treat AV/HV/CV/FM/IO and non-fake GVs as immutable */ @@ -8974,88 +8974,88 @@ Perl_sv_inc_nomg(pTHX_ SV *const sv) Perl_croak_no_modify(); if (!(flags & SVp_POK) || !*SvPVX_const(sv)) { - if ((flags & SVTYPEMASK) < SVt_PVIV) - sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV)); - (void)SvIOK_only(sv); - SvIV_set(sv, 1); - return; + if ((flags & SVTYPEMASK) < SVt_PVIV) + sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV ? SVt_PVIV : SVt_IV)); + (void)SvIOK_only(sv); + SvIV_set(sv, 1); + return; } d = SvPVX(sv); while (isALPHA(*d)) d++; while (isDIGIT(*d)) d++; if (d < SvEND(sv)) { - const int numtype = grok_number_flags(SvPVX_const(sv), SvCUR(sv), NULL, PERL_SCAN_TRAILING); + const int numtype = grok_number_flags(SvPVX_const(sv), SvCUR(sv), NULL, PERL_SCAN_TRAILING); #ifdef PERL_PRESERVE_IVUV - /* Got to punt this as an integer if needs be, but we don't issue - warnings. Probably ought to make the sv_iv_please() that does - the conversion if possible, and silently. */ - if (numtype && !(numtype & IS_NUMBER_INFINITY)) { - /* Need to try really hard to see if it's an integer. - 9.22337203685478e+18 is an integer. - but "9.22337203685478e+18" + 0 is UV=9223372036854779904 - so $a="9.22337203685478e+18"; $a+0; $a++ - needs to be the same as $a="9.22337203685478e+18"; $a++ - or we go insane. */ - - (void) sv_2iv(sv); - if (SvIOK(sv)) - goto oops_its_int; - - /* sv_2iv *should* have made this an NV */ - if (flags & SVp_NOK) { - (void)SvNOK_only(sv); + /* Got to punt this as an integer if needs be, but we don't issue + warnings. Probably ought to make the sv_iv_please() that does + the conversion if possible, and silently. */ + if (numtype && !(numtype & IS_NUMBER_INFINITY)) { + /* Need to try really hard to see if it's an integer. + 9.22337203685478e+18 is an integer. + but "9.22337203685478e+18" + 0 is UV=9223372036854779904 + so $a="9.22337203685478e+18"; $a+0; $a++ + needs to be the same as $a="9.22337203685478e+18"; $a++ + or we go insane. */ + + (void) sv_2iv(sv); + if (SvIOK(sv)) + goto oops_its_int; + + /* sv_2iv *should* have made this an NV */ + if (flags & SVp_NOK) { + (void)SvNOK_only(sv); SvNV_set(sv, SvNVX(sv) + 1.0); - return; - } - /* I don't think we can get here. Maybe I should assert this - And if we do get here I suspect that sv_setnv will croak. NWC - Fall through. */ - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%" UVxf " NV=%" NVgf "\n", - SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); - } + return; + } + /* I don't think we can get here. Maybe I should assert this + And if we do get here I suspect that sv_setnv will croak. NWC + Fall through. */ + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_inc punt failed to convert '%s' to IOK or NOKp, UV=0x%" UVxf " NV=%" NVgf "\n", + SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); + } #endif /* PERL_PRESERVE_IVUV */ if (!numtype && ckWARN(WARN_NUMERIC)) not_incrementable(sv); - sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0); - return; + sv_setnv(sv,Atof(SvPVX_const(sv)) + 1.0); + return; } d--; while (d >= SvPVX_const(sv)) { - if (isDIGIT(*d)) { - if (++*d <= '9') - return; - *(d--) = '0'; - } - else { + if (isDIGIT(*d)) { + if (++*d <= '9') + return; + *(d--) = '0'; + } + else { #ifdef EBCDIC - /* MKS: The original code here died if letters weren't consecutive. - * at least it didn't have to worry about non-C locales. The - * new code assumes that ('z'-'a')==('Z'-'A'), letters are - * arranged in order (although not consecutively) and that only - * [A-Za-z] are accepted by isALPHA in the C locale. - */ - if (isALPHA_FOLD_NE(*d, 'z')) { - do { ++*d; } while (!isALPHA(*d)); - return; - } - *(d--) -= 'z' - 'a'; + /* MKS: The original code here died if letters weren't consecutive. + * at least it didn't have to worry about non-C locales. The + * new code assumes that ('z'-'a')==('Z'-'A'), letters are + * arranged in order (although not consecutively) and that only + * [A-Za-z] are accepted by isALPHA in the C locale. + */ + if (isALPHA_FOLD_NE(*d, 'z')) { + do { ++*d; } while (!isALPHA(*d)); + return; + } + *(d--) -= 'z' - 'a'; #else - ++*d; - if (isALPHA(*d)) - return; - *(d--) -= 'z' - 'a' + 1; + ++*d; + if (isALPHA(*d)) + return; + *(d--) -= 'z' - 'a' + 1; #endif - } + } } /* oh,oh, the number grew */ SvGROW(sv, SvCUR(sv) + 2); SvCUR_set(sv, SvCUR(sv) + 1); for (d = SvPVX(sv) + SvCUR(sv); d > SvPVX_const(sv); d--) - *d = d[-1]; + *d = d[-1]; if (isDIGIT(d[1])) - *d = '1'; + *d = '1'; else - *d = d[1]; + *d = d[1]; } /* @@ -9076,7 +9076,7 @@ void Perl_sv_dec(pTHX_ SV *const sv) { if (!sv) - return; + return; SvGETMAGIC(sv); sv_dec_nomg(sv); } @@ -9087,54 +9087,54 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv) int flags; if (!sv) - return; + return; if (SvTHINKFIRST(sv)) { - if (SvREADONLY(sv)) { - Perl_croak_no_modify(); - } - if (SvROK(sv)) { - IV i; - if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg)) - return; - i = PTR2IV(SvRV(sv)); - sv_unref(sv); - sv_setiv(sv, i); - } - else sv_force_normal_flags(sv, 0); + if (SvREADONLY(sv)) { + Perl_croak_no_modify(); + } + if (SvROK(sv)) { + IV i; + if (SvAMAGIC(sv) && AMG_CALLunary(sv, dec_amg)) + return; + i = PTR2IV(SvRV(sv)); + sv_unref(sv); + sv_setiv(sv, i); + } + else sv_force_normal_flags(sv, 0); } /* Unlike sv_inc we don't have to worry about string-never-numbers and keeping them magic. But we mustn't warn on punting */ flags = SvFLAGS(sv); if ((flags & SVf_IOK) || ((flags & (SVp_IOK | SVp_NOK)) == SVp_IOK)) { - /* It's publicly an integer, or privately an integer-not-float */ + /* It's publicly an integer, or privately an integer-not-float */ #ifdef PERL_PRESERVE_IVUV oops_its_int: #endif - if (SvIsUV(sv)) { - if (SvUVX(sv) == 0) { - (void)SvIOK_only(sv); - SvIV_set(sv, -1); - } - else { - (void)SvIOK_only_UV(sv); - SvUV_set(sv, SvUVX(sv) - 1); - } - } else { - 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); - } - } - return; + if (SvIsUV(sv)) { + if (SvUVX(sv) == 0) { + (void)SvIOK_only(sv); + SvIV_set(sv, -1); + } + else { + (void)SvIOK_only_UV(sv); + SvUV_set(sv, SvUVX(sv) - 1); + } + } else { + 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); + } + } + return; } if (flags & SVp_NOK) { oops_its_num: - { - const NV was = SvNVX(sv); + { + const NV was = SvNVX(sv); if (NV_OVERFLOWS_INTEGERS_AT != 0.0 && /* If NVX was NaN, these comparisons return always false */ UNLIKELY(was <= -NV_OVERFLOWS_INTEGERS_AT || @@ -9145,15 +9145,15 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv) LIKELY(!Perl_isinf(was)) #endif ) { - /* diag_listed_as: Lost precision when %s %f by 1 */ - Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), - "Lost precision when decrementing %" NVff " by 1", - was); - } - (void)SvNOK_only(sv); - SvNV_set(sv, was - 1.0); - return; - } + /* diag_listed_as: Lost precision when %s %f by 1 */ + Perl_ck_warner(aTHX_ packWARN(WARN_IMPRECISION), + "Lost precision when decrementing %" NVff " by 1", + was); + } + (void)SvNOK_only(sv); + SvNV_set(sv, was - 1.0); + return; + } } /* treat AV/HV/CV/FM/IO and non-fake GVs as immutable */ @@ -9161,39 +9161,39 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv) Perl_croak_no_modify(); if (!(flags & SVp_POK)) { - if ((flags & SVTYPEMASK) < SVt_PVIV) - sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV); - SvIV_set(sv, -1); - (void)SvIOK_only(sv); - return; + if ((flags & SVTYPEMASK) < SVt_PVIV) + sv_upgrade(sv, ((flags & SVTYPEMASK) > SVt_IV) ? SVt_PVIV : SVt_IV); + SvIV_set(sv, -1); + (void)SvIOK_only(sv); + return; } #ifdef PERL_PRESERVE_IVUV { - const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); - if (numtype && !(numtype & IS_NUMBER_INFINITY)) { - /* Need to try really hard to see if it's an integer. - 9.22337203685478e+18 is an integer. - but "9.22337203685478e+18" + 0 is UV=9223372036854779904 - so $a="9.22337203685478e+18"; $a+0; $a-- - needs to be the same as $a="9.22337203685478e+18"; $a-- - or we go insane. */ - - (void) sv_2iv(sv); - if (SvIOK(sv)) - goto oops_its_int; - - /* sv_2iv *should* have made this an NV */ - if (flags & SVp_NOK) { - (void)SvNOK_only(sv); + const int numtype = grok_number(SvPVX_const(sv), SvCUR(sv), NULL); + if (numtype && !(numtype & IS_NUMBER_INFINITY)) { + /* Need to try really hard to see if it's an integer. + 9.22337203685478e+18 is an integer. + but "9.22337203685478e+18" + 0 is UV=9223372036854779904 + so $a="9.22337203685478e+18"; $a+0; $a-- + needs to be the same as $a="9.22337203685478e+18"; $a-- + or we go insane. */ + + (void) sv_2iv(sv); + if (SvIOK(sv)) + goto oops_its_int; + + /* sv_2iv *should* have made this an NV */ + if (flags & SVp_NOK) { + (void)SvNOK_only(sv); SvNV_set(sv, SvNVX(sv) - 1.0); - return; - } - /* I don't think we can get here. Maybe I should assert this - And if we do get here I suspect that sv_setnv will croak. NWC - Fall through. */ - DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%" UVxf " NV=%" NVgf "\n", - SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); - } + return; + } + /* I don't think we can get here. Maybe I should assert this + And if we do get here I suspect that sv_setnv will croak. NWC + Fall through. */ + DEBUG_c(PerlIO_printf(Perl_debug_log,"sv_dec punt failed to convert '%s' to IOK or NOKp, UV=0x%" UVxf " NV=%" NVgf "\n", + SvPVX_const(sv), SvIVX(sv), SvNVX(sv))); + } } #endif /* PERL_PRESERVE_IVUV */ sv_setnv(sv,Atof(SvPVX_const(sv)) - 1.0); /* punt */ @@ -9205,10 +9205,10 @@ Perl_sv_dec_nomg(pTHX_ SV *const sv) */ #define PUSH_EXTEND_MORTAL__SV_C(AnSv) \ STMT_START { \ - SSize_t ix = ++PL_tmps_ix; \ - if (UNLIKELY(ix >= PL_tmps_max)) \ - ix = tmps_grow_p(ix); \ - PL_tmps_stack[ix] = (AnSv); \ + SSize_t ix = ++PL_tmps_ix; \ + if (UNLIKELY(ix >= PL_tmps_max)) \ + ix = tmps_grow_p(ix); \ + PL_tmps_stack[ix] = (AnSv); \ } STMT_END /* @@ -9238,7 +9238,7 @@ Perl_sv_mortalcopy_flags(pTHX_ SV *const oldstr, U32 flags) SV *sv; if (flags & SV_GMAGIC) - SvGETMAGIC(oldstr); /* before new_SV, in case it dies */ + SvGETMAGIC(oldstr); /* before new_SV, in case it dies */ new_SV(sv); sv_setsv_flags(sv,oldstr,flags & ~SV_GMAGIC); PUSH_EXTEND_MORTAL__SV_C(sv); @@ -9285,7 +9285,7 @@ C flag 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) + newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) =for apidoc Amnh||SVs_TEMP @@ -9314,7 +9314,7 @@ Perl_newSVpvn_flags(pTHX_ const char *const s, const STRLEN len, const U32 flags SvFLAGS(sv) |= flags; if(flags & SVs_TEMP){ - PUSH_EXTEND_MORTAL__SV_C(sv); + PUSH_EXTEND_MORTAL__SV_C(sv); } return sv; @@ -9336,9 +9336,9 @@ SV * Perl_sv_2mortal(pTHX_ SV *const sv) { if (!sv) - return sv; + return sv; if (SvIMMORTAL(sv)) - return sv; + return sv; PUSH_EXTEND_MORTAL__SV_C(sv); SvTEMP_on(sv); return sv; @@ -9411,54 +9411,54 @@ SV * Perl_newSVhek(pTHX_ const HEK *const hek) { if (!hek) { - SV *sv; + SV *sv; - new_SV(sv); - return sv; + new_SV(sv); + return sv; } if (HEK_LEN(hek) == HEf_SVKEY) { - return newSVsv(*(SV**)HEK_KEY(hek)); + return newSVsv(*(SV**)HEK_KEY(hek)); } else { - const int flags = HEK_FLAGS(hek); - if (flags & HVhek_WASUTF8) { - /* Trouble :-) - Andreas would like keys he put in as utf8 to come back as utf8 - */ - STRLEN utf8_len = HEK_LEN(hek); - SV * const sv = newSV_type(SVt_PV); - char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); - /* bytes_to_utf8() allocates a new string, which we can repurpose: */ - sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL); - SvUTF8_on (sv); - return sv; + const int flags = HEK_FLAGS(hek); + if (flags & HVhek_WASUTF8) { + /* Trouble :-) + Andreas would like keys he put in as utf8 to come back as utf8 + */ + STRLEN utf8_len = HEK_LEN(hek); + SV * const sv = newSV_type(SVt_PV); + char *as_utf8 = (char *)bytes_to_utf8 ((U8*)HEK_KEY(hek), &utf8_len); + /* bytes_to_utf8() allocates a new string, which we can repurpose: */ + sv_usepvn_flags(sv, as_utf8, utf8_len, SV_HAS_TRAILING_NUL); + SvUTF8_on (sv); + return sv; } else if (flags & HVhek_UNSHARED) { /* A hash that isn't using shared hash keys has to have - the flag in every key so that we know not to try to call - share_hek_hek on it. */ - - SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); - if (HEK_UTF8(hek)) - SvUTF8_on (sv); - return sv; - } - /* This will be overwhelminly the most common case. */ - { - /* Inline most of newSVpvn_share(), because share_hek_hek() is far - more efficient than sharepvn(). */ - SV *sv; - - new_SV(sv); - sv_upgrade(sv, SVt_PV); - SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek))); - SvCUR_set(sv, HEK_LEN(hek)); - SvLEN_set(sv, 0); - SvIsCOW_on(sv); - SvPOK_on(sv); - if (HEK_UTF8(hek)) - SvUTF8_on(sv); - return sv; - } + the flag in every key so that we know not to try to call + share_hek_hek on it. */ + + SV * const sv = newSVpvn (HEK_KEY(hek), HEK_LEN(hek)); + if (HEK_UTF8(hek)) + SvUTF8_on (sv); + return sv; + } + /* This will be overwhelminly the most common case. */ + { + /* Inline most of newSVpvn_share(), because share_hek_hek() is far + more efficient than sharepvn(). */ + SV *sv; + + new_SV(sv); + sv_upgrade(sv, SVt_PV); + SvPV_set(sv, (char *)HEK_KEY(share_hek_hek(hek))); + SvCUR_set(sv, HEK_LEN(hek)); + SvLEN_set(sv, 0); + SvIsCOW_on(sv); + SvPOK_on(sv); + if (HEK_UTF8(hek)) + SvUTF8_on(sv); + return sv; + } } } @@ -9486,14 +9486,14 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) const char *const orig_src = src; if (len < 0) { - STRLEN tmplen = -len; + STRLEN tmplen = -len; is_utf8 = TRUE; - /* See the note in hv.c:hv_fetch() --jhi */ - src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8); - len = tmplen; + /* See the note in hv.c:hv_fetch() --jhi */ + src = (char*)bytes_from_utf8((const U8*)src, &tmplen, &is_utf8); + len = tmplen; } if (!hash) - PERL_HASH(hash, src, len); + 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. */ @@ -9506,7 +9506,7 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) if (is_utf8) SvUTF8_on(sv); if (src != orig_src) - Safefree(src); + Safefree(src); return sv; } @@ -9665,7 +9665,7 @@ Perl_newSVuv(pTHX_ const UV u) /* Using ivs is more efficient than using uvs - see sv_setuv */ if (u <= (UV)IV_MAX) { - return newSViv((IV)u); + return newSViv((IV)u); } new_SV(sv); @@ -9703,7 +9703,7 @@ Perl_newSV_type(pTHX_ const svtype type) new_SV(sv); ASSUME(SvTYPE(sv) == SVt_FIRST); if(type != SVt_FIRST) - sv_upgrade(sv, type); + sv_upgrade(sv, type); return sv; } @@ -9774,10 +9774,10 @@ Perl_newSVsv_flags(pTHX_ SV *const old, I32 flags) SV *sv; if (!old) - return NULL; + return NULL; if (SvTYPE(old) == (svtype)SVTYPEMASK) { - Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); - return NULL; + Perl_ck_warner_d(aTHX_ packWARN(WARN_INTERNAL), "semi-panic: attempt to dup freed string"); + return NULL; } /* Do this here, otherwise we leak the new SV if this croaks. */ if (flags & SV_GMAGIC) @@ -9811,71 +9811,71 @@ Perl_sv_resetpvn(pTHX_ const char *s, STRLEN len, HV * const stash) const char *send; if (!stash || SvTYPE(stash) != SVt_PVHV) - return; + return; if (!s) { /* reset ?? searches */ - 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; - PMOP *const *const end = pmp + count; + 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; + PMOP *const *const end = pmp + count; - while (pmp < end) { + while (pmp < end) { #ifdef USE_ITHREADS SvREADONLY_off(PL_regex_pad[(*pmp)->op_pmoffset]); #else - (*pmp)->op_pmflags &= ~PMf_USED; + (*pmp)->op_pmflags &= ~PMf_USED; #endif - ++pmp; - } - } - return; + ++pmp; + } + } + return; } /* reset variables */ if (!HvARRAY(stash)) - return; + return; Zero(todo, 256, char); send = s + len; while (s < send) { - I32 max; - I32 i = (unsigned char)*s; - if (s[1] == '-') { - s += 2; - } - max = (unsigned char)*s++; - for ( ; i <= max; i++) { - todo[i] = 1; - } - for (i = 0; i <= (I32) HvMAX(stash); i++) { - HE *entry; - for (entry = HvARRAY(stash)[i]; - entry; - entry = HeNEXT(entry)) - { - GV *gv; - SV *sv; - - if (!todo[(U8)*HeKEY(entry)]) - continue; - gv = MUTABLE_GV(HeVAL(entry)); - if (!isGV(gv)) - continue; - sv = GvSV(gv); - if (sv && !SvREADONLY(sv)) { - SV_CHECK_THINKFIRST_COW_DROP(sv); - if (!isGV(sv)) SvOK_off(sv); - } - if (GvAV(gv)) { - av_clear(GvAV(gv)); - } - if (GvHV(gv) && !HvNAME_get(GvHV(gv))) { - hv_clear(GvHV(gv)); - } - } - } + I32 max; + I32 i = (unsigned char)*s; + if (s[1] == '-') { + s += 2; + } + max = (unsigned char)*s++; + for ( ; i <= max; i++) { + todo[i] = 1; + } + for (i = 0; i <= (I32) HvMAX(stash); i++) { + HE *entry; + for (entry = HvARRAY(stash)[i]; + entry; + entry = HeNEXT(entry)) + { + GV *gv; + SV *sv; + + if (!todo[(U8)*HeKEY(entry)]) + continue; + gv = MUTABLE_GV(HeVAL(entry)); + if (!isGV(gv)) + continue; + sv = GvSV(gv); + if (sv && !SvREADONLY(sv)) { + SV_CHECK_THINKFIRST_COW_DROP(sv); + if (!isGV(sv)) SvOK_off(sv); + } + if (GvAV(gv)) { + av_clear(GvAV(gv)); + } + if (GvHV(gv) && !HvNAME_get(GvHV(gv))) { + hv_clear(GvHV(gv)); + } + } + } } } @@ -9902,40 +9902,40 @@ Perl_sv_2io(pTHX_ SV *const sv) switch (SvTYPE(sv)) { case SVt_PVIO: - io = MUTABLE_IO(sv); - break; + io = MUTABLE_IO(sv); + break; case SVt_PVGV: case SVt_PVLV: - if (isGV_with_GP(sv)) { - gv = MUTABLE_GV(sv); - io = GvIO(gv); - if (!io) - Perl_croak(aTHX_ "Bad filehandle: %" HEKf, + if (isGV_with_GP(sv)) { + gv = MUTABLE_GV(sv); + io = GvIO(gv); + if (!io) + Perl_croak(aTHX_ "Bad filehandle: %" HEKf, HEKfARG(GvNAME_HEK(gv))); - break; - } - /* FALLTHROUGH */ + break; + } + /* FALLTHROUGH */ default: - if (!SvOK(sv)) - Perl_croak(aTHX_ PL_no_usym, "filehandle"); - if (SvROK(sv)) { - SvGETMAGIC(SvRV(sv)); - return sv_2io(SvRV(sv)); - } - gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO); - if (gv) - io = GvIO(gv); - else - io = 0; - if (!io) { - SV *newsv = sv; - if (SvGMAGICAL(sv)) { - newsv = sv_newmortal(); - sv_setsv_nomg(newsv, sv); - } - Perl_croak(aTHX_ "Bad filehandle: %" SVf, SVfARG(newsv)); - } - break; + if (!SvOK(sv)) + Perl_croak(aTHX_ PL_no_usym, "filehandle"); + if (SvROK(sv)) { + SvGETMAGIC(SvRV(sv)); + return sv_2io(SvRV(sv)); + } + gv = gv_fetchsv_nomg(sv, 0, SVt_PVIO); + if (gv) + io = GvIO(gv); + else + io = 0; + if (!io) { + SV *newsv = sv; + if (SvGMAGICAL(sv)) { + newsv = sv_newmortal(); + sv_setsv_nomg(newsv, sv); + } + Perl_croak(aTHX_ "Bad filehandle: %" SVf, SVfARG(newsv)); + } + break; } return io; } @@ -9959,62 +9959,62 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) PERL_ARGS_ASSERT_SV_2CV; if (!sv) { - *st = NULL; - *gvp = NULL; - return NULL; + *st = NULL; + *gvp = NULL; + return NULL; } switch (SvTYPE(sv)) { case SVt_PVCV: - *st = CvSTASH(sv); - *gvp = NULL; - return MUTABLE_CV(sv); + *st = CvSTASH(sv); + *gvp = NULL; + return MUTABLE_CV(sv); case SVt_PVHV: case SVt_PVAV: - *st = NULL; - *gvp = NULL; - return NULL; + *st = NULL; + *gvp = NULL; + return NULL; default: - SvGETMAGIC(sv); - if (SvROK(sv)) { - if (SvAMAGIC(sv)) - sv = amagic_deref_call(sv, to_cv_amg); - - sv = SvRV(sv); - if (SvTYPE(sv) == SVt_PVCV) { - cv = MUTABLE_CV(sv); - *gvp = NULL; - *st = CvSTASH(cv); - return cv; - } - else if(SvGETMAGIC(sv), isGV_with_GP(sv)) - gv = MUTABLE_GV(sv); - else - Perl_croak(aTHX_ "Not a subroutine reference"); - } - else if (isGV_with_GP(sv)) { - gv = MUTABLE_GV(sv); - } - else { - gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV); - } - *gvp = gv; - if (!gv) { - *st = NULL; - return NULL; - } - /* Some flags to gv_fetchsv mean don't really create the GV */ - if (!isGV_with_GP(gv)) { - *st = NULL; - return NULL; - } - *st = GvESTASH(gv); - if (lref & ~GV_ADDMG && !GvCVu(gv)) { - /* XXX this is probably not what they think they're getting. - * It has the same effect as "sub name;", i.e. just a forward - * declaration! */ - newSTUB(gv,0); - } - return GvCVu(gv); + SvGETMAGIC(sv); + if (SvROK(sv)) { + if (SvAMAGIC(sv)) + sv = amagic_deref_call(sv, to_cv_amg); + + sv = SvRV(sv); + if (SvTYPE(sv) == SVt_PVCV) { + cv = MUTABLE_CV(sv); + *gvp = NULL; + *st = CvSTASH(cv); + return cv; + } + else if(SvGETMAGIC(sv), isGV_with_GP(sv)) + gv = MUTABLE_GV(sv); + else + Perl_croak(aTHX_ "Not a subroutine reference"); + } + else if (isGV_with_GP(sv)) { + gv = MUTABLE_GV(sv); + } + else { + gv = gv_fetchsv_nomg(sv, lref, SVt_PVCV); + } + *gvp = gv; + if (!gv) { + *st = NULL; + return NULL; + } + /* Some flags to gv_fetchsv mean don't really create the GV */ + if (!isGV_with_GP(gv)) { + *st = NULL; + return NULL; + } + *st = GvESTASH(gv); + if (lref & ~GV_ADDMG && !GvCVu(gv)) { + /* XXX this is probably not what they think they're getting. + * It has the same effect as "sub name;", i.e. just a forward + * declaration! */ + newSTUB(gv,0); + } + return GvCVu(gv); } } @@ -10032,25 +10032,25 @@ I32 Perl_sv_true(pTHX_ SV *const sv) { if (!sv) - return 0; + return 0; if (SvPOK(sv)) { - const XPV* const tXpv = (XPV*)SvANY(sv); - if (tXpv && - (tXpv->xpv_cur > 1 || - (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0'))) - return 1; - else - return 0; + const XPV* const tXpv = (XPV*)SvANY(sv); + if (tXpv && + (tXpv->xpv_cur > 1 || + (tXpv->xpv_cur && *sv->sv_u.svu_pv != '0'))) + return 1; + else + return 0; } else { - if (SvIOK(sv)) - return SvIVX(sv) != 0; - else { - if (SvNOK(sv)) - return SvNVX(sv) != 0.0; - else - return sv_2bool(sv); - } + if (SvIOK(sv)) + return SvIVX(sv) != 0; + else { + if (SvNOK(sv)) + return SvNVX(sv) != 0.0; + else + return sv_2bool(sv); + } } } @@ -10083,41 +10083,41 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const U32 flags) sv_force_normal_flags(sv, 0); if (SvPOK(sv)) { - if (lp) - *lp = SvCUR(sv); + if (lp) + *lp = SvCUR(sv); } else { - char *s; - STRLEN len; - - if (SvTYPE(sv) > SVt_PVLV - || isGV_with_GP(sv)) - /* diag_listed_as: Can't coerce %s to %s in %s */ - Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), - OP_DESC(PL_op)); - s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC); - if (!s) { - s = (char *)""; - } - if (lp) - *lp = len; + char *s; + STRLEN len; + + if (SvTYPE(sv) > SVt_PVLV + || isGV_with_GP(sv)) + /* diag_listed_as: Can't coerce %s to %s in %s */ + Perl_croak(aTHX_ "Can't coerce %s to string in %s", sv_reftype(sv,0), + OP_DESC(PL_op)); + s = sv_2pv_flags(sv, &len, flags &~ SV_GMAGIC); + if (!s) { + s = (char *)""; + } + if (lp) + *lp = len; if (SvTYPE(sv) < SVt_PV || s != SvPVX_const(sv)) { /* Almost, but not quite, sv_setpvn() */ - if (SvROK(sv)) - sv_unref(sv); - SvUPGRADE(sv, SVt_PV); /* Never FALSE */ - SvGROW(sv, len + 1); - Move(s,SvPVX(sv),len,char); - SvCUR_set(sv, len); - SvPVX(sv)[len] = '\0'; - } - if (!SvPOK(sv)) { - SvPOK_on(sv); /* validate pointer */ - SvTAINT(sv); - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n", - PTR2UV(sv),SvPVX_const(sv))); - } + if (SvROK(sv)) + sv_unref(sv); + SvUPGRADE(sv, SVt_PV); /* Never FALSE */ + SvGROW(sv, len + 1); + Move(s,SvPVX(sv),len,char); + SvCUR_set(sv, len); + SvPVX(sv)[len] = '\0'; + } + if (!SvPOK(sv)) { + SvPOK_on(sv); /* validate pointer */ + SvTAINT(sv); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%" UVxf " 2pv(%s)\n", + PTR2UV(sv),SvPVX_const(sv))); + } } (void)SvPOK_only_UTF8(sv); return SvPVX_mutable(sv); @@ -10179,7 +10179,7 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) { PERL_ARGS_ASSERT_SV_REFTYPE; if (ob && SvOBJECT(sv)) { - return SvPV_nolen_const(sv_ref(NULL, sv, ob)); + return SvPV_nolen_const(sv_ref(NULL, sv, ob)); } else { /* WARNING - There is code, for instance in mg.c, that assumes that @@ -10190,37 +10190,37 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) * Do not change this assumption without searching for "dodgy type check" in * the code. * - Yves */ - switch (SvTYPE(sv)) { - case SVt_NULL: - case SVt_IV: - case SVt_NV: - case SVt_PV: - case SVt_PVIV: - case SVt_PVNV: - case SVt_PVMG: - if (SvVOK(sv)) - return "VSTRING"; - if (SvROK(sv)) - return "REF"; - else - return "SCALAR"; - - case SVt_PVLV: return (char *) (SvROK(sv) ? "REF" - /* tied lvalues should appear to be - * scalars for backwards compatibility */ - : (isALPHA_FOLD_EQ(LvTYPE(sv), 't')) - ? "SCALAR" : "LVALUE"); - case SVt_PVAV: return "ARRAY"; - case SVt_PVHV: return "HASH"; - case SVt_PVCV: return "CODE"; - case SVt_PVGV: return (char *) (isGV_with_GP(sv) - ? "GLOB" : "SCALAR"); - case SVt_PVFM: return "FORMAT"; - case SVt_PVIO: return "IO"; - case SVt_INVLIST: return "INVLIST"; - case SVt_REGEXP: return "REGEXP"; - default: return "UNKNOWN"; - } + switch (SvTYPE(sv)) { + case SVt_NULL: + case SVt_IV: + case SVt_NV: + case SVt_PV: + case SVt_PVIV: + case SVt_PVNV: + case SVt_PVMG: + if (SvVOK(sv)) + return "VSTRING"; + if (SvROK(sv)) + return "REF"; + else + return "SCALAR"; + + case SVt_PVLV: return (char *) (SvROK(sv) ? "REF" + /* tied lvalues should appear to be + * scalars for backwards compatibility */ + : (isALPHA_FOLD_EQ(LvTYPE(sv), 't')) + ? "SCALAR" : "LVALUE"); + case SVt_PVAV: return "ARRAY"; + case SVt_PVHV: return "HASH"; + case SVt_PVCV: return "CODE"; + case SVt_PVGV: return (char *) (isGV_with_GP(sv) + ? "GLOB" : "SCALAR"); + case SVt_PVFM: return "FORMAT"; + case SVt_PVIO: return "IO"; + case SVt_INVLIST: return "INVLIST"; + case SVt_REGEXP: return "REGEXP"; + default: return "UNKNOWN"; + } } } @@ -10247,7 +10247,7 @@ Perl_sv_ref(pTHX_ SV *dst, const SV *const sv, const int ob) dst = sv_newmortal(); if (ob && SvOBJECT(sv)) { - HvNAME_get(SvSTASH(sv)) + HvNAME_get(SvSTASH(sv)) ? sv_sethek(dst, HvNAME_HEK(SvSTASH(sv))) : sv_setpvs(dst, "__ANON__"); } @@ -10272,13 +10272,13 @@ int Perl_sv_isobject(pTHX_ SV *sv) { if (!sv) - return 0; + return 0; SvGETMAGIC(sv); if (!SvROK(sv)) - return 0; + return 0; sv = SvRV(sv); if (!SvOBJECT(sv)) - return 0; + return 0; return 1; } @@ -10304,16 +10304,16 @@ Perl_sv_isa(pTHX_ SV *sv, const char *const name) PERL_ARGS_ASSERT_SV_ISA; if (!sv) - return 0; + return 0; SvGETMAGIC(sv); if (!SvROK(sv)) - return 0; + return 0; sv = SvRV(sv); if (!SvOBJECT(sv)) - return 0; + return 0; hvname = HvNAME_get(SvSTASH(sv)); if (!hvname) - return 0; + return 0; return strEQ(hvname, name); } @@ -10342,17 +10342,17 @@ Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) SV_CHECK_THINKFIRST_COW_DROP(rv); if (UNLIKELY( SvTYPE(rv) >= SVt_PVMG )) { - const U32 refcnt = SvREFCNT(rv); - SvREFCNT(rv) = 0; - sv_clear(rv); - SvFLAGS(rv) = 0; - SvREFCNT(rv) = refcnt; + const U32 refcnt = SvREFCNT(rv); + SvREFCNT(rv) = 0; + sv_clear(rv); + SvFLAGS(rv) = 0; + SvREFCNT(rv) = refcnt; - sv_upgrade(rv, SVt_IV); + sv_upgrade(rv, SVt_IV); } else if (SvROK(rv)) { - SvREFCNT_dec(SvRV(rv)); + SvREFCNT_dec(SvRV(rv)); } else { - prepare_SV_for_RV(rv); + prepare_SV_for_RV(rv); } SvOK_off(rv); @@ -10360,8 +10360,8 @@ Perl_newSVrv(pTHX_ SV *const rv, const char *const classname) SvROK_on(rv); if (classname) { - HV* const stash = gv_stashpv(classname, GV_ADD); - (void)sv_bless(rv, stash); + HV* const stash = gv_stashpv(classname, GV_ADD); + (void)sv_bless(rv, stash); } return sv; } @@ -10403,11 +10403,11 @@ Perl_sv_setref_pv(pTHX_ SV *const rv, const char *const classname, void *const p PERL_ARGS_ASSERT_SV_SETREF_PV; if (!pv) { - sv_set_undef(rv); - SvSETMAGIC(rv); + sv_set_undef(rv); + SvSETMAGIC(rv); } else - sv_setiv(newSVrv(rv,classname), PTR2IV(pv)); + sv_setiv(newSVrv(rv,classname), PTR2IV(pv)); return rv; } @@ -10522,11 +10522,11 @@ Perl_sv_bless(pTHX_ SV *const sv, HV *const stash) Perl_croak(aTHX_ "Can't bless non-reference value"); tmpRef = SvRV(sv); if (SvFLAGS(tmpRef) & (SVs_OBJECT|SVf_READONLY|SVf_PROTECT)) { - if (SvREADONLY(tmpRef)) - Perl_croak_no_modify(); - if (SvOBJECT(tmpRef)) { - oldstash = SvSTASH(tmpRef); - } + if (SvREADONLY(tmpRef)) + Perl_croak_no_modify(); + if (SvOBJECT(tmpRef)) { + oldstash = SvSTASH(tmpRef); + } } SvOBJECT_on(tmpRef); SvUPGRADE(tmpRef, SVt_PVMG); @@ -10558,34 +10558,34 @@ S_sv_unglob(pTHX_ SV *const sv, U32 flags) assert(SvTYPE(sv) == SVt_PVGV || SvTYPE(sv) == SVt_PVLV); SvFAKE_off(sv); if (!(flags & SV_COW_DROP_PV)) - gv_efullname3(temp, MUTABLE_GV(sv), "*"); + gv_efullname3(temp, MUTABLE_GV(sv), "*"); SvREFCNT_inc_simple_void_NN(sv_2mortal(sv)); if (GvGP(sv)) { if(GvCVu((const GV *)sv) && (stash = GvSTASH(MUTABLE_GV(sv))) - && HvNAME_get(stash)) + && HvNAME_get(stash)) mro_method_changed_in(stash); - gp_free(MUTABLE_GV(sv)); + gp_free(MUTABLE_GV(sv)); } if (GvSTASH(sv)) { - sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv); - GvSTASH(sv) = NULL; + sv_del_backref(MUTABLE_SV(GvSTASH(sv)), sv); + GvSTASH(sv) = NULL; } GvMULTI_off(sv); if (GvNAME_HEK(sv)) { - unshare_hek(GvNAME_HEK(sv)); + unshare_hek(GvNAME_HEK(sv)); } isGV_with_GP_off(sv); if(SvTYPE(sv) == SVt_PVGV) { - /* need to keep SvANY(sv) in the right arena */ - xpvmg = new_XPVMG(); - StructCopy(SvANY(sv), xpvmg, XPVMG); - del_XPVGV(SvANY(sv)); - SvANY(sv) = xpvmg; + /* need to keep SvANY(sv) in the right arena */ + xpvmg = new_XPVMG(); + StructCopy(SvANY(sv), xpvmg, XPVMG); + del_XPVGV(SvANY(sv)); + SvANY(sv) = xpvmg; - SvFLAGS(sv) &= ~SVTYPEMASK; - SvFLAGS(sv) |= SVt_PVMG; + SvFLAGS(sv) &= ~SVTYPEMASK; + SvFLAGS(sv) |= SVt_PVMG; } /* Intentionally not calling any local SET magic, as this isn't so much a @@ -10594,9 +10594,9 @@ S_sv_unglob(pTHX_ SV *const sv, U32 flags) else sv_setsv_flags(sv, temp, 0); if ((const GV *)sv == PL_last_in_gv) - PL_last_in_gv = NULL; + PL_last_in_gv = NULL; else if ((const GV *)sv == PL_statgv) - PL_statgv = NULL; + PL_statgv = NULL; } /* @@ -10623,19 +10623,19 @@ Perl_sv_unref_flags(pTHX_ SV *const ref, const U32 flags) PERL_ARGS_ASSERT_SV_UNREF_FLAGS; if (SvWEAKREF(ref)) { - sv_del_backref(target, ref); - SvWEAKREF_off(ref); - SvRV_set(ref, NULL); - return; + sv_del_backref(target, ref); + SvWEAKREF_off(ref); + SvRV_set(ref, NULL); + return; } SvRV_set(ref, NULL); SvROK_off(ref); /* You can't have a || SvREADONLY(target) here, as $a = $$a, where $a was assigned to as BEGIN {$a = \"Foo"} will fail. */ if (SvREFCNT(target) != 1 || (flags & SV_IMMEDIATE_UNREF)) - SvREFCNT_dec_NN(target); + SvREFCNT_dec_NN(target); else /* XXX Hack, but hard to make $a=$a->[1] work otherwise */ - sv_2mortal(target); /* Schedule for freeing later */ + sv_2mortal(target); /* Schedule for freeing later */ } /* @@ -10653,9 +10653,9 @@ Perl_sv_untaint(pTHX_ SV *const sv) PERL_UNUSED_CONTEXT; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); - if (mg) - mg->mg_len &= ~1; + MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); + if (mg) + mg->mg_len &= ~1; } } @@ -10674,9 +10674,9 @@ Perl_sv_tainted(pTHX_ SV *const sv) PERL_UNUSED_CONTEXT; if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); - if (mg && (mg->mg_len & 1) ) - return TRUE; + const MAGIC * const mg = mg_find(sv, PERL_MAGIC_taint); + if (mg && (mg->mg_len & 1) ) + return TRUE; } return FALSE; } @@ -11027,8 +11027,8 @@ S_sv_catpvn_simple(pTHX_ SV *const sv, const char* const buf, const STRLEN len) STATIC void S_warn_vcatpvfn_missing_argument(pTHX) { if (ckWARN(WARN_MISSING)) { - Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s", - PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); + Perl_warner(aTHX_ packWARN(WARN_MISSING), "Missing argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); } } @@ -11133,24 +11133,24 @@ S_F0convert(NV nv, char *const endbuf, STRLEN *const len) assert(!Perl_isinfnan(nv)); if (neg) - nv = -nv; + nv = -nv; if (nv != 0.0 && nv < (NV) UV_MAX) { - char *p = endbuf; - uv = (UV)nv; - if (uv != nv) { - nv += 0.5; - uv = (UV)nv; - if (uv & 1 && uv == nv) - uv--; /* Round to even */ - } - do { - const unsigned dig = uv % 10; - *--p = '0' + dig; - } while (uv /= 10); - if (neg) - *--p = '-'; - *len = endbuf - p; - return p; + char *p = endbuf; + uv = (UV)nv; + if (uv != nv) { + nv += 0.5; + uv = (UV)nv; + if (uv & 1 && uv == nv) + uv--; /* Round to even */ + } + do { + const unsigned dig = uv % 10; + *--p = '0' + dig; + } while (uv /= 10); + if (neg) + *--p = '-'; + *len = endbuf - p; + return p; } return NULL; } @@ -11176,7 +11176,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *const sv, const char *const pat, const STRLEN patlen, * synonym for "double"). */ #if defined(HAS_LONG_DOUBLE) && LONG_DOUBLESIZE > DOUBLESIZE && \ - defined(PERL_PRIgldbl) && !defined(USE_QUADMATH) + defined(PERL_PRIgldbl) && !defined(USE_QUADMATH) # define VCATPVFN_FV_GF PERL_PRIgldbl # if defined(__VMS) && defined(__ia64) && defined(__IEEE_FLOAT) /* Work around breakage in OTS$CVT_FLOAT_T_X */ @@ -11345,7 +11345,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, /* The bytes 13..0 are the mantissa/fraction, * the 15,14 are the sign+exponent. */ const U8* nvp = (const U8*)(&nv); - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); # undef HEXTRACT_HAS_TOP_NYBBLE HEXTRACT_BYTES_LE(13, 0); @@ -11355,7 +11355,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, /* The bytes 2..15 are the mantissa/fraction, * the 0,1 are the sign+exponent. */ const U8* nvp = (const U8*)(&nv); - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); # undef HEXTRACT_HAS_TOP_NYBBLE HEXTRACT_BYTES_BE(2, 15); @@ -11365,11 +11365,11 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, * NVSIZE can be either 12 (ILP32, Solaris x86) or 16 (LP64, Linux * and OS X), meaning that 2 or 6 bytes are empty padding. */ /* The bytes 0..1 are the sign+exponent, - * the bytes 2..9 are the mantissa/fraction. */ + * the bytes 2..9 are the mantissa/fraction. */ const U8* nvp = (const U8*)(&nv); # undef HEXTRACT_HAS_IMPLICIT_BIT # undef HEXTRACT_HAS_TOP_NYBBLE - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_BYTES_LE(7, 0); # elif LONG_DOUBLEKIND == LONG_DOUBLE_IS_X86_80_BIT_BIG_ENDIAN /* Does this format ever happen? (Wikipedia says the Motorola @@ -11379,7 +11379,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, const U8* nvp = (const U8*)(&nv); # undef HEXTRACT_HAS_IMPLICIT_BIT # undef HEXTRACT_HAS_TOP_NYBBLE - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_BYTES_BE(0, 7); # else # define HEXTRACT_FALLBACK @@ -11415,21 +11415,21 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, # ifdef HEXTRACT_LITTLE_ENDIAN /* 0 1 2 3 4 5 6 7 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */ const U8* nvp = (const U8*)(&nv); - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); HEXTRACT_TOP_NYBBLE(6); HEXTRACT_BYTES_LE(5, 0); # elif defined(HEXTRACT_BIG_ENDIAN) /* 7 6 5 4 3 2 1 0 (MSB = 7, LSB = 0, 6+7 = exponent+sign) */ const U8* nvp = (const U8*)(&nv); - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); HEXTRACT_TOP_NYBBLE(1); HEXTRACT_BYTES_BE(2, 7); # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_LE_BE /* 4 5 6 7 0 1 2 3 (MSB = 7, LSB = 0, 6:7 = nybble:exponent:sign) */ const U8* nvp = (const U8*)(&nv); - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); HEXTRACT_TOP_NYBBLE(2); /* 6 */ HEXTRACT_BYTE(1); /* 5 */ @@ -11441,7 +11441,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, # elif DOUBLEKIND == DOUBLE_IS_IEEE_754_64_BIT_MIXED_ENDIAN_BE_LE /* 3 2 1 0 7 6 5 4 (MSB = 7, LSB = 0, 7:6 = sign:exponent:nybble) */ const U8* nvp = (const U8*)(&nv); - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); HEXTRACT_IMPLICIT_BIT(nv); HEXTRACT_TOP_NYBBLE(5); /* 6 */ HEXTRACT_BYTE(6); /* 5 */ @@ -11459,7 +11459,7 @@ S_hextract(pTHX_ const NV nv, int* exponent, bool *subnormal, #endif /* #if defined(USE_LONG_DOUBLE) && (NVSIZE > DOUBLESIZE) #else */ #ifdef HEXTRACT_FALLBACK - HEXTRACT_GET_SUBNORMAL(nv); + HEXTRACT_GET_SUBNORMAL(nv); # undef HEXTRACT_HAS_TOP_NYBBLE /* Meaningless, but consistent. */ /* The fallback is used for the double-double format, and * for unknown long double formats, and for unknown double @@ -11936,7 +11936,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p */ if (patlen == 0 && (args || sv_count == 0)) - return; + return; if (patlen <= 4 && pat[0] == '%' && (args || sv_count == 1)) { @@ -11985,46 +11985,46 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p patend = (char*)pat + patlen; for (fmtstart = pat; fmtstart < patend; fmtstart = q) { - char intsize = 0; /* size qualifier in "%hi..." etc */ - bool alt = FALSE; /* has "%#..." */ - bool left = FALSE; /* has "%-..." */ - bool fill = FALSE; /* has "%0..." */ - char plus = 0; /* has "%+..." */ - STRLEN width = 0; /* value of "%NNN..." */ - bool has_precis = FALSE; /* has "%.NNN..." */ - STRLEN precis = 0; /* value of "%.NNN..." */ - int base = 0; /* base to print in, e.g. 8 for %o */ - UV uv = 0; /* the value to print of int-ish args */ - - bool vectorize = FALSE; /* has "%v..." */ - bool vec_utf8 = FALSE; /* SvUTF8(vec arg) */ - const U8 *vecstr = NULL; /* SvPVX(vec arg) */ - STRLEN veclen = 0; /* SvCUR(vec arg) */ - const char *dotstr = NULL; /* separator string for %v */ - STRLEN dotstrlen; /* length of separator string for %v */ - - Size_t efix = 0; /* explicit format parameter index */ - const Size_t osvix = svix; /* original index in case of bad fmt */ - - SV *argsv = NULL; - bool is_utf8 = FALSE; /* is this item utf8? */ + char intsize = 0; /* size qualifier in "%hi..." etc */ + bool alt = FALSE; /* has "%#..." */ + bool left = FALSE; /* has "%-..." */ + bool fill = FALSE; /* has "%0..." */ + char plus = 0; /* has "%+..." */ + STRLEN width = 0; /* value of "%NNN..." */ + bool has_precis = FALSE; /* has "%.NNN..." */ + STRLEN precis = 0; /* value of "%.NNN..." */ + int base = 0; /* base to print in, e.g. 8 for %o */ + UV uv = 0; /* the value to print of int-ish args */ + + bool vectorize = FALSE; /* has "%v..." */ + bool vec_utf8 = FALSE; /* SvUTF8(vec arg) */ + const U8 *vecstr = NULL; /* SvPVX(vec arg) */ + STRLEN veclen = 0; /* SvCUR(vec arg) */ + const char *dotstr = NULL; /* separator string for %v */ + STRLEN dotstrlen; /* length of separator string for %v */ + + Size_t efix = 0; /* explicit format parameter index */ + const Size_t osvix = svix; /* original index in case of bad fmt */ + + SV *argsv = NULL; + bool is_utf8 = FALSE; /* is this item utf8? */ bool arg_missing = FALSE; /* give "Missing argument" warning */ - char esignbuf[4]; /* holds sign prefix, e.g. "-0x" */ - STRLEN esignlen = 0; /* length of e.g. "-0x" */ - STRLEN zeros = 0; /* how many '0' to prepend */ + char esignbuf[4]; /* holds sign prefix, e.g. "-0x" */ + STRLEN esignlen = 0; /* length of e.g. "-0x" */ + STRLEN zeros = 0; /* how many '0' to prepend */ - const char *eptr = NULL; /* the address of the element string */ - STRLEN elen = 0; /* the length of the element string */ + const char *eptr = NULL; /* the address of the element string */ + STRLEN elen = 0; /* the length of the element string */ - char c; /* the actual format ('d', s' etc) */ + char c; /* the actual format ('d', s' etc) */ - /* echo everything up to the next format specification */ - for (q = fmtstart; q < patend && *q != '%'; ++q) + /* echo everything up to the next format specification */ + for (q = fmtstart; q < patend && *q != '%'; ++q) {}; - if (q > fmtstart) { - if (has_utf8 && !pat_utf8) { + if (q > fmtstart) { + if (has_utf8 && !pat_utf8) { /* upgrade and copy the bytes of fmtstart..q-1 to utf8 on * the fly */ const char *p; @@ -12042,73 +12042,73 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p *dst = '\0'; SvCUR_set(sv, need - 1); } - else + else S_sv_catpvn_simple(aTHX_ sv, fmtstart, q - fmtstart); - } - if (q++ >= patend) - break; + } + if (q++ >= patend) + break; - fmtstart = q; /* fmtstart is char following the '%' */ + fmtstart = q; /* fmtstart is char following the '%' */ /* We allow format specification elements in this order: - \d+\$ explicit format parameter index - [-+ 0#]+ flags - v|\*(\d+\$)?v vector with optional (optionally specified) arg - 0 flag (as above): repeated to allow "v02" - \d+|\*(\d+\$)? width using optional (optionally specified) arg - \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg - [hlqLV] size + \d+\$ explicit format parameter index + [-+ 0#]+ flags + v|\*(\d+\$)?v vector with optional (optionally specified) arg + 0 flag (as above): repeated to allow "v02" + \d+|\*(\d+\$)? width using optional (optionally specified) arg + \.(\d*|\*(\d+\$)?) precision using optional (optionally specified) arg + [hlqLV] size [%bcdefginopsuxDFOUX] format (mandatory) */ - if (inRANGE(*q, '1', '9')) { + if (inRANGE(*q, '1', '9')) { width = expect_number(&q); - if (*q == '$') { + if (*q == '$') { if (args) Perl_croak_nocontext( "Cannot yet reorder sv_vcatpvfn() arguments from va_list"); - ++q; - efix = (Size_t)width; + ++q; + efix = (Size_t)width; width = 0; no_redundant_warning = TRUE; - } else { - goto gotwidth; - } - } - - /* FLAGS */ - - while (*q) { - switch (*q) { - case ' ': - case '+': - if (plus == '+' && *q == ' ') /* '+' over ' ' */ - q++; - else - plus = *q++; - continue; - - case '-': - left = TRUE; - q++; - continue; - - case '0': - fill = TRUE; + } else { + goto gotwidth; + } + } + + /* FLAGS */ + + while (*q) { + switch (*q) { + case ' ': + case '+': + if (plus == '+' && *q == ' ') /* '+' over ' ' */ + q++; + else + plus = *q++; + continue; + + case '-': + left = TRUE; + q++; + continue; + + case '0': + fill = TRUE; q++; - continue; + continue; - case '#': - alt = TRUE; - q++; - continue; + case '#': + alt = TRUE; + q++; + continue; - default: - break; - } - break; - } + default: + break; + } + break; + } /* at this point we can expect one of: * @@ -12127,18 +12127,18 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p */ tryasterisk: - if (*q == '*') { + if (*q == '*') { STRLEN ix; /* explicit width/vector separator index */ - q++; + q++; if (inRANGE(*q, '1', '9')) { ix = expect_number(&q); - if (*q++ == '$') { + if (*q++ == '$') { if (args) Perl_croak_nocontext( "Cannot yet reorder sv_vcatpvfn() arguments from va_list"); no_redundant_warning = TRUE; } else - goto unknown; + goto unknown; } else ix = 0; @@ -12186,35 +12186,35 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p width = S_sprintf_arg_num_val(aTHX_ args, i, width_sv, &left); } } - else if (*q == 'v') { - q++; - if (vectorize) - goto unknown; - vectorize = TRUE; + else if (*q == 'v') { + q++; + if (vectorize) + goto unknown; + vectorize = TRUE; dotstr = "."; dotstrlen = 1; goto tryasterisk; } - else { + else { /* explicit width? */ - if(*q == '0') { - fill = TRUE; + if(*q == '0') { + fill = TRUE; q++; } if (inRANGE(*q, '1', '9')) width = expect_number(&q); - } + } gotwidth: - /* PRECISION */ + /* PRECISION */ - if (*q == '.') { - q++; - if (*q == '*') { + if (*q == '.') { + q++; + if (*q == '*') { STRLEN ix; /* explicit precision index */ - q++; + q++; if (inRANGE(*q, '1', '9')) { ix = expect_number(&q); if (*q++ == '$') { @@ -12246,8 +12246,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (!has_precis) precis = 0; } - } - else { + } + else { /* although it doesn't seem documented, this code has long * behaved so that: * no digits following the '.' is treated like '.0' @@ -12258,88 +12258,88 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p while (*q == '0') q++; precis = inRANGE(*q, '1', '9') ? expect_number(&q) : 0; - has_precis = TRUE; - } - } + has_precis = TRUE; + } + } - /* SIZE */ + /* SIZE */ - switch (*q) { + switch (*q) { #ifdef WIN32 - case 'I': /* Ix, I32x, and I64x */ + case 'I': /* Ix, I32x, and I64x */ # ifdef USE_64_BIT_INT - if (q[1] == '6' && q[2] == '4') { - q += 3; - intsize = 'q'; - break; - } + if (q[1] == '6' && q[2] == '4') { + q += 3; + intsize = 'q'; + break; + } # endif - if (q[1] == '3' && q[2] == '2') { - q += 3; - break; - } + if (q[1] == '3' && q[2] == '2') { + q += 3; + break; + } # ifdef USE_64_BIT_INT - intsize = 'q'; + intsize = 'q'; # endif - q++; - break; + q++; + break; #endif #if (IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)) || \ (IVSIZE == 4 && !defined(HAS_LONG_DOUBLE)) - case 'L': /* Ld */ - /* FALLTHROUGH */ + case 'L': /* Ld */ + /* FALLTHROUGH */ # if IVSIZE >= 8 - case 'q': /* qd */ + case 'q': /* qd */ # endif - intsize = 'q'; - q++; - break; + intsize = 'q'; + q++; + break; #endif - case 'l': - ++q; + case 'l': + ++q; #if (IVSIZE >= 8 || defined(HAS_LONG_DOUBLE)) || \ (IVSIZE == 4 && !defined(HAS_LONG_DOUBLE)) - if (*q == 'l') { /* lld, llf */ - intsize = 'q'; - ++q; - } - else + if (*q == 'l') { /* lld, llf */ + intsize = 'q'; + ++q; + } + else #endif - intsize = 'l'; - break; - case 'h': - if (*++q == 'h') { /* hhd, hhu */ - intsize = 'c'; - ++q; - } - else - intsize = 'h'; - break; + intsize = 'l'; + break; + case 'h': + if (*++q == 'h') { /* hhd, hhu */ + intsize = 'c'; + ++q; + } + else + intsize = 'h'; + break; #ifdef USE_QUADMATH case 'Q': #endif - case 'V': - case 'z': - case 't': + case 'V': + case 'z': + case 't': case 'j': - intsize = *q++; - break; - } + intsize = *q++; + break; + } - /* CONVERSION */ + /* CONVERSION */ - c = *q++; /* c now holds the conversion type */ + c = *q++; /* c now holds the conversion type */ /* '%' doesn't have an arg, so skip arg processing */ - if (c == '%') { - eptr = q - 1; - elen = 1; - if (vectorize) - goto unknown; - goto string; - } - - if (vectorize && !memCHRs("BbDdiOouUXx", c)) + if (c == '%') { + eptr = q - 1; + elen = 1; + if (vectorize) + goto unknown; + goto string; + } + + if (vectorize && !memCHRs("BbDdiOouUXx", c)) goto unknown; /* get next arg (individual branches do their own va_arg() @@ -12349,55 +12349,55 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p efix = efix ? efix - 1 : svix++; argsv = efix < sv_count ? svargs[efix] : (arg_missing = TRUE, &PL_sv_no); - } + } - switch (c) { + switch (c) { - /* STRINGS */ + /* STRINGS */ - case 's': - if (args) { - eptr = va_arg(*args, char*); - if (eptr) + case 's': + if (args) { + eptr = va_arg(*args, char*); + if (eptr) if (has_precis) elen = my_strnlen(eptr, precis); else elen = strlen(eptr); - else { - eptr = (char *)nullstr; - elen = sizeof nullstr - 1; - } - } - else { - eptr = SvPV_const(argsv, elen); - if (DO_UTF8(argsv)) { - STRLEN old_precis = precis; - if (has_precis && precis < elen) { - STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen); - STRLEN p = precis > ulen ? ulen : precis; - precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0); - /* sticks at end */ - } - if (width) { /* fudge width (can't fudge elen) */ - if (has_precis && precis < elen) - width += precis - old_precis; - else - width += - elen - sv_or_pv_len_utf8(argsv,eptr,elen); - } - is_utf8 = TRUE; - } - } - - string: - if (has_precis && precis < elen) - elen = precis; - break; - - /* INTEGERS */ - - case 'p': + else { + eptr = (char *)nullstr; + elen = sizeof nullstr - 1; + } + } + else { + eptr = SvPV_const(argsv, elen); + if (DO_UTF8(argsv)) { + STRLEN old_precis = precis; + if (has_precis && precis < elen) { + STRLEN ulen = sv_or_pv_len_utf8(argsv, eptr, elen); + STRLEN p = precis > ulen ? ulen : precis; + precis = sv_or_pv_pos_u2b(argsv, eptr, p, 0); + /* sticks at end */ + } + if (width) { /* fudge width (can't fudge elen) */ + if (has_precis && precis < elen) + width += precis - old_precis; + else + width += + elen - sv_or_pv_len_utf8(argsv,eptr,elen); + } + is_utf8 = TRUE; + } + } + + string: + if (has_precis && precis < elen) + elen = precis; + break; + + /* INTEGERS */ + + case 'p': /* %p extensions: * @@ -12470,12 +12470,12 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* treat as normal %...p */ - uv = PTR2UV(args ? va_arg(*args, void*) : argsv); - base = 16; + uv = PTR2UV(args ? va_arg(*args, void*) : argsv); + base = 16; c = 'x'; /* in case the format string contains '#' */ - goto do_integer; + goto do_integer; - case 'c': + case 'c': /* Ignore any size specifiers, since they're not documented as * being allowed for %c (ideally we should warn on e.g. '%hc'). * Setting a default intsize, along with a positive @@ -12491,16 +12491,16 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p base = 1; /* special value that indicates we're doing a 'c' */ goto get_int_arg_val; - case 'D': + case 'D': #ifdef IV_IS_QUAD - intsize = 'q'; + intsize = 'q'; #else - intsize = 'l'; + intsize = 'l'; #endif base = -10; goto get_int_arg_val; - case 'd': + case 'd': /* probably just a plain %d, but it might be the start of the * special UTF8f format, which usually looks something like * "%d%lu%4p" (the lu may vary by platform) @@ -12508,67 +12508,67 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p assert((UTF8f)[0] == 'd'); assert((UTF8f)[1] == '%'); - if ( args /* UTF8f only valid for C-ish sprintf */ + if ( args /* UTF8f only valid for C-ish sprintf */ && q == fmtstart + 1 /* plain %d, not %....d */ && patend >= fmtstart + sizeof(UTF8f) - 1 /* long enough */ && *q == '%' && strnEQ(q + 1, (UTF8f) + 2, sizeof(UTF8f) - 3)) { - /* The argument has already gone through cBOOL, so the cast - is safe. */ - is_utf8 = (bool)va_arg(*args, int); - elen = va_arg(*args, UV); + /* The argument has already gone through cBOOL, so the cast + is safe. */ + is_utf8 = (bool)va_arg(*args, int); + elen = va_arg(*args, UV); /* if utf8 length is larger than 0x7ffff..., then it might * have been a signed value that wrapped */ if (elen > ((~(STRLEN)0) >> 1)) { assert(0); /* in DEBUGGING build we want to crash */ elen = 0; /* otherwise we want to treat this as an empty string */ } - eptr = va_arg(*args, char *); - q += sizeof(UTF8f) - 2; - goto string; - } + eptr = va_arg(*args, char *); + q += sizeof(UTF8f) - 2; + goto string; + } - /* FALLTHROUGH */ - case 'i': + /* FALLTHROUGH */ + case 'i': base = -10; goto get_int_arg_val; - case 'U': + case 'U': #ifdef IV_IS_QUAD - intsize = 'q'; + intsize = 'q'; #else - intsize = 'l'; + intsize = 'l'; #endif - /* FALLTHROUGH */ - case 'u': - base = 10; - goto get_int_arg_val; + /* FALLTHROUGH */ + case 'u': + base = 10; + goto get_int_arg_val; - case 'B': - case 'b': - base = 2; - goto get_int_arg_val; + case 'B': + case 'b': + base = 2; + goto get_int_arg_val; - case 'O': + case 'O': #ifdef IV_IS_QUAD - intsize = 'q'; + intsize = 'q'; #else - intsize = 'l'; + intsize = 'l'; #endif - /* FALLTHROUGH */ - case 'o': - base = 8; - goto get_int_arg_val; + /* FALLTHROUGH */ + case 'o': + base = 8; + goto get_int_arg_val; - case 'X': - case 'x': - base = 16; + case 'X': + case 'x': + base = 16; get_int_arg_val: - if (vectorize) { - STRLEN ulen; + if (vectorize) { + STRLEN ulen; SV *vecsv; if (base < 0) { @@ -12603,20 +12603,20 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* This is the re-entry point for when we're iterating * over the individual characters of a vector arg */ - vector: - if (!veclen) + vector: + if (!veclen) goto done_valid_conversion; - if (vec_utf8) - uv = utf8n_to_uvchr(vecstr, veclen, &ulen, - UTF8_ALLOW_ANYUV); - else { - uv = *vecstr; - ulen = 1; - } - vecstr += ulen; - veclen -= ulen; - } - else { + if (vec_utf8) + uv = utf8n_to_uvchr(vecstr, veclen, &ulen, + UTF8_ALLOW_ANYUV); + else { + uv = *vecstr; + ulen = 1; + } + vecstr += ulen; + veclen -= ulen; + } + else { /* test arg for inf/nan. This can trigger an unwanted * 'str' overload, so manually force 'num' overload first * if necessary */ @@ -12730,16 +12730,16 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } } - do_integer: - { - char *ptr = ebuf + sizeof ebuf; + do_integer: + { + char *ptr = ebuf + sizeof ebuf; unsigned dig; - zeros = 0; + zeros = 0; - switch (base) { - case 16: + switch (base) { + case 16: { - const char * const p = + const char * const p = (c == 'X') ? PL_hexdigit + 16 : PL_hexdigit; do { @@ -12752,26 +12752,26 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } break; } - case 8: - do { - dig = uv & 7; - *--ptr = '0' + dig; - } while (uv >>= 3); - if (alt && *ptr != '0') - *--ptr = '0'; - break; - case 2: - do { - dig = uv & 1; - *--ptr = '0' + dig; - } while (uv >>= 1); - if (alt && *ptr != '0') { - esignbuf[esignlen++] = '0'; - esignbuf[esignlen++] = c; /* 'b' or 'B' */ - } - break; - - case 1: + case 8: + do { + dig = uv & 7; + *--ptr = '0' + dig; + } while (uv >>= 3); + if (alt && *ptr != '0') + *--ptr = '0'; + break; + case 2: + do { + dig = uv & 1; + *--ptr = '0' + dig; + } while (uv >>= 1); + if (alt && *ptr != '0') { + esignbuf[esignlen++] = '0'; + esignbuf[esignlen++] = c; /* 'b' or 'B' */ + } + break; + + case 1: /* special-case: base 1 indicates a 'c' format: * we use the common code for extracting a uv, * but handle that value differently here than @@ -12792,37 +12792,37 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p } goto string; - default: /* it had better be ten or less */ - do { - dig = uv % base; - *--ptr = '0' + dig; - } while (uv /= base); - break; - } - elen = (ebuf + sizeof ebuf) - ptr; - eptr = ptr; - if (has_precis) { - if (precis > elen) - zeros = precis - elen; - else if (precis == 0 && elen == 1 && *eptr == '0' - && !(base == 8 && alt)) /* "%#.0o" prints "0" */ - elen = 0; + default: /* it had better be ten or less */ + do { + dig = uv % base; + *--ptr = '0' + dig; + } while (uv /= base); + break; + } + elen = (ebuf + sizeof ebuf) - ptr; + eptr = ptr; + if (has_precis) { + if (precis > elen) + zeros = precis - elen; + else if (precis == 0 && elen == 1 && *eptr == '0' + && !(base == 8 && alt)) /* "%#.0o" prints "0" */ + elen = 0; /* a precision nullifies the 0 flag. */ fill = FALSE; - } - } - break; + } + } + break; - /* FLOATING POINT */ + /* FLOATING POINT */ - case 'F': - c = 'f'; /* maybe %F isn't supported here */ - /* FALLTHROUGH */ - case 'e': case 'E': - case 'f': - case 'g': case 'G': - case 'a': case 'A': + case 'F': + c = 'f'; /* maybe %F isn't supported here */ + /* FALLTHROUGH */ + case 'e': case 'E': + case 'f': + case 'g': case 'G': + case 'a': case 'A': { STRLEN float_need; /* what PL_efloatsize needs to become */ @@ -12831,43 +12831,43 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p vcatpvfn_long_double_t fv; NV nv; - /* This is evil, but floating point is even more evil */ + /* This is evil, but floating point is even more evil */ - /* for SV-style calling, we can only get NV - for C-style calling, we assume %f is double; - for simplicity we allow any of %Lf, %llf, %qf for long double - */ - switch (intsize) { + /* for SV-style calling, we can only get NV + for C-style calling, we assume %f is double; + for simplicity we allow any of %Lf, %llf, %qf for long double + */ + switch (intsize) { #if defined(USE_QUADMATH) case 'Q': break; #endif - case 'V': + case 'V': #if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH) - intsize = 'q'; + intsize = 'q'; #endif - break; + break; /* [perl #20339] - we should accept and ignore %lf rather than die */ - case 'l': - /* FALLTHROUGH */ - default: + case 'l': + /* FALLTHROUGH */ + default: #if defined(USE_LONG_DOUBLE) || defined(USE_QUADMATH) - intsize = args ? 0 : 'q'; + intsize = args ? 0 : 'q'; #endif - break; - case 'q': + break; + case 'q': #if defined(HAS_LONG_DOUBLE) - break; + break; #else - /* FALLTHROUGH */ + /* FALLTHROUGH */ #endif - case 'c': - case 'h': - case 'z': - case 't': - case 'j': - goto unknown; - } + case 'c': + case 'h': + case 'z': + case 't': + case 'j': + goto unknown; + } /* Now we need (long double) if intsize == 'q', else (double). */ if (args) { @@ -13016,7 +13016,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p hexfp = FALSE; - if (isALPHA_FOLD_EQ(c, 'f')) { + if (isALPHA_FOLD_EQ(c, 'f')) { /* Determine how many digits before the radix point * might be emitted. frexp() (or frexpl) has some * unspecified behaviour for nan/inf/-inf, so lucky we've @@ -13071,7 +13071,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p assert(float_need < ((STRLEN)~0) - digits); float_need += digits; } - } + } /* special-case "%.g" if it will fit in ebuf */ else if (c == 'g' && precis /* See earlier comment about buggy Gconvert @@ -13096,7 +13096,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p elen = strlen(ebuf); eptr = ebuf; goto float_concat; - } + } { @@ -13109,8 +13109,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p float_need += pr; } - if (float_need < width) - float_need = width; + if (float_need < width) + float_need = width; if (float_need > INT_MAX) { /* snprintf() returns an int, and we use that return value, @@ -13119,7 +13119,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p Perl_croak(aTHX_ "Numeric format result too large"); } - if (PL_efloatsize <= float_need) { + if (PL_efloatsize <= float_need) { /* PL_efloatbuf should be at least 1 greater than * float_need to allow a trailing \0 to be returned by * snprintf(). If we need to grow, overgrow for the @@ -13128,11 +13128,11 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p if (float_need >= ((STRLEN)~0) - extra) croak_memory_wrap(); float_need += extra; - Safefree(PL_efloatbuf); - PL_efloatsize = float_need; - Newx(PL_efloatbuf, PL_efloatsize, char); - PL_efloatbuf[0] = '\0'; - } + Safefree(PL_efloatbuf); + PL_efloatsize = float_need; + Newx(PL_efloatbuf, PL_efloatsize, char); + PL_efloatbuf[0] = '\0'; + } if (UNLIKELY(hexfp)) { elen = S_format_hexfp(aTHX_ PL_efloatbuf, PL_efloatsize, c, @@ -13152,40 +13152,40 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p *--ptr = 'Q'; /* FIXME: what to do if HAS_LONG_DOUBLE but not PERL_PRIfldbl? */ #elif defined(HAS_LONG_DOUBLE) && defined(PERL_PRIfldbl) - /* Note that this is HAS_LONG_DOUBLE and PERL_PRIfldbl, - * not USE_LONG_DOUBLE and NVff. In other words, - * this needs to work without USE_LONG_DOUBLE. */ - if (intsize == 'q') { - /* Copy the one or more characters in a long double - * format before the 'base' ([efgEFG]) character to - * the format string. */ - static char const ldblf[] = PERL_PRIfldbl; - char const *p = ldblf + sizeof(ldblf) - 3; - while (p >= ldblf) { *--ptr = *p--; } - } + /* Note that this is HAS_LONG_DOUBLE and PERL_PRIfldbl, + * not USE_LONG_DOUBLE and NVff. In other words, + * this needs to work without USE_LONG_DOUBLE. */ + if (intsize == 'q') { + /* Copy the one or more characters in a long double + * format before the 'base' ([efgEFG]) character to + * the format string. */ + static char const ldblf[] = PERL_PRIfldbl; + char const *p = ldblf + sizeof(ldblf) - 3; + while (p >= ldblf) { *--ptr = *p--; } + } #endif - if (has_precis) { - base = precis; - do { *--ptr = '0' + (base % 10); } while (base /= 10); - *--ptr = '.'; - } - if (width) { - base = width; - do { *--ptr = '0' + (base % 10); } while (base /= 10); - } - if (fill) - *--ptr = '0'; - if (left) - *--ptr = '-'; - if (plus) - *--ptr = plus; - if (alt) - *--ptr = '#'; - *--ptr = '%'; - - /* No taint. Otherwise we are in the strange situation - * where printf() taints but print($float) doesn't. - * --jhi */ + if (has_precis) { + base = precis; + do { *--ptr = '0' + (base % 10); } while (base /= 10); + *--ptr = '.'; + } + if (width) { + base = width; + do { *--ptr = '0' + (base % 10); } while (base /= 10); + } + if (fill) + *--ptr = '0'; + if (left) + *--ptr = '-'; + if (plus) + *--ptr = plus; + if (alt) + *--ptr = '#'; + *--ptr = '%'; + + /* No taint. Otherwise we are in the strange situation + * where printf() taints but print($float) doesn't. + * --jhi */ /* hopefully the above makes ptr a very constrained format * that is safe to use, even though it's not literal */ @@ -13214,11 +13214,11 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p ); #endif GCC_DIAG_RESTORE_STMT; - } + } - eptr = PL_efloatbuf; + eptr = PL_efloatbuf; - float_concat: + float_concat: /* Since floating-point formats do their own formatting and * padding, we skip the main block of code at the end of this @@ -13235,9 +13235,9 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p goto done_valid_conversion; } - /* SPECIAL */ + /* SPECIAL */ - case 'n': + case 'n': { STRLEN len; /* XXX ideally we should warn if any flags etc have been @@ -13280,65 +13280,65 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p goto done_valid_conversion; } - /* UNKNOWN */ + /* UNKNOWN */ + + default: + unknown: + if (!args + && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF) + && ckWARN(WARN_PRINTF)) + { + SV * const msg = sv_newmortal(); + Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", + (PL_op->op_type == OP_PRTF) ? "" : "s"); + if (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_nomg(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 */ + } - default: - unknown: - if (!args - && (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF) - && ckWARN(WARN_PRINTF)) - { - SV * const msg = sv_newmortal(); - Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %sprintf: ", - (PL_op->op_type == OP_PRTF) ? "" : "s"); - if (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_nomg(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 */ - } - - /* mangled format: output the '%', then continue from the + /* mangled format: output the '%', then continue from the * character following that */ sv_catpvn_nomg(sv, fmtstart-1, 1); q = fmtstart; - svix = osvix; + svix = osvix; /* Any "redundant arg" warning from now onwards will probably * just be misleading, so don't bother. */ no_redundant_warning = TRUE; - continue; /* not "break" */ - } - - if (is_utf8 != has_utf8) { - if (is_utf8) { - if (SvCUR(sv)) - sv_utf8_upgrade(sv); - } - else { - const STRLEN old_elen = elen; - SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP); - sv_utf8_upgrade(nsv); - eptr = SvPVX_const(nsv); - elen = SvCUR(nsv); - - if (width) { /* fudge width (can't fudge elen) */ - width += elen - old_elen; - } - is_utf8 = TRUE; - } - } + continue; /* not "break" */ + } + + if (is_utf8 != has_utf8) { + if (is_utf8) { + if (SvCUR(sv)) + sv_utf8_upgrade(sv); + } + else { + const STRLEN old_elen = elen; + SV * const nsv = newSVpvn_flags(eptr, elen, SVs_TEMP); + sv_utf8_upgrade(nsv); + eptr = SvPVX_const(nsv); + elen = SvCUR(nsv); + + if (width) { /* fudge width (can't fudge elen) */ + width += elen - old_elen; + } + is_utf8 = TRUE; + } + } /* append esignbuf, filler, zeros, eptr and dotstr to sv */ @@ -13411,14 +13411,14 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p SvUTF8_on(sv); } - if (vectorize && veclen) { + if (vectorize && veclen) { /* we append the vector separator separately since %v isn't * very common: don't slow down the general case by adding * dotstrlen to need etc */ sv_catpvn_nomg(sv, dotstr, dotstrlen); esignlen = 0; goto vector; /* do next iteration */ - } + } done_valid_conversion: @@ -13430,8 +13430,8 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * do we have things left on the stack that we didn't use? */ if (!no_redundant_warning && sv_count >= svix + 1 && ckWARN(WARN_REDUNDANT)) { - Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", - PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); + Perl_warner(aTHX_ packWARN(WARN_REDUNDANT), "Redundant argument in %s", + PL_op ? OP_DESC(PL_op) : "sv_vcatpvfn()"); } if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { @@ -13497,12 +13497,12 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) PERL_ARGS_ASSERT_PARSER_DUP; if (!proto) - return NULL; + return NULL; /* look for it in the table first */ parser = (yy_parser *)ptr_table_fetch(PL_ptr_table, proto); if (parser) - return parser; + return parser; /* create anew and remember what it is */ Newxz(parser, 1, yy_parser); @@ -13513,9 +13513,9 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) parser->lex_brackets = proto->lex_brackets; parser->lex_casemods = proto->lex_casemods; parser->lex_brackstack = savepvn(proto->lex_brackstack, - (proto->lex_brackets < 120 ? 120 : proto->lex_brackets)); + (proto->lex_brackets < 120 ? 120 : proto->lex_brackets)); parser->lex_casestack = savepvn(proto->lex_casestack, - (proto->lex_casemods < 12 ? 12 : proto->lex_casemods)); + (proto->lex_casemods < 12 ? 12 : proto->lex_casemods)); parser->lex_defer = proto->lex_defer; parser->lex_dojoin = proto->lex_dojoin; parser->lex_formbrack = proto->lex_formbrack; @@ -13551,23 +13551,23 @@ Perl_parser_dup(pTHX_ const yy_parser *const proto, CLONE_PARAMS *const param) parser->recheck_utf8_validity = proto->recheck_utf8_validity; { - char * const ols = SvPVX(proto->linestr); - char * const ls = SvPVX(parser->linestr); + char * const ols = SvPVX(proto->linestr); + char * const ls = SvPVX(parser->linestr); - parser->bufptr = ls + (proto->bufptr >= ols ? - proto->bufptr - ols : 0); - parser->oldbufptr = ls + (proto->oldbufptr >= ols ? - proto->oldbufptr - ols : 0); - parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ? - proto->oldoldbufptr - ols : 0); - parser->linestart = ls + (proto->linestart >= ols ? - proto->linestart - ols : 0); - parser->last_uni = ls + (proto->last_uni >= ols ? - proto->last_uni - ols : 0); - parser->last_lop = ls + (proto->last_lop >= ols ? - proto->last_lop - ols : 0); + parser->bufptr = ls + (proto->bufptr >= ols ? + proto->bufptr - ols : 0); + parser->oldbufptr = ls + (proto->oldbufptr >= ols ? + proto->oldbufptr - ols : 0); + parser->oldoldbufptr= ls + (proto->oldoldbufptr >= ols ? + proto->oldoldbufptr - ols : 0); + parser->linestart = ls + (proto->linestart >= ols ? + proto->linestart - ols : 0); + parser->last_uni = ls + (proto->last_uni >= ols ? + proto->last_uni - ols : 0); + parser->last_lop = ls + (proto->last_lop >= ols ? + proto->last_lop - ols : 0); - parser->bufend = ls + SvCUR(parser->linestr); + parser->bufend = ls + SvCUR(parser->linestr); } Copy(proto->tokenbuf, parser->tokenbuf, 256, char); @@ -13595,12 +13595,12 @@ Perl_fp_dup(pTHX_ PerlIO *const fp, const char type, CLONE_PARAMS *const param) PERL_UNUSED_ARG(type); if (!fp) - return (PerlIO*)NULL; + return (PerlIO*)NULL; /* look for it in the table first */ ret = (PerlIO*)ptr_table_fetch(PL_ptr_table, fp); if (ret) - return ret; + return ret; /* create anew and remember what it is */ #ifdef __amigaos4__ @@ -13632,12 +13632,12 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) PERL_ARGS_ASSERT_DIRP_DUP; if (!dp) - return (DIR*)NULL; + return (DIR*)NULL; /* look for it in the table first */ ret = (DIR*)ptr_table_fetch(PL_ptr_table, dp); if (ret) - return ret; + return ret; #if defined(HAS_FCHDIR) && defined(HAS_TELLDIR) && defined(HAS_SEEKDIR) @@ -13650,8 +13650,8 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) /* chdir to our dir handle and open the present working directory */ if (fchdir(my_dirfd(dp)) < 0 || !(ret = PerlDir_open("."))) { - PerlDir_close(pwd); - return (DIR *)NULL; + PerlDir_close(pwd); + return (DIR *)NULL; } /* Now we should have two dir handles pointing to the same dir. */ @@ -13671,7 +13671,7 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) tion. Then step back. */ pos = PerlDir_tell(dp); if ((dirent = PerlDir_read(dp))) { - len = d_namlen(dirent); + len = d_namlen(dirent); if (len > sizeof(dirent->d_name) && sizeof(dirent->d_name) > PTRSIZE) { /* If the len is somehow magically longer than the * maximum length of the directory entry, even though @@ -13680,45 +13680,45 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) PerlDir_close(ret); return (DIR*)NULL; } - if (len <= sizeof smallbuf) name = smallbuf; - else Newx(name, len, char); - Move(dirent->d_name, name, len, char); + if (len <= sizeof smallbuf) name = smallbuf; + else Newx(name, len, char); + Move(dirent->d_name, name, len, char); } PerlDir_seek(dp, pos); /* Iterate through the new dir handle, till we find a file with the right name. */ if (!dirent) /* just before the end */ - for(;;) { - pos = PerlDir_tell(ret); - if (PerlDir_read(ret)) continue; /* not there yet */ - PerlDir_seek(ret, pos); /* step back */ - break; - } + for(;;) { + pos = PerlDir_tell(ret); + if (PerlDir_read(ret)) continue; /* not there yet */ + PerlDir_seek(ret, pos); /* step back */ + break; + } else { - const long pos0 = PerlDir_tell(ret); - for(;;) { - pos = PerlDir_tell(ret); - if ((dirent = PerlDir_read(ret))) { - if (len == (STRLEN)d_namlen(dirent) + const long pos0 = PerlDir_tell(ret); + for(;;) { + pos = PerlDir_tell(ret); + if ((dirent = PerlDir_read(ret))) { + if (len == (STRLEN)d_namlen(dirent) && memEQ(name, dirent->d_name, len)) { - /* found it */ - PerlDir_seek(ret, pos); /* step back */ - break; - } - /* else we are not there yet; keep iterating */ - } - else { /* This is not meant to happen. The best we can do is - reset the iterator to the beginning. */ - PerlDir_seek(ret, pos0); - break; - } - } + /* found it */ + PerlDir_seek(ret, pos); /* step back */ + break; + } + /* else we are not there yet; keep iterating */ + } + else { /* This is not meant to happen. The best we can do is + reset the iterator to the beginning. */ + PerlDir_seek(ret, pos0); + break; + } + } } #undef d_namlen if (name && name != smallbuf) - Safefree(name); + Safefree(name); #endif #ifdef WIN32 @@ -13727,7 +13727,7 @@ Perl_dirp_dup(pTHX_ DIR *const dp, CLONE_PARAMS *const param) /* pop it in the pointer table */ if (ret) - ptr_table_store(PL_ptr_table, dp, ret); + ptr_table_store(PL_ptr_table, dp, ret); return ret; } @@ -13742,11 +13742,11 @@ Perl_gp_dup(pTHX_ GP *const gp, CLONE_PARAMS *const param) PERL_ARGS_ASSERT_GP_DUP; if (!gp) - return (GP*)NULL; + return (GP*)NULL; /* look for it in the table first */ ret = (GP*)ptr_table_fetch(PL_ptr_table, gp); if (ret) - return ret; + return ret; /* create anew and remember what it is */ Newxz(ret, 1, GP); @@ -13779,60 +13779,60 @@ Perl_mg_dup(pTHX_ MAGIC *mg, CLONE_PARAMS *const param) PERL_ARGS_ASSERT_MG_DUP; for (; mg; mg = mg->mg_moremagic) { - MAGIC *nmg; - - if ((param->flags & CLONEf_JOIN_IN) - && mg->mg_type == PERL_MAGIC_backref) - /* when joining, we let the individual SVs add themselves to - * backref as needed. */ - continue; - - Newx(nmg, 1, MAGIC); - *mgprev_p = nmg; - mgprev_p = &(nmg->mg_moremagic); - - /* There was a comment "XXX copy dynamic vtable?" but as we don't have - dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates - from the original commit adding Perl_mg_dup() - revision 4538. - Similarly there is the annotation "XXX random ptr?" next to the - assignment to nmg->mg_ptr. */ - *nmg = *mg; - - /* FIXME for plugins - if (nmg->mg_type == PERL_MAGIC_qr) { - nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param)); - } - else - */ - nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED) - ? nmg->mg_type == PERL_MAGIC_backref - /* The backref AV has its reference - * count deliberately bumped by 1 */ - ? SvREFCNT_inc(av_dup_inc((const AV *) - nmg->mg_obj, param)) - : sv_dup_inc(nmg->mg_obj, param) + MAGIC *nmg; + + if ((param->flags & CLONEf_JOIN_IN) + && mg->mg_type == PERL_MAGIC_backref) + /* when joining, we let the individual SVs add themselves to + * backref as needed. */ + continue; + + Newx(nmg, 1, MAGIC); + *mgprev_p = nmg; + mgprev_p = &(nmg->mg_moremagic); + + /* There was a comment "XXX copy dynamic vtable?" but as we don't have + dynamic vtables, I'm not sure why Sarathy wrote it. The comment dates + from the original commit adding Perl_mg_dup() - revision 4538. + Similarly there is the annotation "XXX random ptr?" next to the + assignment to nmg->mg_ptr. */ + *nmg = *mg; + + /* FIXME for plugins + if (nmg->mg_type == PERL_MAGIC_qr) { + nmg->mg_obj = MUTABLE_SV(CALLREGDUPE((REGEXP*)nmg->mg_obj, param)); + } + else + */ + nmg->mg_obj = (nmg->mg_flags & MGf_REFCOUNTED) + ? nmg->mg_type == PERL_MAGIC_backref + /* The backref AV has its reference + * count deliberately bumped by 1 */ + ? SvREFCNT_inc(av_dup_inc((const AV *) + nmg->mg_obj, param)) + : sv_dup_inc(nmg->mg_obj, param) : (nmg->mg_type == PERL_MAGIC_regdatum || nmg->mg_type == PERL_MAGIC_regdata) ? nmg->mg_obj : sv_dup(nmg->mg_obj, param); - if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) { - if (nmg->mg_len > 0) { - nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len); - if (nmg->mg_type == PERL_MAGIC_overload_table && - AMT_AMAGIC((AMT*)nmg->mg_ptr)) - { - AMT * const namtp = (AMT*)nmg->mg_ptr; - sv_dup_inc_multiple((SV**)(namtp->table), - (SV**)(namtp->table), NofAMmeth, param); - } - } - else if (nmg->mg_len == HEf_SVKEY) - nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param); - } - if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) { - nmg->mg_virtual->svt_dup(aTHX_ nmg, param); - } + if (nmg->mg_ptr && nmg->mg_type != PERL_MAGIC_regex_global) { + if (nmg->mg_len > 0) { + nmg->mg_ptr = SAVEPVN(nmg->mg_ptr, nmg->mg_len); + if (nmg->mg_type == PERL_MAGIC_overload_table && + AMT_AMAGIC((AMT*)nmg->mg_ptr)) + { + AMT * const namtp = (AMT*)nmg->mg_ptr; + sv_dup_inc_multiple((SV**)(namtp->table), + (SV**)(namtp->table), NofAMmeth, param); + } + } + else if (nmg->mg_len == HEf_SVKEY) + nmg->mg_ptr = (char*)sv_dup_inc((const SV *)nmg->mg_ptr, param); + } + if ((nmg->mg_flags & MGf_DUP) && nmg->mg_virtual && nmg->mg_virtual->svt_dup) { + nmg->mg_virtual->svt_dup(aTHX_ nmg, param); + } } return mgret; } @@ -13877,8 +13877,8 @@ S_ptr_table_find(PTR_TBL_t *const tbl, const void *const sv) tblent = tbl->tbl_ary[hash & tbl->tbl_max]; for (; tblent; tblent = tblent->next) { - if (tblent->oldval == sv) - return tblent; + if (tblent->oldval == sv) + return tblent; } return NULL; } @@ -13907,29 +13907,29 @@ Perl_ptr_table_store(pTHX_ PTR_TBL_t *const tbl, const void *const oldsv, void * PERL_UNUSED_CONTEXT; if (tblent) { - tblent->newval = newsv; + tblent->newval = newsv; } else { - const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max; + const UV entry = PTR_TABLE_HASH(oldsv) & tbl->tbl_max; - if (tbl->tbl_arena_next == tbl->tbl_arena_end) { - struct ptr_tbl_arena *new_arena; + if (tbl->tbl_arena_next == tbl->tbl_arena_end) { + struct ptr_tbl_arena *new_arena; - Newx(new_arena, 1, struct ptr_tbl_arena); - new_arena->next = tbl->tbl_arena; - tbl->tbl_arena = new_arena; - tbl->tbl_arena_next = new_arena->array; - tbl->tbl_arena_end = C_ARRAY_END(new_arena->array); - } + Newx(new_arena, 1, struct ptr_tbl_arena); + new_arena->next = tbl->tbl_arena; + tbl->tbl_arena = new_arena; + tbl->tbl_arena_next = new_arena->array; + tbl->tbl_arena_end = C_ARRAY_END(new_arena->array); + } - tblent = tbl->tbl_arena_next++; + tblent = tbl->tbl_arena_next++; - tblent->oldval = oldsv; - tblent->newval = newsv; - tblent->next = tbl->tbl_ary[entry]; - tbl->tbl_ary[entry] = tblent; - tbl->tbl_items++; - if (tblent->next && tbl->tbl_items > tbl->tbl_max) - ptr_table_split(tbl); + tblent->oldval = oldsv; + tblent->newval = newsv; + tblent->next = tbl->tbl_ary[entry]; + tbl->tbl_ary[entry] = tblent; + tbl->tbl_items++; + if (tblent->next && tbl->tbl_items > tbl->tbl_max) + ptr_table_split(tbl); } } @@ -13951,22 +13951,22 @@ Perl_ptr_table_split(pTHX_ PTR_TBL_t *const tbl) tbl->tbl_max = --newsize; tbl->tbl_ary = ary; for (i=0; i < oldsize; i++, ary++) { - PTR_TBL_ENT_t **entp = ary; - PTR_TBL_ENT_t *ent = *ary; - PTR_TBL_ENT_t **curentp; - if (!ent) - continue; - curentp = ary + oldsize; - do { - if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) { - *entp = ent->next; - ent->next = *curentp; - *curentp = ent; - } - else - entp = &ent->next; - ent = *entp; - } while (ent); + PTR_TBL_ENT_t **entp = ary; + PTR_TBL_ENT_t *ent = *ary; + PTR_TBL_ENT_t **curentp; + if (!ent) + continue; + curentp = ary + oldsize; + do { + if ((newsize & PTR_TABLE_HASH(ent->oldval)) != i) { + *entp = ent->next; + ent->next = *curentp; + *curentp = ent; + } + else + entp = &ent->next; + ent = *entp; + } while (ent); } } @@ -13978,21 +13978,21 @@ Perl_ptr_table_clear(pTHX_ PTR_TBL_t *const tbl) { PERL_UNUSED_CONTEXT; if (tbl && tbl->tbl_items) { - struct ptr_tbl_arena *arena = tbl->tbl_arena; + struct ptr_tbl_arena *arena = tbl->tbl_arena; - Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent *); + Zero(tbl->tbl_ary, tbl->tbl_max + 1, struct ptr_tbl_ent *); - while (arena) { - struct ptr_tbl_arena *next = arena->next; + while (arena) { + struct ptr_tbl_arena *next = arena->next; - Safefree(arena); - arena = next; - }; + Safefree(arena); + arena = next; + }; - tbl->tbl_items = 0; - tbl->tbl_arena = NULL; - tbl->tbl_arena_next = NULL; - tbl->tbl_arena_end = NULL; + tbl->tbl_items = 0; + tbl->tbl_arena = NULL; + tbl->tbl_arena_next = NULL; + tbl->tbl_arena_end = NULL; } } @@ -14012,10 +14012,10 @@ Perl_ptr_table_free(pTHX_ PTR_TBL_t *const tbl) arena = tbl->tbl_arena; while (arena) { - struct ptr_tbl_arena *next = arena->next; + struct ptr_tbl_arena *next = arena->next; - Safefree(arena); - arena = next; + Safefree(arena); + arena = next; } Safefree(tbl->tbl_ary); @@ -14031,58 +14031,58 @@ Perl_rvpv_dup(pTHX_ SV *const dsv, const SV *const ssv, CLONE_PARAMS *const para assert(!isREGEXP(ssv)); if (SvROK(ssv)) { - if (SvWEAKREF(ssv)) { - SvRV_set(dsv, sv_dup(SvRV_const(ssv), param)); - if (param->flags & CLONEf_JOIN_IN) { - /* if joining, we add any back references individually rather - * than copying the whole backref array */ - Perl_sv_add_backref(aTHX_ SvRV(dsv), dsv); - } - } - else - SvRV_set(dsv, sv_dup_inc(SvRV_const(ssv), param)); + if (SvWEAKREF(ssv)) { + SvRV_set(dsv, sv_dup(SvRV_const(ssv), param)); + if (param->flags & CLONEf_JOIN_IN) { + /* if joining, we add any back references individually rather + * than copying the whole backref array */ + Perl_sv_add_backref(aTHX_ SvRV(dsv), dsv); + } + } + else + SvRV_set(dsv, sv_dup_inc(SvRV_const(ssv), param)); } else if (SvPVX_const(ssv)) { - /* Has something there */ - if (SvLEN(ssv)) { - /* Normal PV - clone whole allocated space */ - SvPV_set(dsv, SAVEPVN(SvPVX_const(ssv), SvLEN(ssv)-1)); - /* ssv may not be that normal, but actually copy on write. - But we are a true, independent SV, so: */ - SvIsCOW_off(dsv); - } - else { - /* Special case - not normally malloced for some reason */ - if (isGV_with_GP(ssv)) { - /* Don't need to do anything here. */ - } - else if ((SvIsCOW(ssv))) { - /* A "shared" PV - clone it as "shared" PV */ - SvPV_set(dsv, - HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)), - param))); - } - else { - /* Some other special case - random pointer */ - SvPV_set(dsv, (char *) SvPVX_const(ssv)); - } - } + /* Has something there */ + if (SvLEN(ssv)) { + /* Normal PV - clone whole allocated space */ + SvPV_set(dsv, SAVEPVN(SvPVX_const(ssv), SvLEN(ssv)-1)); + /* ssv may not be that normal, but actually copy on write. + But we are a true, independent SV, so: */ + SvIsCOW_off(dsv); + } + else { + /* Special case - not normally malloced for some reason */ + if (isGV_with_GP(ssv)) { + /* Don't need to do anything here. */ + } + else if ((SvIsCOW(ssv))) { + /* A "shared" PV - clone it as "shared" PV */ + SvPV_set(dsv, + HEK_KEY(hek_dup(SvSHARED_HEK_FROM_PV(SvPVX_const(ssv)), + param))); + } + else { + /* Some other special case - random pointer */ + SvPV_set(dsv, (char *) SvPVX_const(ssv)); + } + } } else { - /* Copy the NULL */ - SvPV_set(dsv, NULL); + /* Copy the NULL */ + SvPV_set(dsv, NULL); } } /* duplicate a list of SVs. source and dest may point to the same memory. */ static SV ** S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest, - SSize_t items, CLONE_PARAMS *const param) + SSize_t items, CLONE_PARAMS *const param) { PERL_ARGS_ASSERT_SV_DUP_INC_MULTIPLE; while (items-- > 0) { - *dest++ = sv_dup_inc(*source++, param); + *dest++ = sv_dup_inc(*source++, param); } return dest; @@ -14099,48 +14099,48 @@ S_sv_dup_common(pTHX_ const SV *const ssv, CLONE_PARAMS *const param) if (SvTYPE(ssv) == (svtype)SVTYPEMASK) { #ifdef DEBUG_LEAKING_SCALARS_ABORT - abort(); + abort(); #endif - return NULL; + return NULL; } /* look for it in the table first */ dsv = MUTABLE_SV(ptr_table_fetch(PL_ptr_table, ssv)); if (dsv) - return dsv; + return dsv; if(param->flags & CLONEf_JOIN_IN) { /** We are joining here so we don't want do clone - something that is bad **/ - if (SvTYPE(ssv) == SVt_PVHV) { - const HEK * const hvname = HvNAME_HEK(ssv); - if (hvname) { - /** don't clone stashes if they already exist **/ - dsv = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), + something that is bad **/ + if (SvTYPE(ssv) == SVt_PVHV) { + const HEK * const hvname = HvNAME_HEK(ssv); + if (hvname) { + /** don't clone stashes if they already exist **/ + dsv = MUTABLE_SV(gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), HEK_UTF8(hvname) ? SVf_UTF8 : 0)); - ptr_table_store(PL_ptr_table, ssv, dsv); - return dsv; - } - } - else if (SvTYPE(ssv) == SVt_PVGV && !SvFAKE(ssv)) { - HV *stash = GvSTASH(ssv); - const HEK * hvname; - if (stash && (hvname = HvNAME_HEK(stash))) { - /** don't clone GVs if they already exist **/ - SV **svp; - stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), - HEK_UTF8(hvname) ? SVf_UTF8 : 0); - svp = hv_fetch( - stash, GvNAME(ssv), - GvNAMEUTF8(ssv) - ? -GvNAMELEN(ssv) - : GvNAMELEN(ssv), - 0 - ); - if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) { - ptr_table_store(PL_ptr_table, ssv, *svp); - return *svp; - } - } + ptr_table_store(PL_ptr_table, ssv, dsv); + return dsv; + } + } + else if (SvTYPE(ssv) == SVt_PVGV && !SvFAKE(ssv)) { + HV *stash = GvSTASH(ssv); + const HEK * hvname; + if (stash && (hvname = HvNAME_HEK(stash))) { + /** don't clone GVs if they already exist **/ + SV **svp; + stash = gv_stashpvn(HEK_KEY(hvname), HEK_LEN(hvname), + HEK_UTF8(hvname) ? SVf_UTF8 : 0); + svp = hv_fetch( + stash, GvNAME(ssv), + GvNAMEUTF8(ssv) + ? -GvNAMELEN(ssv) + : GvNAMELEN(ssv), + 0 + ); + if (svp && *svp && SvTYPE(*svp) == SVt_PVGV) { + ptr_table_store(PL_ptr_table, ssv, *svp); + return *svp; + } + } } } @@ -14165,345 +14165,345 @@ S_sv_dup_common(pTHX_ const SV *const ssv, CLONE_PARAMS *const param) #ifdef DEBUGGING if (SvANY(ssv) && PL_watch_pvx && SvPVX_const(ssv) == PL_watch_pvx) - PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", - (void*)PL_watch_pvx, SvPVX_const(ssv)); + PerlIO_printf(Perl_debug_log, "watch at %p hit, found string \"%s\"\n", + (void*)PL_watch_pvx, SvPVX_const(ssv)); #endif /* don't clone objects whose class has asked us not to */ if (SvOBJECT(ssv) && ! (SvFLAGS(SvSTASH(ssv)) & SVphv_CLONEABLE)) { - SvFLAGS(dsv) = 0; - return dsv; + SvFLAGS(dsv) = 0; + return dsv; } switch (SvTYPE(ssv)) { case SVt_NULL: - SvANY(dsv) = NULL; - break; + SvANY(dsv) = NULL; + break; case SVt_IV: - SET_SVANY_FOR_BODYLESS_IV(dsv); - if(SvROK(ssv)) { - Perl_rvpv_dup(aTHX_ dsv, ssv, param); - } else { - SvIV_set(dsv, SvIVX(ssv)); - } - break; + SET_SVANY_FOR_BODYLESS_IV(dsv); + if(SvROK(ssv)) { + Perl_rvpv_dup(aTHX_ dsv, ssv, param); + } else { + SvIV_set(dsv, SvIVX(ssv)); + } + break; case SVt_NV: #if NVSIZE <= IVSIZE - SET_SVANY_FOR_BODYLESS_NV(dsv); + SET_SVANY_FOR_BODYLESS_NV(dsv); #else - SvANY(dsv) = new_XNV(); + SvANY(dsv) = new_XNV(); #endif - SvNV_set(dsv, SvNVX(ssv)); - break; + SvNV_set(dsv, SvNVX(ssv)); + break; default: - { - /* These are all the types that need complex bodies allocating. */ - void *new_body; - const svtype sv_type = SvTYPE(ssv); - const struct body_details *const sv_type_details - = bodies_by_type + sv_type; - - switch (sv_type) { - default: - Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(ssv)); + { + /* These are all the types that need complex bodies allocating. */ + void *new_body; + const svtype sv_type = SvTYPE(ssv); + const struct body_details *const sv_type_details + = bodies_by_type + sv_type; + + switch (sv_type) { + default: + Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(ssv)); NOT_REACHED; /* NOTREACHED */ - break; - - case SVt_PVGV: - case SVt_PVIO: - case SVt_PVFM: - case SVt_PVHV: - case SVt_PVAV: - case SVt_PVCV: - case SVt_PVLV: - case SVt_REGEXP: - case SVt_PVMG: - case SVt_PVNV: - case SVt_PVIV: + break; + + case SVt_PVGV: + case SVt_PVIO: + case SVt_PVFM: + case SVt_PVHV: + case SVt_PVAV: + case SVt_PVCV: + case SVt_PVLV: + case SVt_REGEXP: + case SVt_PVMG: + case SVt_PVNV: + case SVt_PVIV: case SVt_INVLIST: - case SVt_PV: - assert(sv_type_details->body_size); - if (sv_type_details->arena) { - new_body_inline(new_body, sv_type); - new_body - = (void*)((char*)new_body - sv_type_details->offset); - } else { - new_body = new_NOARENA(sv_type_details); - } - } - assert(new_body); - SvANY(dsv) = new_body; + case SVt_PV: + assert(sv_type_details->body_size); + if (sv_type_details->arena) { + new_body_inline(new_body, sv_type); + new_body + = (void*)((char*)new_body - sv_type_details->offset); + } else { + new_body = new_NOARENA(sv_type_details); + } + } + assert(new_body); + SvANY(dsv) = new_body; #ifndef PURIFY - Copy(((char*)SvANY(ssv)) + sv_type_details->offset, - ((char*)SvANY(dsv)) + sv_type_details->offset, - sv_type_details->copy, char); + Copy(((char*)SvANY(ssv)) + sv_type_details->offset, + ((char*)SvANY(dsv)) + sv_type_details->offset, + sv_type_details->copy, char); #else - Copy(((char*)SvANY(ssv)), - ((char*)SvANY(dsv)), - sv_type_details->body_size + sv_type_details->offset, char); + Copy(((char*)SvANY(ssv)), + ((char*)SvANY(dsv)), + sv_type_details->body_size + sv_type_details->offset, char); #endif - if (sv_type != SVt_PVAV && sv_type != SVt_PVHV - && !isGV_with_GP(dsv) - && !isREGEXP(dsv) - && !(sv_type == SVt_PVIO && !(IoFLAGS(dsv) & IOf_FAKE_DIRP))) - Perl_rvpv_dup(aTHX_ dsv, ssv, param); - - /* The Copy above means that all the source (unduplicated) pointers - are now in the destination. We can check the flags and the - pointers in either, but it's possible that there's less cache - missing by always going for the destination. - FIXME - instrument and check that assumption */ - if (sv_type >= SVt_PVMG) { - if (SvMAGIC(dsv)) - SvMAGIC_set(dsv, mg_dup(SvMAGIC(dsv), param)); - if (SvOBJECT(dsv) && SvSTASH(dsv)) - SvSTASH_set(dsv, hv_dup_inc(SvSTASH(dsv), param)); - else SvSTASH_set(dsv, 0); /* don't copy DESTROY cache */ - } - - /* The cast silences a GCC warning about unhandled types. */ - switch ((int)sv_type) { - case SVt_PV: - break; - case SVt_PVIV: - break; - case SVt_PVNV: - break; - case SVt_PVMG: - break; - case SVt_REGEXP: - duprex: - /* FIXME for plugins */ - re_dup_guts((REGEXP*) ssv, (REGEXP*) dsv, param); - break; - case SVt_PVLV: - /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ - if (LvTYPE(dsv) == 't') /* for tie: unrefcnted fake (SV**) */ - LvTARG(dsv) = dsv; - else if (LvTYPE(dsv) == 'T') /* for tie: fake HE */ - LvTARG(dsv) = MUTABLE_SV(he_dup((HE*)LvTARG(dsv), 0, param)); - else - LvTARG(dsv) = sv_dup_inc(LvTARG(dsv), param); - if (isREGEXP(ssv)) goto duprex; - /* FALLTHROUGH */ - case SVt_PVGV: - /* non-GP case already handled above */ - if(isGV_with_GP(ssv)) { - GvNAME_HEK(dsv) = hek_dup(GvNAME_HEK(dsv), param); - /* Don't call sv_add_backref here as it's going to be - created as part of the magic cloning of the symbol - table--unless this is during a join and the stash - is not actually being cloned. */ - /* Danger Will Robinson - GvGP(dsv) isn't initialised - at the point of this comment. */ - GvSTASH(dsv) = hv_dup(GvSTASH(dsv), param); - if (param->flags & CLONEf_JOIN_IN) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv); - GvGP_set(dsv, gp_dup(GvGP(ssv), param)); - (void)GpREFCNT_inc(GvGP(dsv)); - } - break; - case SVt_PVIO: - /* PL_parser->rsfp_filters entries have fake IoDIRP() */ - if(IoFLAGS(dsv) & IOf_FAKE_DIRP) { - /* I have no idea why fake dirp (rsfps) - should be treated differently but otherwise - we end up with leaks -- sky*/ - IoTOP_GV(dsv) = gv_dup_inc(IoTOP_GV(dsv), param); - IoFMT_GV(dsv) = gv_dup_inc(IoFMT_GV(dsv), param); - IoBOTTOM_GV(dsv) = gv_dup_inc(IoBOTTOM_GV(dsv), param); - } else { - IoTOP_GV(dsv) = gv_dup(IoTOP_GV(dsv), param); - IoFMT_GV(dsv) = gv_dup(IoFMT_GV(dsv), param); - IoBOTTOM_GV(dsv) = gv_dup(IoBOTTOM_GV(dsv), param); - if (IoDIRP(dsv)) { - IoDIRP(dsv) = dirp_dup(IoDIRP(dsv), param); - } else { - NOOP; - /* IoDIRP(dsv) is already a copy of IoDIRP(ssv) */ - } - IoIFP(dsv) = fp_dup(IoIFP(ssv), IoTYPE(dsv), param); - } - if (IoOFP(dsv) == IoIFP(ssv)) - IoOFP(dsv) = IoIFP(dsv); - else - IoOFP(dsv) = fp_dup(IoOFP(dsv), IoTYPE(dsv), param); - IoTOP_NAME(dsv) = SAVEPV(IoTOP_NAME(dsv)); - IoFMT_NAME(dsv) = SAVEPV(IoFMT_NAME(dsv)); - IoBOTTOM_NAME(dsv) = SAVEPV(IoBOTTOM_NAME(dsv)); - break; - case SVt_PVAV: - /* avoid cloning an empty array */ - if (AvARRAY((const AV *)ssv) && AvFILLp((const AV *)ssv) >= 0) { - SV **dst_ary, **src_ary; - SSize_t items = AvFILLp((const AV *)ssv) + 1; - - src_ary = AvARRAY((const AV *)ssv); - Newx(dst_ary, AvMAX((const AV *)ssv)+1, SV*); - ptr_table_store(PL_ptr_table, src_ary, dst_ary); - AvARRAY(MUTABLE_AV(dsv)) = dst_ary; - AvALLOC((const AV *)dsv) = dst_ary; - if (AvREAL((const AV *)ssv)) { - dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items, - param); - } - else { - while (items-- > 0) - *dst_ary++ = sv_dup(*src_ary++, param); - } - items = AvMAX((const AV *)ssv) - AvFILLp((const AV *)ssv); - while (items-- > 0) { - *dst_ary++ = NULL; - } - } - else { - AvARRAY(MUTABLE_AV(dsv)) = NULL; - AvALLOC((const AV *)dsv) = (SV**)NULL; - AvMAX( (const AV *)dsv) = -1; - AvFILLp((const AV *)dsv) = -1; - } - break; - case SVt_PVHV: - if (HvARRAY((const HV *)ssv)) { - STRLEN i = 0; - const bool sharekeys = !!HvSHAREKEYS(ssv); - XPVHV * const dxhv = (XPVHV*)SvANY(dsv); - XPVHV * const sxhv = (XPVHV*)SvANY(ssv); - char *darray; - Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) - + (SvOOK(ssv) ? sizeof(struct xpvhv_aux) : 0), - char); - HvARRAY(dsv) = (HE**)darray; - while (i <= sxhv->xhv_max) { - const HE * const source = HvARRAY(ssv)[i]; - HvARRAY(dsv)[i] = source - ? he_dup(source, sharekeys, param) : 0; - ++i; - } - if (SvOOK(ssv)) { - const struct xpvhv_aux * const saux = HvAUX(ssv); - struct xpvhv_aux * const daux = HvAUX(dsv); - /* This flag isn't copied. */ - SvOOK_on(dsv); - - if (saux->xhv_name_count) { - HEK ** const sname = saux->xhv_name_u.xhvnameu_names; - const I32 count - = saux->xhv_name_count < 0 - ? -saux->xhv_name_count - : saux->xhv_name_count; - HEK **shekp = sname + count; - HEK **dhekp; - Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *); - dhekp = daux->xhv_name_u.xhvnameu_names + count; - while (shekp-- > sname) { - dhekp--; - *dhekp = hek_dup(*shekp, param); - } - } - else { - daux->xhv_name_u.xhvnameu_name - = hek_dup(saux->xhv_name_u.xhvnameu_name, - param); - } - daux->xhv_name_count = saux->xhv_name_count; - - daux->xhv_aux_flags = saux->xhv_aux_flags; + if (sv_type != SVt_PVAV && sv_type != SVt_PVHV + && !isGV_with_GP(dsv) + && !isREGEXP(dsv) + && !(sv_type == SVt_PVIO && !(IoFLAGS(dsv) & IOf_FAKE_DIRP))) + Perl_rvpv_dup(aTHX_ dsv, ssv, param); + + /* The Copy above means that all the source (unduplicated) pointers + are now in the destination. We can check the flags and the + pointers in either, but it's possible that there's less cache + missing by always going for the destination. + FIXME - instrument and check that assumption */ + if (sv_type >= SVt_PVMG) { + if (SvMAGIC(dsv)) + SvMAGIC_set(dsv, mg_dup(SvMAGIC(dsv), param)); + if (SvOBJECT(dsv) && SvSTASH(dsv)) + SvSTASH_set(dsv, hv_dup_inc(SvSTASH(dsv), param)); + else SvSTASH_set(dsv, 0); /* don't copy DESTROY cache */ + } + + /* The cast silences a GCC warning about unhandled types. */ + switch ((int)sv_type) { + case SVt_PV: + break; + case SVt_PVIV: + break; + case SVt_PVNV: + break; + case SVt_PVMG: + break; + case SVt_REGEXP: + duprex: + /* FIXME for plugins */ + re_dup_guts((REGEXP*) ssv, (REGEXP*) dsv, param); + break; + case SVt_PVLV: + /* XXX LvTARGOFF sometimes holds PMOP* when DEBUGGING */ + if (LvTYPE(dsv) == 't') /* for tie: unrefcnted fake (SV**) */ + LvTARG(dsv) = dsv; + else if (LvTYPE(dsv) == 'T') /* for tie: fake HE */ + LvTARG(dsv) = MUTABLE_SV(he_dup((HE*)LvTARG(dsv), 0, param)); + else + LvTARG(dsv) = sv_dup_inc(LvTARG(dsv), param); + if (isREGEXP(ssv)) goto duprex; + /* FALLTHROUGH */ + case SVt_PVGV: + /* non-GP case already handled above */ + if(isGV_with_GP(ssv)) { + GvNAME_HEK(dsv) = hek_dup(GvNAME_HEK(dsv), param); + /* Don't call sv_add_backref here as it's going to be + created as part of the magic cloning of the symbol + table--unless this is during a join and the stash + is not actually being cloned. */ + /* Danger Will Robinson - GvGP(dsv) isn't initialised + at the point of this comment. */ + GvSTASH(dsv) = hv_dup(GvSTASH(dsv), param); + if (param->flags & CLONEf_JOIN_IN) + Perl_sv_add_backref(aTHX_ MUTABLE_SV(GvSTASH(dsv)), dsv); + GvGP_set(dsv, gp_dup(GvGP(ssv), param)); + (void)GpREFCNT_inc(GvGP(dsv)); + } + break; + case SVt_PVIO: + /* PL_parser->rsfp_filters entries have fake IoDIRP() */ + if(IoFLAGS(dsv) & IOf_FAKE_DIRP) { + /* I have no idea why fake dirp (rsfps) + should be treated differently but otherwise + we end up with leaks -- sky*/ + IoTOP_GV(dsv) = gv_dup_inc(IoTOP_GV(dsv), param); + IoFMT_GV(dsv) = gv_dup_inc(IoFMT_GV(dsv), param); + IoBOTTOM_GV(dsv) = gv_dup_inc(IoBOTTOM_GV(dsv), param); + } else { + IoTOP_GV(dsv) = gv_dup(IoTOP_GV(dsv), param); + IoFMT_GV(dsv) = gv_dup(IoFMT_GV(dsv), param); + IoBOTTOM_GV(dsv) = gv_dup(IoBOTTOM_GV(dsv), param); + if (IoDIRP(dsv)) { + IoDIRP(dsv) = dirp_dup(IoDIRP(dsv), param); + } else { + NOOP; + /* IoDIRP(dsv) is already a copy of IoDIRP(ssv) */ + } + IoIFP(dsv) = fp_dup(IoIFP(ssv), IoTYPE(dsv), param); + } + if (IoOFP(dsv) == IoIFP(ssv)) + IoOFP(dsv) = IoIFP(dsv); + else + IoOFP(dsv) = fp_dup(IoOFP(dsv), IoTYPE(dsv), param); + IoTOP_NAME(dsv) = SAVEPV(IoTOP_NAME(dsv)); + IoFMT_NAME(dsv) = SAVEPV(IoFMT_NAME(dsv)); + IoBOTTOM_NAME(dsv) = SAVEPV(IoBOTTOM_NAME(dsv)); + break; + case SVt_PVAV: + /* avoid cloning an empty array */ + if (AvARRAY((const AV *)ssv) && AvFILLp((const AV *)ssv) >= 0) { + SV **dst_ary, **src_ary; + SSize_t items = AvFILLp((const AV *)ssv) + 1; + + src_ary = AvARRAY((const AV *)ssv); + Newx(dst_ary, AvMAX((const AV *)ssv)+1, SV*); + ptr_table_store(PL_ptr_table, src_ary, dst_ary); + AvARRAY(MUTABLE_AV(dsv)) = dst_ary; + AvALLOC((const AV *)dsv) = dst_ary; + if (AvREAL((const AV *)ssv)) { + dst_ary = sv_dup_inc_multiple(src_ary, dst_ary, items, + param); + } + else { + while (items-- > 0) + *dst_ary++ = sv_dup(*src_ary++, param); + } + items = AvMAX((const AV *)ssv) - AvFILLp((const AV *)ssv); + while (items-- > 0) { + *dst_ary++ = NULL; + } + } + else { + AvARRAY(MUTABLE_AV(dsv)) = NULL; + AvALLOC((const AV *)dsv) = (SV**)NULL; + AvMAX( (const AV *)dsv) = -1; + AvFILLp((const AV *)dsv) = -1; + } + break; + case SVt_PVHV: + if (HvARRAY((const HV *)ssv)) { + STRLEN i = 0; + const bool sharekeys = !!HvSHAREKEYS(ssv); + XPVHV * const dxhv = (XPVHV*)SvANY(dsv); + XPVHV * const sxhv = (XPVHV*)SvANY(ssv); + char *darray; + Newx(darray, PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1) + + (SvOOK(ssv) ? sizeof(struct xpvhv_aux) : 0), + char); + HvARRAY(dsv) = (HE**)darray; + while (i <= sxhv->xhv_max) { + const HE * const source = HvARRAY(ssv)[i]; + HvARRAY(dsv)[i] = source + ? he_dup(source, sharekeys, param) : 0; + ++i; + } + if (SvOOK(ssv)) { + const struct xpvhv_aux * const saux = HvAUX(ssv); + struct xpvhv_aux * const daux = HvAUX(dsv); + /* This flag isn't copied. */ + SvOOK_on(dsv); + + if (saux->xhv_name_count) { + HEK ** const sname = saux->xhv_name_u.xhvnameu_names; + const I32 count + = saux->xhv_name_count < 0 + ? -saux->xhv_name_count + : saux->xhv_name_count; + HEK **shekp = sname + count; + HEK **dhekp; + Newx(daux->xhv_name_u.xhvnameu_names, count, HEK *); + dhekp = daux->xhv_name_u.xhvnameu_names + count; + while (shekp-- > sname) { + dhekp--; + *dhekp = hek_dup(*shekp, param); + } + } + else { + daux->xhv_name_u.xhvnameu_name + = hek_dup(saux->xhv_name_u.xhvnameu_name, + param); + } + daux->xhv_name_count = saux->xhv_name_count; + + daux->xhv_aux_flags = saux->xhv_aux_flags; #ifdef PERL_HASH_RANDOMIZE_KEYS - daux->xhv_rand = saux->xhv_rand; - daux->xhv_last_rand = saux->xhv_last_rand; + daux->xhv_rand = saux->xhv_rand; + daux->xhv_last_rand = saux->xhv_last_rand; #endif - daux->xhv_riter = saux->xhv_riter; - daux->xhv_eiter = saux->xhv_eiter - ? he_dup(saux->xhv_eiter, - cBOOL(HvSHAREKEYS(ssv)), param) : 0; - /* backref array needs refcnt=2; see sv_add_backref */ - daux->xhv_backreferences = - (param->flags & CLONEf_JOIN_IN) - /* when joining, we let the individual GVs and - * CVs add themselves to backref as - * needed. This avoids pulling in stuff - * that isn't required, and simplifies the - * case where stashes aren't cloned back - * if they already exist in the parent - * thread */ - ? NULL - : saux->xhv_backreferences - ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV) - ? MUTABLE_AV(SvREFCNT_inc( - sv_dup_inc((const SV *) - saux->xhv_backreferences, param))) - : MUTABLE_AV(sv_dup((const SV *) - saux->xhv_backreferences, param)) - : 0; + daux->xhv_riter = saux->xhv_riter; + daux->xhv_eiter = saux->xhv_eiter + ? he_dup(saux->xhv_eiter, + cBOOL(HvSHAREKEYS(ssv)), param) : 0; + /* backref array needs refcnt=2; see sv_add_backref */ + daux->xhv_backreferences = + (param->flags & CLONEf_JOIN_IN) + /* when joining, we let the individual GVs and + * CVs add themselves to backref as + * needed. This avoids pulling in stuff + * that isn't required, and simplifies the + * case where stashes aren't cloned back + * if they already exist in the parent + * thread */ + ? NULL + : saux->xhv_backreferences + ? (SvTYPE(saux->xhv_backreferences) == SVt_PVAV) + ? MUTABLE_AV(SvREFCNT_inc( + sv_dup_inc((const SV *) + saux->xhv_backreferences, param))) + : MUTABLE_AV(sv_dup((const SV *) + saux->xhv_backreferences, param)) + : 0; daux->xhv_mro_meta = saux->xhv_mro_meta ? mro_meta_dup(saux->xhv_mro_meta, param) : 0; - /* Record stashes for possible cloning in Perl_clone(). */ - if (HvNAME(ssv)) - av_push(param->stashes, dsv); - } - } - else - HvARRAY(MUTABLE_HV(dsv)) = NULL; - break; - case SVt_PVCV: - if (!(param->flags & CLONEf_COPY_STACKS)) { - CvDEPTH(dsv) = 0; - } - /* FALLTHROUGH */ - case SVt_PVFM: - /* NOTE: not refcounted */ - SvANY(MUTABLE_CV(dsv))->xcv_stash = - hv_dup(CvSTASH(dsv), param); - if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dsv)) - Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dsv)), dsv); - if (!CvISXSUB(dsv)) { - OP_REFCNT_LOCK; - CvROOT(dsv) = OpREFCNT_inc(CvROOT(dsv)); - OP_REFCNT_UNLOCK; - CvSLABBED_off(dsv); - } else if (CvCONST(dsv)) { - CvXSUBANY(dsv).any_ptr = - sv_dup_inc((const SV *)CvXSUBANY(dsv).any_ptr, param); - } - assert(!CvSLABBED(dsv)); - if (CvDYNFILE(dsv)) CvFILE(dsv) = SAVEPV(CvFILE(dsv)); - if (CvNAMED(dsv)) - SvANY((CV *)dsv)->xcv_gv_u.xcv_hek = - hek_dup(CvNAME_HEK((CV *)ssv), 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 */ - else - SvANY(MUTABLE_CV(dsv))->xcv_gv_u.xcv_gv = - CvCVGV_RC(dsv) - ? gv_dup_inc(CvGV(ssv), param) - : (param->flags & CLONEf_JOIN_IN) - ? NULL - : gv_dup(CvGV(ssv), param); - - if (!CvISXSUB(ssv)) { - PADLIST * padlist = CvPADLIST(ssv); - if(padlist) - padlist = padlist_dup(padlist, param); - CvPADLIST_set(dsv, padlist); - } else + /* Record stashes for possible cloning in Perl_clone(). */ + if (HvNAME(ssv)) + av_push(param->stashes, dsv); + } + } + else + HvARRAY(MUTABLE_HV(dsv)) = NULL; + break; + case SVt_PVCV: + if (!(param->flags & CLONEf_COPY_STACKS)) { + CvDEPTH(dsv) = 0; + } + /* FALLTHROUGH */ + case SVt_PVFM: + /* NOTE: not refcounted */ + SvANY(MUTABLE_CV(dsv))->xcv_stash = + hv_dup(CvSTASH(dsv), param); + if ((param->flags & CLONEf_JOIN_IN) && CvSTASH(dsv)) + Perl_sv_add_backref(aTHX_ MUTABLE_SV(CvSTASH(dsv)), dsv); + if (!CvISXSUB(dsv)) { + OP_REFCNT_LOCK; + CvROOT(dsv) = OpREFCNT_inc(CvROOT(dsv)); + OP_REFCNT_UNLOCK; + CvSLABBED_off(dsv); + } else if (CvCONST(dsv)) { + CvXSUBANY(dsv).any_ptr = + sv_dup_inc((const SV *)CvXSUBANY(dsv).any_ptr, param); + } + assert(!CvSLABBED(dsv)); + if (CvDYNFILE(dsv)) CvFILE(dsv) = SAVEPV(CvFILE(dsv)); + if (CvNAMED(dsv)) + SvANY((CV *)dsv)->xcv_gv_u.xcv_hek = + hek_dup(CvNAME_HEK((CV *)ssv), 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 */ + else + SvANY(MUTABLE_CV(dsv))->xcv_gv_u.xcv_gv = + CvCVGV_RC(dsv) + ? gv_dup_inc(CvGV(ssv), param) + : (param->flags & CLONEf_JOIN_IN) + ? NULL + : gv_dup(CvGV(ssv), param); + + if (!CvISXSUB(ssv)) { + PADLIST * padlist = CvPADLIST(ssv); + if(padlist) + padlist = padlist_dup(padlist, param); + CvPADLIST_set(dsv, padlist); + } else /* unthreaded perl can't sv_dup so we dont support unthreaded's CvHSCXT */ - PoisonPADLIST(dsv); + PoisonPADLIST(dsv); - CvOUTSIDE(dsv) = - CvWEAKOUTSIDE(ssv) - ? cv_dup( CvOUTSIDE(dsv), param) - : cv_dup_inc(CvOUTSIDE(dsv), param); - break; - } - } + CvOUTSIDE(dsv) = + CvWEAKOUTSIDE(ssv) + ? cv_dup( CvOUTSIDE(dsv), param) + : cv_dup_inc(CvOUTSIDE(dsv), param); + break; + } + } } return dsv; @@ -14537,8 +14537,8 @@ Perl_sv_dup(pTHX_ const SV *const ssv, CLONE_PARAMS *const param) to be in use, and free to be re-used. Not good. */ if (dsv && !(param->flags & CLONEf_COPY_STACKS) && !SvREFCNT(dsv)) { - assert(param->unreferenced); - av_push(param->unreferenced, SvREFCNT_inc(dsv)); + assert(param->unreferenced); + av_push(param->unreferenced, SvREFCNT_inc(dsv)); } return dsv; @@ -14554,12 +14554,12 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) PERL_ARGS_ASSERT_CX_DUP; if (!cxs) - return (PERL_CONTEXT*)NULL; + return (PERL_CONTEXT*)NULL; /* look for it in the table first */ ncxs = (PERL_CONTEXT*)ptr_table_fetch(PL_ptr_table, cxs); if (ncxs) - return ncxs; + return ncxs; /* create anew and remember what it is */ Newx(ncxs, max + 1, PERL_CONTEXT); @@ -14567,92 +14567,92 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* param) Copy(cxs, ncxs, max + 1, PERL_CONTEXT); while (ix >= 0) { - PERL_CONTEXT * const ncx = &ncxs[ix]; - if (CxTYPE(ncx) == CXt_SUBST) { - Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); - } - else { - ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl); - switch (CxTYPE(ncx)) { - case CXt_SUB: - ncx->blk_sub.cv = cv_dup_inc(ncx->blk_sub.cv, param); - if(CxHASARGS(ncx)){ - ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,param); - } else { - ncx->blk_sub.savearray = NULL; - } - ncx->blk_sub.prevcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, - ncx->blk_sub.prevcomppad); - break; - case CXt_EVAL: - ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv, - param); + PERL_CONTEXT * const ncx = &ncxs[ix]; + if (CxTYPE(ncx) == CXt_SUBST) { + Perl_croak(aTHX_ "Cloning substitution context is unimplemented"); + } + else { + ncx->blk_oldcop = (COP*)any_dup(ncx->blk_oldcop, param->proto_perl); + switch (CxTYPE(ncx)) { + case CXt_SUB: + ncx->blk_sub.cv = cv_dup_inc(ncx->blk_sub.cv, param); + if(CxHASARGS(ncx)){ + ncx->blk_sub.savearray = av_dup_inc(ncx->blk_sub.savearray,param); + } else { + ncx->blk_sub.savearray = NULL; + } + ncx->blk_sub.prevcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, + ncx->blk_sub.prevcomppad); + break; + case CXt_EVAL: + ncx->blk_eval.old_namesv = sv_dup_inc(ncx->blk_eval.old_namesv, + param); /* XXX should this sv_dup_inc? Or only if CxEVAL_TXT_REFCNTED ???? */ - ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param); - ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param); + ncx->blk_eval.cur_text = sv_dup(ncx->blk_eval.cur_text, param); + ncx->blk_eval.cv = cv_dup(ncx->blk_eval.cv, param); /* XXX what to do with cur_top_env ???? */ - break; - case CXt_LOOP_LAZYSV: - ncx->blk_loop.state_u.lazysv.end - = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param); + break; + case CXt_LOOP_LAZYSV: + ncx->blk_loop.state_u.lazysv.end + = sv_dup_inc(ncx->blk_loop.state_u.lazysv.end, param); /* Fallthrough: duplicate lazysv.cur by using the ary.ary duplication code instead. We are taking advantage of (1) av_dup_inc and sv_dup_inc actually being the same function, and (2) order equivalence 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); + 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); /* FALLTHROUGH */ - case CXt_LOOP_ARY: - ncx->blk_loop.state_u.ary.ary - = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param); + case CXt_LOOP_ARY: + ncx->blk_loop.state_u.ary.ary + = av_dup_inc(ncx->blk_loop.state_u.ary.ary, param); /* FALLTHROUGH */ - case CXt_LOOP_LIST: - case CXt_LOOP_LAZYIV: + case CXt_LOOP_LIST: + case CXt_LOOP_LAZYIV: /* code common to all 'for' CXt_LOOP_* types */ - ncx->blk_loop.itersave = + ncx->blk_loop.itersave = sv_dup_inc(ncx->blk_loop.itersave, param); - if (CxPADLOOP(ncx)) { + if (CxPADLOOP(ncx)) { PADOFFSET off = ncx->blk_loop.itervar_u.svp - &CX_CURPAD_SV(ncx->blk_loop, 0); ncx->blk_loop.oldcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, ncx->blk_loop.oldcomppad); - ncx->blk_loop.itervar_u.svp = + ncx->blk_loop.itervar_u.svp = &CX_CURPAD_SV(ncx->blk_loop, off); } - else { + else { /* this copies the GV if CXp_FOR_GV, or the SV for an * alias (for \$x (...)) - relies on gv_dup being the * same as sv_dup */ - ncx->blk_loop.itervar_u.gv - = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv, - param); - } - break; - case CXt_LOOP_PLAIN: - break; - case CXt_FORMAT: - ncx->blk_format.prevcomppad = + ncx->blk_loop.itervar_u.gv + = gv_dup((const GV *)ncx->blk_loop.itervar_u.gv, + param); + } + break; + case CXt_LOOP_PLAIN: + break; + case CXt_FORMAT: + ncx->blk_format.prevcomppad = (PAD*)ptr_table_fetch(PL_ptr_table, - ncx->blk_format.prevcomppad); - ncx->blk_format.cv = cv_dup_inc(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_GIVEN: - ncx->blk_givwhen.defsv_save = + ncx->blk_format.prevcomppad); + ncx->blk_format.cv = cv_dup_inc(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_GIVEN: + ncx->blk_givwhen.defsv_save = sv_dup_inc(ncx->blk_givwhen.defsv_save, param); - break; - case CXt_BLOCK: - case CXt_NULL: - case CXt_WHEN: - break; - } - } - --ix; + break; + case CXt_BLOCK: + case CXt_NULL: + case CXt_WHEN: + break; + } + } + --ix; } return ncxs; } @@ -14667,12 +14667,12 @@ Perl_si_dup(pTHX_ PERL_SI *si, CLONE_PARAMS* param) PERL_ARGS_ASSERT_SI_DUP; if (!si) - return (PERL_SI*)NULL; + return (PERL_SI*)NULL; /* look for it in the table first */ nsi = (PERL_SI*)ptr_table_fetch(PL_ptr_table, si); if (nsi) - return nsi; + return nsi; /* create anew and remember what it is */ Newx(nsi, 1, PERL_SI); @@ -14728,18 +14728,18 @@ Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl) PERL_ARGS_ASSERT_ANY_DUP; if (!v) - return (void*)NULL; + return (void*)NULL; /* look for it in the table first */ ret = ptr_table_fetch(PL_ptr_table, v); if (ret) - return ret; + return ret; /* see if it is part of the interpreter structure */ if (v >= (void*)proto_perl && v < (void*)(proto_perl+1)) - ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl)); + ret = (void*)(((char*)aTHX) + (((char*)v) - (char*)proto_perl)); else { - ret = v; + ret = v; } return ret; @@ -14773,255 +14773,255 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) Newx(nss, max, ANY); while (ix > 0) { - const UV uv = POPUV(ss,ix); - const U8 type = (U8)uv & SAVE_MASK; - - TOPUV(nss,ix) = uv; - switch (type) { - case SAVEt_CLEARSV: - case SAVEt_CLEARPADRANGE: - break; - case SAVEt_HELEM: /* hash element */ - case SAVEt_SV: /* scalar reference */ - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param)); - /* FALLTHROUGH */ - case SAVEt_ITEM: /* normal string */ + const UV uv = POPUV(ss,ix); + const U8 type = (U8)uv & SAVE_MASK; + + TOPUV(nss,ix) = uv; + switch (type) { + case SAVEt_CLEARSV: + case SAVEt_CLEARPADRANGE: + break; + case SAVEt_HELEM: /* hash element */ + case SAVEt_SV: /* scalar reference */ + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param)); + /* FALLTHROUGH */ + case SAVEt_ITEM: /* normal string */ case SAVEt_GVSV: /* scalar slot in GV */ - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - if (type == SAVEt_SV) - break; - /* FALLTHROUGH */ - case SAVEt_FREESV: - case SAVEt_MORTALIZESV: - case SAVEt_READONLY_OFF: - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - break; - case SAVEt_FREEPADNAME: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = padname_dup((PADNAME *)ptr, param); - PadnameREFCNT((PADNAME *)TOPPTR(nss,ix))++; - break; - case SAVEt_SHARED_PVREF: /* char* in shared space */ - c = (char*)POPPTR(ss,ix); - TOPPTR(nss,ix) = savesharedpv(c); - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - break; + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + if (type == SAVEt_SV) + break; + /* FALLTHROUGH */ + case SAVEt_FREESV: + case SAVEt_MORTALIZESV: + case SAVEt_READONLY_OFF: + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + break; + case SAVEt_FREEPADNAME: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = padname_dup((PADNAME *)ptr, param); + PadnameREFCNT((PADNAME *)TOPPTR(nss,ix))++; + break; + case SAVEt_SHARED_PVREF: /* char* in shared space */ + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = savesharedpv(c); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; case SAVEt_GENERIC_SVREF: /* generic sv */ case SAVEt_SVREF: /* scalar reference */ - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - if (type == SAVEt_SVREF) - SvREFCNT_inc_simple_void((SV *)TOPPTR(nss,ix)); - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ - break; + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + if (type == SAVEt_SVREF) + SvREFCNT_inc_simple_void((SV *)TOPPTR(nss,ix)); + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = svp_dup_inc((SV**)ptr, proto_perl);/* XXXXX */ + break; case SAVEt_GVSLOT: /* any slot in GV */ - 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 */ - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - break; + 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 */ + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + break; case SAVEt_HV: /* hash reference */ case SAVEt_AV: /* array reference */ - sv = (const SV *) POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - /* FALLTHROUGH */ - case SAVEt_COMPPAD: - case SAVEt_NSTAB: - sv = (const SV *) POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup(sv, param); - break; - case SAVEt_INT: /* int reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - intval = (int)POPINT(ss,ix); - TOPINT(nss,ix) = intval; - break; - case SAVEt_LONG: /* long reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - longval = (long)POPLONG(ss,ix); - TOPLONG(nss,ix) = longval; - break; - case SAVEt_I32: /* I32 reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - break; - case SAVEt_IV: /* IV reference */ - case SAVEt_STRLEN: /* STRLEN/size_t ref */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - iv = POPIV(ss,ix); - TOPIV(nss,ix) = iv; - break; - case SAVEt_TMPSFLOOR: - iv = POPIV(ss,ix); - TOPIV(nss,ix) = iv; - break; - case SAVEt_HPTR: /* HV* reference */ - case SAVEt_APTR: /* AV* reference */ - case SAVEt_SPTR: /* SV* reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup(sv, param); - break; - case SAVEt_VPTR: /* random* reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - /* FALLTHROUGH */ - case SAVEt_STRLEN_SMALL: - case SAVEt_INT_SMALL: - case SAVEt_I32_SMALL: - case SAVEt_I16: /* I16 reference */ - case SAVEt_I8: /* I8 reference */ - case SAVEt_BOOL: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - break; - case SAVEt_GENERIC_PVREF: /* generic char* */ - case SAVEt_PPTR: /* char* reference */ - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); - c = (char*)POPPTR(ss,ix); - TOPPTR(nss,ix) = pv_dup(c); - break; - case SAVEt_GP: /* scalar reference */ - gp = (GP*)POPPTR(ss,ix); - TOPPTR(nss,ix) = gp = gp_dup(gp, param); - (void)GpREFCNT_inc(gp); - gv = (const GV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = gv_dup_inc(gv, param); - break; - case SAVEt_FREEOP: - ptr = POPPTR(ss,ix); - if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { - /* these are assumed to be refcounted properly */ - OP *o; - switch (((OP*)ptr)->op_type) { - case OP_LEAVESUB: - case OP_LEAVESUBLV: - case OP_LEAVEEVAL: - case OP_LEAVE: - case OP_SCOPE: - case OP_LEAVEWRITE: - TOPPTR(nss,ix) = ptr; - o = (OP*)ptr; - OP_REFCNT_LOCK; - (void) OpREFCNT_inc(o); - OP_REFCNT_UNLOCK; - break; - default: - TOPPTR(nss,ix) = NULL; - break; - } - } - else - TOPPTR(nss,ix) = NULL; - break; - case SAVEt_FREECOPHH: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr); - break; - case SAVEt_ADELETE: - av = (const AV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = av_dup_inc(av, param); - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - break; - case SAVEt_DELETE: - hv = (const HV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = hv_dup_inc(hv, param); - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - /* FALLTHROUGH */ - case SAVEt_FREEPV: - c = (char*)POPPTR(ss,ix); - TOPPTR(nss,ix) = pv_dup_inc(c); - break; - case SAVEt_STACK_POS: /* Position on Perl stack */ - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - break; - case SAVEt_DESTRUCTOR: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ - dptr = POPDPTR(ss,ix); - TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*), - any_dup(FPTR2DPTR(void *, dptr), - proto_perl)); - break; - case SAVEt_DESTRUCTOR_X: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ - dxptr = POPDXPTR(ss,ix); - TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*), - any_dup(FPTR2DPTR(void *, dxptr), - proto_perl)); - break; - case SAVEt_REGCONTEXT: - case SAVEt_ALLOC: - ix -= uv >> SAVE_TIGHT_SHIFT; - break; - case SAVEt_AELEM: /* array element */ - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param)); - iv = POPIV(ss,ix); - TOPIV(nss,ix) = iv; - av = (const AV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = av_dup_inc(av, param); - break; - case SAVEt_OP: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = ptr; - break; + sv = (const SV *) POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + /* FALLTHROUGH */ + case SAVEt_COMPPAD: + case SAVEt_NSTAB: + sv = (const SV *) POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv, param); + break; + case SAVEt_INT: /* int reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + intval = (int)POPINT(ss,ix); + TOPINT(nss,ix) = intval; + break; + case SAVEt_LONG: /* long reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + longval = (long)POPLONG(ss,ix); + TOPLONG(nss,ix) = longval; + break; + case SAVEt_I32: /* I32 reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_IV: /* IV reference */ + case SAVEt_STRLEN: /* STRLEN/size_t ref */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + break; + case SAVEt_TMPSFLOOR: + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + break; + case SAVEt_HPTR: /* HV* reference */ + case SAVEt_APTR: /* AV* reference */ + case SAVEt_SPTR: /* SV* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv, param); + break; + case SAVEt_VPTR: /* random* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + /* FALLTHROUGH */ + case SAVEt_STRLEN_SMALL: + case SAVEt_INT_SMALL: + case SAVEt_I32_SMALL: + case SAVEt_I16: /* I16 reference */ + case SAVEt_I8: /* I8 reference */ + case SAVEt_BOOL: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + break; + case SAVEt_GENERIC_PVREF: /* generic char* */ + case SAVEt_PPTR: /* char* reference */ + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup(c); + break; + case SAVEt_GP: /* scalar reference */ + gp = (GP*)POPPTR(ss,ix); + TOPPTR(nss,ix) = gp = gp_dup(gp, param); + (void)GpREFCNT_inc(gp); + gv = (const GV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = gv_dup_inc(gv, param); + break; + case SAVEt_FREEOP: + ptr = POPPTR(ss,ix); + if (ptr && (((OP*)ptr)->op_private & OPpREFCOUNTED)) { + /* these are assumed to be refcounted properly */ + OP *o; + switch (((OP*)ptr)->op_type) { + case OP_LEAVESUB: + case OP_LEAVESUBLV: + case OP_LEAVEEVAL: + case OP_LEAVE: + case OP_SCOPE: + case OP_LEAVEWRITE: + TOPPTR(nss,ix) = ptr; + o = (OP*)ptr; + OP_REFCNT_LOCK; + (void) OpREFCNT_inc(o); + OP_REFCNT_UNLOCK; + break; + default: + TOPPTR(nss,ix) = NULL; + break; + } + } + else + TOPPTR(nss,ix) = NULL; + break; + case SAVEt_FREECOPHH: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = cophh_copy((COPHH *)ptr); + break; + case SAVEt_ADELETE: + av = (const AV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup_inc(av, param); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_DELETE: + hv = (const HV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = hv_dup_inc(hv, param); + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + /* FALLTHROUGH */ + case SAVEt_FREEPV: + c = (char*)POPPTR(ss,ix); + TOPPTR(nss,ix) = pv_dup_inc(c); + break; + case SAVEt_STACK_POS: /* Position on Perl stack */ + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + case SAVEt_DESTRUCTOR: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ + dptr = POPDPTR(ss,ix); + TOPDPTR(nss,ix) = DPTR2FPTR(void (*)(void*), + any_dup(FPTR2DPTR(void *, dptr), + proto_perl)); + break; + case SAVEt_DESTRUCTOR_X: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = any_dup(ptr, proto_perl); /* XXX quite arbitrary */ + dxptr = POPDXPTR(ss,ix); + TOPDXPTR(nss,ix) = DPTR2FPTR(void (*)(pTHX_ void*), + any_dup(FPTR2DPTR(void *, dxptr), + proto_perl)); + break; + case SAVEt_REGCONTEXT: + case SAVEt_ALLOC: + ix -= uv >> SAVE_TIGHT_SHIFT; + break; + case SAVEt_AELEM: /* array element */ + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = SvREFCNT_inc(sv_dup_inc(sv, param)); + iv = POPIV(ss,ix); + TOPIV(nss,ix) = iv; + av = (const AV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = av_dup_inc(av, param); + break; + case SAVEt_OP: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = ptr; + break; case SAVEt_HINTS_HH: hv = (const HV *)POPPTR(ss,ix); TOPPTR(nss,ix) = hv_dup_inc(hv, param); /* FALLTHROUGH */ - case SAVEt_HINTS: - ptr = POPPTR(ss,ix); - ptr = cophh_copy((COPHH*)ptr); - TOPPTR(nss,ix) = ptr; - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - break; - 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 = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup_inc(sv, param); - break; - case SAVEt_SET_SVFLAGS: - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - i = POPINT(ss,ix); - TOPINT(nss,ix) = i; - sv = (const SV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = sv_dup(sv, param); - break; - case SAVEt_COMPILE_WARNINGS: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); - break; - case SAVEt_PARSER: - ptr = POPPTR(ss,ix); - TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param); - break; - default: - Perl_croak(aTHX_ - "panic: ss_dup inconsistency (%" IVdf ")", (IV) type); - } + case SAVEt_HINTS: + ptr = POPPTR(ss,ix); + ptr = cophh_copy((COPHH*)ptr); + TOPPTR(nss,ix) = ptr; + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + break; + 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 = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup_inc(sv, param); + break; + case SAVEt_SET_SVFLAGS: + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + i = POPINT(ss,ix); + TOPINT(nss,ix) = i; + sv = (const SV *)POPPTR(ss,ix); + TOPPTR(nss,ix) = sv_dup(sv, param); + break; + case SAVEt_COMPILE_WARNINGS: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = DUP_WARNINGS((STRLEN*)ptr); + break; + case SAVEt_PARSER: + ptr = POPPTR(ss,ix); + TOPPTR(nss,ix) = parser_dup((const yy_parser*)ptr, param); + break; + default: + Perl_croak(aTHX_ + "panic: ss_dup inconsistency (%" IVdf ")", (IV) type); + } } return nss; @@ -15037,26 +15037,26 @@ do_mark_cloneable_stash(pTHX_ SV *const sv) { const HEK * const hvname = HvNAME_HEK((const HV *)sv); if (hvname) { - 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; - UV status; - - ENTER; - SAVETMPS; - PUSHMARK(SP); - mXPUSHs(newSVhek(hvname)); - PUTBACK; - call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR); - SPAGAIN; - status = POPu; - PUTBACK; - FREETMPS; - LEAVE; - if (status) - SvFLAGS(sv) &= ~SVphv_CLONEABLE; - } + 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; + UV status; + + ENTER; + SAVETMPS; + PUSHMARK(SP); + mXPUSHs(newSVhek(hvname)); + PUTBACK; + call_sv(MUTABLE_SV(GvCV(cloner)), G_SCALAR); + SPAGAIN; + status = POPu; + PUTBACK; + FREETMPS; + LEAVE; + if (status) + SvFLAGS(sv) &= ~SVphv_CLONEABLE; + } } } @@ -15118,24 +15118,24 @@ perl_clone(PerlInterpreter *proto_perl, UV flags) } #endif return perl_clone_using(proto_perl, flags, - proto_perl->IMem, - proto_perl->IMemShared, - proto_perl->IMemParse, - proto_perl->IEnv, - proto_perl->IStdIO, - proto_perl->ILIO, - proto_perl->IDir, - proto_perl->ISock, - proto_perl->IProc); + proto_perl->IMem, + proto_perl->IMemShared, + proto_perl->IMemParse, + proto_perl->IEnv, + proto_perl->IStdIO, + proto_perl->ILIO, + proto_perl->IDir, + proto_perl->ISock, + proto_perl->IProc); } PerlInterpreter * perl_clone_using(PerlInterpreter *proto_perl, UV flags, - struct IPerlMem* ipM, struct IPerlMem* ipMS, - struct IPerlMem* ipMP, struct IPerlEnv* ipE, - struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, - struct IPerlDir* ipD, struct IPerlSock* ipS, - struct IPerlProc* ipP) + struct IPerlMem* ipM, struct IPerlMem* ipMS, + struct IPerlMem* ipMP, struct IPerlEnv* ipE, + struct IPerlStdIO* ipStd, struct IPerlLIO* ipLIO, + struct IPerlDir* ipD, struct IPerlSock* ipS, + struct IPerlProc* ipP) { /* XXX many of the string copies here can be optimized if they're * constants; they need to be allocated as common memory and just @@ -15374,20 +15374,20 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE); if (flags & CLONEf_COPY_STACKS) { - /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ - PL_tmps_ix = proto_perl->Itmps_ix; - PL_tmps_max = proto_perl->Itmps_max; - PL_tmps_floor = proto_perl->Itmps_floor; + /* next allocation will be PL_tmps_stack[PL_tmps_ix+1] */ + PL_tmps_ix = proto_perl->Itmps_ix; + PL_tmps_max = proto_perl->Itmps_max; + PL_tmps_floor = proto_perl->Itmps_floor; - /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] - * NOTE: unlike the others! */ - PL_scopestack_ix = proto_perl->Iscopestack_ix; - PL_scopestack_max = proto_perl->Iscopestack_max; + /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] + * NOTE: unlike the others! */ + PL_scopestack_ix = proto_perl->Iscopestack_ix; + PL_scopestack_max = proto_perl->Iscopestack_max; - /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] - * NOTE: unlike the others! */ - PL_savestack_ix = proto_perl->Isavestack_ix; - PL_savestack_max = proto_perl->Isavestack_max; + /* next SSPUSHFOO() sets PL_savestack[PL_savestack_ix] + * NOTE: unlike the others! */ + PL_savestack_ix = proto_perl->Isavestack_ix; + PL_savestack_max = proto_perl->Isavestack_max; } PL_start_env = proto_perl->Istart_env; /* XXXXXX */ @@ -15458,7 +15458,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, ptr_table_store(PL_ptr_table, &proto_perl->Isv_zero, &PL_sv_zero); ptr_table_store(PL_ptr_table, &proto_perl->Isv_yes, &PL_sv_yes); ptr_table_store(PL_ptr_table, &proto_perl->Ipadname_const, - &PL_padname_const); + &PL_padname_const); /* create (a non-shared!) shared string table */ PL_strtab = newHV(); @@ -15487,7 +15487,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, AvREAL_off(param->stashes); if (!(flags & CLONEf_COPY_STACKS)) { - param->unreferenced = newAV(); + param->unreferenced = newAV(); } #ifdef PERLIO_LAYERS @@ -15527,9 +15527,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_stashpadix = proto_perl->Istashpadix ; Newx(PL_stashpad, PL_stashpadmax, HV *); { - PADOFFSET o = 0; - for (; o < PL_stashpadmax; ++o) - PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param); + PADOFFSET o = 0; + for (; o < PL_stashpadmax; ++o) + PL_stashpad[o] = hv_dup(proto_perl->Istashpad[o], param); } /* shortcuts to various I/O objects */ @@ -15579,9 +15579,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_fdpid = av_dup_inc(proto_perl->Ifdpid, param); if (proto_perl->Iop_mask) - PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); + PL_op_mask = SAVEPVN(proto_perl->Iop_mask, PL_maxo); else - PL_op_mask = NULL; + PL_op_mask = NULL; /* PL_asserting = proto_perl->Iasserting; */ /* current interpreter roots */ @@ -15600,19 +15600,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* interpreter atexit processing */ PL_exitlistlen = proto_perl->Iexitlistlen; if (PL_exitlistlen) { - Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry); - Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); + Newx(PL_exitlist, PL_exitlistlen, PerlExitListEntry); + Copy(proto_perl->Iexitlist, PL_exitlist, PL_exitlistlen, PerlExitListEntry); } else - PL_exitlist = (PerlExitListEntry*)NULL; + PL_exitlist = (PerlExitListEntry*)NULL; PL_my_cxt_size = proto_perl->Imy_cxt_size; if (PL_my_cxt_size) { - Newx(PL_my_cxt_list, PL_my_cxt_size, void *); - Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *); + Newx(PL_my_cxt_list, PL_my_cxt_size, void *); + Copy(proto_perl->Imy_cxt_list, PL_my_cxt_list, PL_my_cxt_size, void *); } else { - PL_my_cxt_list = (void**)NULL; + PL_my_cxt_list = (void**)NULL; } PL_modglobal = hv_dup_inc(proto_perl->Imodglobal, param); PL_custom_op_names = hv_dup_inc(proto_perl->Icustom_op_names,param); @@ -15637,9 +15637,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* XXX this only works if the saved cop has already been cloned */ if (proto_perl->Iparser) { - PL_parser->saved_curcop = (COP*)any_dup( - proto_perl->Iparser->saved_curcop, - proto_perl); + PL_parser->saved_curcop = (COP*)any_dup( + proto_perl->Iparser->saved_curcop, + proto_perl); } PL_subname = sv_dup_inc(proto_perl->Isubname, param); @@ -15745,71 +15745,71 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif if (proto_perl->Ipsig_pend) { - Newxz(PL_psig_pend, SIG_SIZE, int); + Newxz(PL_psig_pend, SIG_SIZE, int); } else { - PL_psig_pend = (int*)NULL; + PL_psig_pend = (int*)NULL; } if (proto_perl->Ipsig_name) { - Newx(PL_psig_name, 2 * SIG_SIZE, SV*); - sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE, - param); - PL_psig_ptr = PL_psig_name + SIG_SIZE; + Newx(PL_psig_name, 2 * SIG_SIZE, SV*); + sv_dup_inc_multiple(proto_perl->Ipsig_name, PL_psig_name, 2 * SIG_SIZE, + param); + PL_psig_ptr = PL_psig_name + SIG_SIZE; } else { - PL_psig_ptr = (SV**)NULL; - PL_psig_name = (SV**)NULL; + PL_psig_ptr = (SV**)NULL; + PL_psig_name = (SV**)NULL; } if (flags & CLONEf_COPY_STACKS) { - Newx(PL_tmps_stack, PL_tmps_max, SV*); - sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, - PL_tmps_ix+1, param); - - /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ - i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; - Newx(PL_markstack, i, I32); - PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max - - proto_perl->Imarkstack); - PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr - - proto_perl->Imarkstack); - Copy(proto_perl->Imarkstack, PL_markstack, - PL_markstack_ptr - PL_markstack + 1, I32); - - /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] - * NOTE: unlike the others! */ - Newx(PL_scopestack, PL_scopestack_max, I32); - Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); + Newx(PL_tmps_stack, PL_tmps_max, SV*); + sv_dup_inc_multiple(proto_perl->Itmps_stack, PL_tmps_stack, + PL_tmps_ix+1, param); + + /* next PUSHMARK() sets *(PL_markstack_ptr+1) */ + i = proto_perl->Imarkstack_max - proto_perl->Imarkstack; + Newx(PL_markstack, i, I32); + PL_markstack_max = PL_markstack + (proto_perl->Imarkstack_max + - proto_perl->Imarkstack); + PL_markstack_ptr = PL_markstack + (proto_perl->Imarkstack_ptr + - proto_perl->Imarkstack); + Copy(proto_perl->Imarkstack, PL_markstack, + PL_markstack_ptr - PL_markstack + 1, I32); + + /* next push_scope()/ENTER sets PL_scopestack[PL_scopestack_ix] + * NOTE: unlike the others! */ + Newx(PL_scopestack, PL_scopestack_max, I32); + Copy(proto_perl->Iscopestack, PL_scopestack, PL_scopestack_ix, I32); #ifdef DEBUGGING - Newx(PL_scopestack_name, PL_scopestack_max, const char *); - Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *); + Newx(PL_scopestack_name, PL_scopestack_max, const char *); + Copy(proto_perl->Iscopestack_name, PL_scopestack_name, PL_scopestack_ix, const char *); #endif /* reset stack AV to correct length before its duped via * PL_curstackinfo */ AvFILLp(proto_perl->Icurstack) = proto_perl->Istack_sp - proto_perl->Istack_base; - /* NOTE: si_dup() looks at PL_markstack */ - PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param); + /* NOTE: si_dup() looks at PL_markstack */ + PL_curstackinfo = si_dup(proto_perl->Icurstackinfo, param); - /* PL_curstack = PL_curstackinfo->si_stack; */ - PL_curstack = av_dup(proto_perl->Icurstack, param); - PL_mainstack = av_dup(proto_perl->Imainstack, param); + /* PL_curstack = PL_curstackinfo->si_stack; */ + PL_curstack = av_dup(proto_perl->Icurstack, param); + PL_mainstack = av_dup(proto_perl->Imainstack, param); - /* next PUSHs() etc. set *(PL_stack_sp+1) */ - PL_stack_base = AvARRAY(PL_curstack); - PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp - - proto_perl->Istack_base); - PL_stack_max = PL_stack_base + AvMAX(PL_curstack); + /* next PUSHs() etc. set *(PL_stack_sp+1) */ + PL_stack_base = AvARRAY(PL_curstack); + PL_stack_sp = PL_stack_base + (proto_perl->Istack_sp + - proto_perl->Istack_base); + PL_stack_max = PL_stack_base + AvMAX(PL_curstack); - /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ - PL_savestack = ss_dup(proto_perl, param); + /*Newxz(PL_savestack, PL_savestack_max, ANY);*/ + PL_savestack = ss_dup(proto_perl, param); } else { - init_stacks(); - ENTER; /* perl_destruct() wants to LEAVE; */ + init_stacks(); + ENTER; /* perl_destruct() wants to LEAVE; */ } PL_statgv = gv_dup(proto_perl->Istatgv, param); @@ -15831,13 +15831,13 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_stashcache = newHV(); PL_watchaddr = (char **) ptr_table_fetch(PL_ptr_table, - proto_perl->Iwatchaddr); + proto_perl->Iwatchaddr); PL_watchok = PL_watchaddr ? * PL_watchaddr : NULL; if (PL_debug && PL_watchaddr) { - PerlIO_printf(Perl_debug_log, - "WATCHING: %" UVxf " cloned as %" UVxf " with value %" UVxf "\n", - PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr), - PTR2UV(PL_watchok)); + PerlIO_printf(Perl_debug_log, + "WATCHING: %" UVxf " cloned as %" UVxf " with value %" UVxf "\n", + PTR2UV(proto_perl->Iwatchaddr), PTR2UV(PL_watchaddr), + PTR2UV(PL_watchok)); } PL_registered_mros = hv_dup_inc(proto_perl->Iregistered_mros, param); @@ -15847,19 +15847,19 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, identified by sv_dup() above. */ while(av_count(param->stashes) != 0) { - 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); - mXPUSHs(newSVhek(HvNAME_HEK(stash))); - PUTBACK; - call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD); - FREETMPS; - LEAVE; - } + 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); + mXPUSHs(newSVhek(HvNAME_HEK(stash))); + PUTBACK; + call_sv(MUTABLE_SV(GvCV(cloner)), G_DISCARD); + FREETMPS; + LEAVE; + } } if (!(flags & CLONEf_KEEP_PTR_TABLE)) { @@ -15868,15 +15868,15 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, } if (!(flags & CLONEf_COPY_STACKS)) { - unreferenced_to_tmp_stack(param->unreferenced); + unreferenced_to_tmp_stack(param->unreferenced); } SvREFCNT_dec(param->stashes); /* orphaned? eg threads->new inside BEGIN or use */ if (PL_compcv && ! SvREFCNT(PL_compcv)) { - SvREFCNT_inc_simple_void(PL_compcv); - SAVEFREESV(PL_compcv); + SvREFCNT_inc_simple_void(PL_compcv); + SAVEFREESV(PL_compcv); } return my_perl; @@ -15888,40 +15888,40 @@ S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced) PERL_ARGS_ASSERT_UNREFERENCED_TO_TMP_STACK; if (AvFILLp(unreferenced) > -1) { - SV **svp = AvARRAY(unreferenced); - SV **const last = svp + AvFILLp(unreferenced); - SSize_t count = 0; - - do { - if (SvREFCNT(*svp) == 1) - ++count; - } while (++svp <= last); - - EXTEND_MORTAL(count); - svp = AvARRAY(unreferenced); - - do { - if (SvREFCNT(*svp) == 1) { - /* Our reference is the only one to this SV. This means that - in this thread, the scalar effectively has a 0 reference. - That doesn't work (cleanup never happens), so donate our - reference to it onto the save stack. */ - PL_tmps_stack[++PL_tmps_ix] = *svp; - } else { - /* As an optimisation, because we are already walking the - entire array, instead of above doing either - SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead - release our reference to the scalar, so that at the end of - the array owns zero references to the scalars it happens to - point to. We are effectively converting the array from - AvREAL() on to AvREAL() off. This saves the av_clear() - (triggered by the SvREFCNT_dec(unreferenced) below) from - walking the array a second time. */ - SvREFCNT_dec(*svp); - } - - } while (++svp <= last); - AvREAL_off(unreferenced); + SV **svp = AvARRAY(unreferenced); + SV **const last = svp + AvFILLp(unreferenced); + SSize_t count = 0; + + do { + if (SvREFCNT(*svp) == 1) + ++count; + } while (++svp <= last); + + EXTEND_MORTAL(count); + svp = AvARRAY(unreferenced); + + do { + if (SvREFCNT(*svp) == 1) { + /* Our reference is the only one to this SV. This means that + in this thread, the scalar effectively has a 0 reference. + That doesn't work (cleanup never happens), so donate our + reference to it onto the save stack. */ + PL_tmps_stack[++PL_tmps_ix] = *svp; + } else { + /* As an optimisation, because we are already walking the + entire array, instead of above doing either + SvREFCNT_inc(*svp) or *svp = &PL_sv_undef, we can instead + release our reference to the scalar, so that at the end of + the array owns zero references to the scalars it happens to + point to. We are effectively converting the array from + AvREAL() on to AvREAL() off. This saves the av_clear() + (triggered by the SvREFCNT_dec(unreferenced) below) from + walking the array a second time. */ + SvREFCNT_dec(*svp); + } + + } while (++svp <= last); + AvREAL_off(unreferenced); } SvREFCNT_dec_NN(unreferenced); } @@ -15936,17 +15936,17 @@ Perl_clone_params_del(CLONE_PARAMS *param) PERL_ARGS_ASSERT_CLONE_PARAMS_DEL; if (was != to) { - PERL_SET_THX(to); + PERL_SET_THX(to); } SvREFCNT_dec(param->stashes); if (param->unreferenced) - unreferenced_to_tmp_stack(param->unreferenced); + unreferenced_to_tmp_stack(param->unreferenced); Safefree(param); if (was != to) { - PERL_SET_THX(was); + PERL_SET_THX(was); } } @@ -15963,7 +15963,7 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) PERL_ARGS_ASSERT_CLONE_PARAMS_NEW; if (was != to) { - PERL_SET_THX(to); + PERL_SET_THX(to); } /* Given that we've set the context, we can do this unshared. */ @@ -15977,7 +15977,7 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) param->unreferenced = (AV *)Perl_newSV_type(to, SVt_PVAV); if (was != to) { - PERL_SET_THX(was); + PERL_SET_THX(was); } return param; } @@ -15995,20 +15995,20 @@ Perl_init_constants(pTHX) SvANY(&PL_sv_no) = new_XPVNV(); SvREFCNT(&PL_sv_no) = SvREFCNT_IMMORTAL; SvFLAGS(&PL_sv_no) = SVt_PVNV|SVf_READONLY|SVf_PROTECT - |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK - |SVp_POK|SVf_POK; + |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK + |SVp_POK|SVf_POK; SvANY(&PL_sv_yes) = new_XPVNV(); SvREFCNT(&PL_sv_yes) = SvREFCNT_IMMORTAL; SvFLAGS(&PL_sv_yes) = SVt_PVNV|SVf_READONLY|SVf_PROTECT - |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK - |SVp_POK|SVf_POK; + |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK + |SVp_POK|SVf_POK; SvANY(&PL_sv_zero) = new_XPVNV(); SvREFCNT(&PL_sv_zero) = SvREFCNT_IMMORTAL; SvFLAGS(&PL_sv_zero) = SVt_PVNV|SVf_READONLY|SVf_PROTECT - |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK - |SVp_POK|SVf_POK + |SVp_IOK|SVf_IOK|SVp_NOK|SVf_NOK + |SVp_POK|SVf_POK |SVs_PADTMP; SvPV_set(&PL_sv_no, (char*)PL_No); @@ -16076,23 +16076,23 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) PERL_ARGS_ASSERT_SV_RECODE_TO_UTF8; if (SvPOK(sv) && !SvUTF8(sv) && !IN_BYTES && SvROK(encoding)) { - SV *uni; - STRLEN len; - const char *s; - dSP; - SV *nsv = sv; - ENTER; - PUSHSTACK; - SAVETMPS; - if (SvPADTMP(nsv)) { - nsv = sv_newmortal(); - SvSetSV_nosteal(nsv, sv); - } - save_re_context(); - PUSHMARK(sp); - EXTEND(SP, 3); - PUSHs(encoding); - PUSHs(nsv); + SV *uni; + STRLEN len; + const char *s; + dSP; + SV *nsv = sv; + ENTER; + PUSHSTACK; + SAVETMPS; + if (SvPADTMP(nsv)) { + nsv = sv_newmortal(); + SvSetSV_nosteal(nsv, sv); + } + save_re_context(); + PUSHMARK(sp); + EXTEND(SP, 3); + PUSHs(encoding); + PUSHs(nsv); /* NI-S 2002/07/09 Passing sv_yes is wrong - it needs to be or'ed set of constants @@ -16101,32 +16101,32 @@ Perl_sv_recode_to_utf8(pTHX_ SV *sv, SV *encoding) Both will default the value - let them. - XPUSHs(&PL_sv_yes); + XPUSHs(&PL_sv_yes); */ - PUTBACK; - call_method("decode", G_SCALAR); - SPAGAIN; - uni = POPs; - PUTBACK; - s = SvPV_const(uni, len); - if (s != SvPVX_const(sv)) { - SvGROW(sv, len + 1); - Move(s, SvPVX(sv), len + 1, char); - SvCUR_set(sv, len); - } - FREETMPS; - POPSTACK; - LEAVE; - if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { - /* clear pos and any utf8 cache */ - MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); - if (mg) - mg->mg_len = -1; - if ((mg = mg_find(sv, PERL_MAGIC_utf8))) - magic_setutf8(sv,mg); /* clear UTF8 cache */ - } - SvUTF8_on(sv); - return SvPVX(sv); + PUTBACK; + call_method("decode", G_SCALAR); + SPAGAIN; + uni = POPs; + PUTBACK; + s = SvPV_const(uni, len); + if (s != SvPVX_const(sv)) { + SvGROW(sv, len + 1); + Move(s, SvPVX(sv), len + 1, char); + SvCUR_set(sv, len); + } + FREETMPS; + POPSTACK; + LEAVE; + if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv)) { + /* clear pos and any utf8 cache */ + MAGIC * mg = mg_find(sv, PERL_MAGIC_regex_global); + if (mg) + mg->mg_len = -1; + if ((mg = mg_find(sv, PERL_MAGIC_utf8))) + magic_setutf8(sv,mg); /* clear UTF8 cache */ + } + SvUTF8_on(sv); + return SvPVX(sv); } return SvPOKp(sv) ? SvPVX(sv) : NULL; } @@ -16148,34 +16148,34 @@ Returns TRUE if the terminator was found, else returns FALSE. bool Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, - SV *ssv, int *offset, char *tstr, int tlen) + SV *ssv, int *offset, char *tstr, int tlen) { bool ret = FALSE; PERL_ARGS_ASSERT_SV_CAT_DECODE; if (SvPOK(ssv) && SvPOK(dsv) && SvROK(encoding)) { - SV *offsv; - dSP; - ENTER; - SAVETMPS; - save_re_context(); - PUSHMARK(sp); - EXTEND(SP, 6); - PUSHs(encoding); - PUSHs(dsv); - PUSHs(ssv); - offsv = newSViv(*offset); - mPUSHs(offsv); - mPUSHp(tstr, tlen); - PUTBACK; - call_method("cat_decode", G_SCALAR); - SPAGAIN; - ret = SvTRUE(TOPs); - *offset = SvIV(offsv); - PUTBACK; - FREETMPS; - LEAVE; + SV *offsv; + dSP; + ENTER; + SAVETMPS; + save_re_context(); + PUSHMARK(sp); + EXTEND(SP, 6); + PUSHs(encoding); + PUSHs(dsv); + PUSHs(ssv); + offsv = newSViv(*offset); + mPUSHs(offsv); + mPUSHp(tstr, tlen); + PUTBACK; + call_method("cat_decode", G_SCALAR); + SPAGAIN; + ret = SvTRUE(TOPs); + *offset = SvIV(offsv); + PUTBACK; + FREETMPS; + LEAVE; } else Perl_croak(aTHX_ "Invalid argument to sv_cat_decode"); @@ -16205,25 +16205,25 @@ S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) PERL_ARGS_ASSERT_FIND_HASH_SUBSCRIPT; if (!hv || SvMAGICAL(hv) || !HvARRAY(hv) || - (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) - return NULL; + (HvTOTALKEYS(hv) > FUV_MAX_SEARCH_SIZE)) + return NULL; array = HvARRAY(hv); for (i=HvMAX(hv); i>=0; i--) { - HE *entry; - for (entry = array[i]; entry; entry = HeNEXT(entry)) { - if (HeVAL(entry) != val) - continue; - if ( HeVAL(entry) == &PL_sv_undef || - HeVAL(entry) == &PL_sv_placeholder) - continue; - if (!HeKEY(entry)) - return NULL; - if (HeKLEN(entry) == HEf_SVKEY) - return sv_mortalcopy(HeKEY_sv(entry)); - return sv_2mortal(newSVhek(HeKEY_hek(entry))); - } + HE *entry; + for (entry = array[i]; entry; entry = HeNEXT(entry)) { + if (HeVAL(entry) != val) + continue; + if ( HeVAL(entry) == &PL_sv_undef || + HeVAL(entry) == &PL_sv_placeholder) + continue; + if (!HeKEY(entry)) + return NULL; + if (HeKLEN(entry) == HEf_SVKEY) + return sv_mortalcopy(HeKEY_sv(entry)); + return sv_2mortal(newSVhek(HeKEY_hek(entry))); + } } return NULL; } @@ -16237,16 +16237,16 @@ S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) PERL_ARGS_ASSERT_FIND_ARRAY_SUBSCRIPT; if (!av || SvMAGICAL(av) || !AvARRAY(av) || - (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) - return -1; + (AvFILLp(av) > FUV_MAX_SEARCH_SIZE)) + return -1; if (val != &PL_sv_undef) { - SV ** const svp = AvARRAY(av); - SSize_t i; + SV ** const svp = AvARRAY(av); + SSize_t i; - for (i=AvFILLp(av); i>=0; i--) - if (svp[i] == val) - return i; + for (i=AvFILLp(av); i>=0; i--) + if (svp[i] == val) + return i; } return -1; } @@ -16264,59 +16264,59 @@ S_find_array_subscript(pTHX_ const AV *const av, const SV *const val) SV* Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, - const SV *const keyname, SSize_t aindex, int subscript_type) + const SV *const keyname, SSize_t aindex, int subscript_type) { SV * const name = sv_newmortal(); if (gv && isGV(gv)) { - char buffer[2]; - buffer[0] = gvtype; - buffer[1] = 0; + char buffer[2]; + buffer[0] = gvtype; + buffer[1] = 0; - /* as gv_fullname4(), but add literal '^' for $^FOO names */ + /* as gv_fullname4(), but add literal '^' for $^FOO names */ - gv_fullname4(name, gv, buffer, 0); + gv_fullname4(name, gv, buffer, 0); - if ((unsigned int)SvPVX(name)[1] <= 26) { - buffer[0] = '^'; - buffer[1] = SvPVX(name)[1] + 'A' - 1; + if ((unsigned int)SvPVX(name)[1] <= 26) { + buffer[0] = '^'; + buffer[1] = SvPVX(name)[1] + 'A' - 1; - /* Swap the 1 unprintable control character for the 2 byte pretty - version - ie substr($name, 1, 1) = $buffer; */ - sv_insert(name, 1, 1, buffer, 2); - } + /* Swap the 1 unprintable control character for the 2 byte pretty + version - ie substr($name, 1, 1) = $buffer; */ + sv_insert(name, 1, 1, buffer, 2); + } } else { - CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL); - PADNAME *sv; + CV * const cv = gv ? ((CV *)gv) : find_runcv(NULL); + PADNAME *sv; - assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); + assert(!cv || SvTYPE(cv) == SVt_PVCV || SvTYPE(cv) == SVt_PVFM); - if (!cv || !CvPADLIST(cv)) - return NULL; - sv = padnamelist_fetch(PadlistNAMES(CvPADLIST(cv)), targ); - sv_setpvn(name, PadnamePV(sv), PadnameLEN(sv)); - SvUTF8_on(name); + if (!cv || !CvPADLIST(cv)) + return NULL; + sv = padnamelist_fetch(PadlistNAMES(CvPADLIST(cv)), targ); + sv_setpvn(name, PadnamePV(sv), PadnameLEN(sv)); + SvUTF8_on(name); } if (subscript_type == FUV_SUBSCRIPT_HASH) { - SV * const sv = newSV(0); + SV * const sv = newSV(0); STRLEN len; const char * const pv = SvPV_nomg_const((SV*)keyname, len); - *SvPVX(name) = '$'; - Perl_sv_catpvf(aTHX_ name, "{%s}", - pv_pretty(sv, pv, len, 32, NULL, NULL, - PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT )); - SvREFCNT_dec_NN(sv); + *SvPVX(name) = '$'; + Perl_sv_catpvf(aTHX_ name, "{%s}", + pv_pretty(sv, pv, len, 32, NULL, NULL, + PERL_PV_PRETTY_DUMP | PERL_PV_ESCAPE_UNI_DETECT )); + SvREFCNT_dec_NN(sv); } else if (subscript_type == FUV_SUBSCRIPT_ARRAY) { - *SvPVX(name) = '$'; - Perl_sv_catpvf(aTHX_ name, "[%" IVdf "]", (IV)aindex); + *SvPVX(name) = '$'; + Perl_sv_catpvf(aTHX_ name, "[%" IVdf "]", (IV)aindex); } 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); + /* 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; @@ -16348,7 +16348,7 @@ C/C points to the currently executing pad. STATIC SV * S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, - bool match, const char **desc_p) + bool match, const char **desc_p) { SV *sv; const GV *gv; @@ -16357,8 +16357,8 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, PERL_ARGS_ASSERT_FIND_UNINIT_VAR; if (!obase || (match && (!uninit_sv || uninit_sv == &PL_sv_undef || - uninit_sv == &PL_sv_placeholder))) - return NULL; + uninit_sv == &PL_sv_placeholder))) + return NULL; switch (obase->op_type) { @@ -16372,216 +16372,216 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, case OP_PADAV: case OP_PADHV: { - const bool pad = ( obase->op_type == OP_PADAV + const bool pad = ( obase->op_type == OP_PADAV || obase->op_type == OP_PADHV || obase->op_type == OP_PADRANGE ); - const bool hash = ( obase->op_type == OP_PADHV + const bool hash = ( obase->op_type == OP_PADHV || obase->op_type == OP_RV2HV || (obase->op_type == OP_PADRANGE && SvTYPE(PAD_SVl(obase->op_targ)) == SVt_PVHV) ); - SSize_t index = 0; - SV *keysv = NULL; - int subscript_type = FUV_SUBSCRIPT_WITHIN; - - if (pad) { /* @lex, %lex */ - sv = PAD_SVl(obase->op_targ); - gv = NULL; - } - else { - if (cUNOPx(obase)->op_first->op_type == OP_GV) { - /* @global, %global */ - gv = cGVOPx_gv(cUNOPx(obase)->op_first); - if (!gv) - break; - sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv)); - } - else if (obase == PL_op) /* @{expr}, %{expr} */ - return find_uninit_var(cUNOPx(obase)->op_first, + SSize_t index = 0; + SV *keysv = NULL; + int subscript_type = FUV_SUBSCRIPT_WITHIN; + + if (pad) { /* @lex, %lex */ + sv = PAD_SVl(obase->op_targ); + gv = NULL; + } + else { + if (cUNOPx(obase)->op_first->op_type == OP_GV) { + /* @global, %global */ + gv = cGVOPx_gv(cUNOPx(obase)->op_first); + if (!gv) + break; + sv = hash ? MUTABLE_SV(GvHV(gv)): MUTABLE_SV(GvAV(gv)); + } + else if (obase == PL_op) /* @{expr}, %{expr} */ + return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, match, desc_p); - else /* @{expr}, %{expr} as a sub-expression */ - return NULL; - } - - /* attempt to find a match within the aggregate */ - if (hash) { - keysv = find_hash_subscript((const HV*)sv, uninit_sv); - if (keysv) - subscript_type = FUV_SUBSCRIPT_HASH; - } - else { - index = find_array_subscript((const AV *)sv, uninit_sv); - if (index >= 0) - subscript_type = FUV_SUBSCRIPT_ARRAY; - } - - if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) - break; - - return varname(gv, (char)(hash ? '%' : '@'), obase->op_targ, - keysv, index, subscript_type); + else /* @{expr}, %{expr} as a sub-expression */ + return NULL; + } + + /* attempt to find a match within the aggregate */ + if (hash) { + keysv = find_hash_subscript((const HV*)sv, uninit_sv); + if (keysv) + subscript_type = FUV_SUBSCRIPT_HASH; + } + else { + index = find_array_subscript((const AV *)sv, uninit_sv); + if (index >= 0) + subscript_type = FUV_SUBSCRIPT_ARRAY; + } + + if (match && subscript_type == FUV_SUBSCRIPT_WITHIN) + break; + + return varname(gv, (char)(hash ? '%' : '@'), obase->op_targ, + keysv, index, subscript_type); } case OP_RV2SV: - if (cUNOPx(obase)->op_first->op_type == OP_GV) { - /* $global */ - gv = cGVOPx_gv(cUNOPx(obase)->op_first); - if (!gv || !GvSTASH(gv)) - break; - if (match && (GvSV(gv) != uninit_sv)) - break; - return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); - } - /* ${expr} */ - return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1, desc_p); + if (cUNOPx(obase)->op_first->op_type == OP_GV) { + /* $global */ + gv = cGVOPx_gv(cUNOPx(obase)->op_first); + if (!gv || !GvSTASH(gv)) + break; + if (match && (GvSV(gv) != uninit_sv)) + break; + return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); + } + /* ${expr} */ + return find_uninit_var(cUNOPx(obase)->op_first, uninit_sv, 1, desc_p); case OP_PADSV: - if (match && PAD_SVl(obase->op_targ) != uninit_sv) - break; - return varname(NULL, '$', obase->op_targ, - NULL, 0, FUV_SUBSCRIPT_NONE); + if (match && PAD_SVl(obase->op_targ) != uninit_sv) + break; + return varname(NULL, '$', obase->op_targ, + NULL, 0, FUV_SUBSCRIPT_NONE); case OP_GVSV: - gv = cGVOPx_gv(obase); - if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv)) - break; - return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); + gv = cGVOPx_gv(obase); + if (!gv || (match && GvSV(gv) != uninit_sv) || !GvSTASH(gv)) + break; + return varname(gv, '$', 0, NULL, 0, FUV_SUBSCRIPT_NONE); case OP_AELEMFAST_LEX: - if (match) { - SV **svp; - AV *av = MUTABLE_AV(PAD_SV(obase->op_targ)); - if (!av || SvRMAGICAL(av)) - break; - svp = av_fetch(av, (I8)obase->op_private, FALSE); - if (!svp || *svp != uninit_sv) - break; - } - return varname(NULL, '$', obase->op_targ, - NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY); + if (match) { + SV **svp; + AV *av = MUTABLE_AV(PAD_SV(obase->op_targ)); + if (!av || SvRMAGICAL(av)) + break; + svp = av_fetch(av, (I8)obase->op_private, FALSE); + if (!svp || *svp != uninit_sv) + break; + } + return varname(NULL, '$', obase->op_targ, + NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY); case OP_AELEMFAST: - { - gv = cGVOPx_gv(obase); - if (!gv) - break; - if (match) { - SV **svp; - AV *const av = GvAV(gv); - if (!av || SvRMAGICAL(av)) - break; - svp = av_fetch(av, (I8)obase->op_private, FALSE); - if (!svp || *svp != uninit_sv) - break; - } - return varname(gv, '$', 0, - NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY); - } - NOT_REACHED; /* NOTREACHED */ + { + gv = cGVOPx_gv(obase); + if (!gv) + break; + if (match) { + SV **svp; + AV *const av = GvAV(gv); + if (!av || SvRMAGICAL(av)) + break; + svp = av_fetch(av, (I8)obase->op_private, FALSE); + if (!svp || *svp != uninit_sv) + break; + } + return varname(gv, '$', 0, + NULL, (I8)obase->op_private, FUV_SUBSCRIPT_ARRAY); + } + NOT_REACHED; /* NOTREACHED */ case OP_EXISTS: - o = cUNOPx(obase)->op_first; - if (!o || o->op_type != OP_NULL || - ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM)) - break; - return find_uninit_var(cBINOPo->op_last, uninit_sv, match, desc_p); + o = cUNOPx(obase)->op_first; + if (!o || o->op_type != OP_NULL || + ! (o->op_targ == OP_AELEM || o->op_targ == OP_HELEM)) + break; + return find_uninit_var(cBINOPo->op_last, uninit_sv, match, desc_p); case OP_AELEM: case OP_HELEM: { - bool negate = FALSE; + bool negate = FALSE; - if (PL_op == obase) - /* $a[uninit_expr] or $h{uninit_expr} */ - return find_uninit_var(cBINOPx(obase)->op_last, + if (PL_op == obase) + /* $a[uninit_expr] or $h{uninit_expr} */ + return find_uninit_var(cBINOPx(obase)->op_last, uninit_sv, match, desc_p); - gv = NULL; - o = cBINOPx(obase)->op_first; - kid = cBINOPx(obase)->op_last; - - /* get the av or hv, and optionally the gv */ - sv = NULL; - if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) { - sv = PAD_SV(o->op_targ); - } - else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) - && cUNOPo->op_first->op_type == OP_GV) - { - gv = cGVOPx_gv(cUNOPo->op_first); - if (!gv) - break; - sv = o->op_type - == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv)); - } - if (!sv) - break; - - if (kid && kid->op_type == OP_NEGATE) { - negate = TRUE; - kid = cUNOPx(kid)->op_first; - } - - if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) { - /* index is constant */ - SV* kidsv; - if (negate) { - kidsv = newSVpvs_flags("-", SVs_TEMP); - sv_catsv(kidsv, cSVOPx_sv(kid)); - } - else - kidsv = cSVOPx_sv(kid); - if (match) { - if (SvMAGICAL(sv)) - break; - if (obase->op_type == OP_HELEM) { - HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0); - if (!he || HeVAL(he) != uninit_sv) - break; - } - else { - SV * const opsv = cSVOPx_sv(kid); - const IV opsviv = SvIV(opsv); - SV * const * const svp = av_fetch(MUTABLE_AV(sv), - negate ? - opsviv : opsviv, - FALSE); - if (!svp || *svp != uninit_sv) - break; - } - } - if (obase->op_type == OP_HELEM) - return varname(gv, '%', o->op_targ, - kidsv, 0, FUV_SUBSCRIPT_HASH); - else - return varname(gv, '@', o->op_targ, NULL, - negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)), - FUV_SUBSCRIPT_ARRAY); - } - else { - /* index is an expression; - * attempt to find a match within the aggregate */ - if (obase->op_type == OP_HELEM) { - SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); - if (keysv) - return varname(gv, '%', o->op_targ, - keysv, 0, FUV_SUBSCRIPT_HASH); - } - else { - const SSize_t index - = find_array_subscript((const AV *)sv, uninit_sv); - if (index >= 0) - return varname(gv, '@', o->op_targ, - NULL, index, FUV_SUBSCRIPT_ARRAY); - } - if (match) - break; - return varname(gv, - (char)((o->op_type == OP_PADAV || o->op_type == OP_RV2AV) - ? '@' : '%'), - o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN); - } - NOT_REACHED; /* NOTREACHED */ + gv = NULL; + o = cBINOPx(obase)->op_first; + kid = cBINOPx(obase)->op_last; + + /* get the av or hv, and optionally the gv */ + sv = NULL; + if (o->op_type == OP_PADAV || o->op_type == OP_PADHV) { + sv = PAD_SV(o->op_targ); + } + else if ((o->op_type == OP_RV2AV || o->op_type == OP_RV2HV) + && cUNOPo->op_first->op_type == OP_GV) + { + gv = cGVOPx_gv(cUNOPo->op_first); + if (!gv) + break; + sv = o->op_type + == OP_RV2HV ? MUTABLE_SV(GvHV(gv)) : MUTABLE_SV(GvAV(gv)); + } + if (!sv) + break; + + if (kid && kid->op_type == OP_NEGATE) { + negate = TRUE; + kid = cUNOPx(kid)->op_first; + } + + if (kid && kid->op_type == OP_CONST && SvOK(cSVOPx_sv(kid))) { + /* index is constant */ + SV* kidsv; + if (negate) { + kidsv = newSVpvs_flags("-", SVs_TEMP); + sv_catsv(kidsv, cSVOPx_sv(kid)); + } + else + kidsv = cSVOPx_sv(kid); + if (match) { + if (SvMAGICAL(sv)) + break; + if (obase->op_type == OP_HELEM) { + HE* he = hv_fetch_ent(MUTABLE_HV(sv), kidsv, 0, 0); + if (!he || HeVAL(he) != uninit_sv) + break; + } + else { + SV * const opsv = cSVOPx_sv(kid); + const IV opsviv = SvIV(opsv); + SV * const * const svp = av_fetch(MUTABLE_AV(sv), + negate ? - opsviv : opsviv, + FALSE); + if (!svp || *svp != uninit_sv) + break; + } + } + if (obase->op_type == OP_HELEM) + return varname(gv, '%', o->op_targ, + kidsv, 0, FUV_SUBSCRIPT_HASH); + else + return varname(gv, '@', o->op_targ, NULL, + negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)), + FUV_SUBSCRIPT_ARRAY); + } + else { + /* index is an expression; + * attempt to find a match within the aggregate */ + if (obase->op_type == OP_HELEM) { + SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); + if (keysv) + return varname(gv, '%', o->op_targ, + keysv, 0, FUV_SUBSCRIPT_HASH); + } + else { + const SSize_t index + = find_array_subscript((const AV *)sv, uninit_sv); + if (index >= 0) + return varname(gv, '@', o->op_targ, + NULL, index, FUV_SUBSCRIPT_ARRAY); + } + if (match) + break; + return varname(gv, + (char)((o->op_type == OP_PADAV || o->op_type == OP_RV2AV) + ? '@' : '%'), + o->op_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN); + } + NOT_REACHED; /* NOTREACHED */ } case OP_MULTIDEREF: { @@ -16702,8 +16702,8 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, actions >>= MDEREF_SHIFT; } /* while */ - if (PL_op == obase) { - /* most likely index was undef */ + if (PL_op == obase) { + /* most likely index was undef */ *desc_p = ( (actions & MDEREF_FLAG_last) && (obase->op_private @@ -16724,7 +16724,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, if (index_targ) { if (PL_curpad[index_targ] == uninit_sv) return varname(NULL, '$', index_targ, - NULL, 0, FUV_SUBSCRIPT_NONE); + NULL, 0, FUV_SUBSCRIPT_NONE); else return NULL; } @@ -16739,7 +16739,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, break; if (agg_targ) - sv = PAD_SV(agg_targ); + sv = PAD_SV(agg_targ); else if (agg_gv) { sv = is_hv ? MUTABLE_SV(GvHV(agg_gv)) : MUTABLE_SV(GvAV(agg_gv)); if (!sv) @@ -16748,43 +16748,43 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, else break; - if (index_type == MDEREF_INDEX_const) { - if (match) { - if (SvMAGICAL(sv)) - break; - if (is_hv) { - HE* he = hv_fetch_ent(MUTABLE_HV(sv), index_const_sv, 0, 0); - if (!he || HeVAL(he) != uninit_sv) - break; - } - else { - SV * const * const svp = + if (index_type == MDEREF_INDEX_const) { + if (match) { + if (SvMAGICAL(sv)) + break; + if (is_hv) { + HE* he = hv_fetch_ent(MUTABLE_HV(sv), index_const_sv, 0, 0); + if (!he || HeVAL(he) != uninit_sv) + break; + } + else { + SV * const * const svp = av_fetch(MUTABLE_AV(sv), index_const_iv, FALSE); - if (!svp || *svp != uninit_sv) - break; - } - } - return is_hv - ? varname(agg_gv, '%', agg_targ, + if (!svp || *svp != uninit_sv) + break; + } + } + return is_hv + ? varname(agg_gv, '%', agg_targ, index_const_sv, 0, FUV_SUBSCRIPT_HASH) - : varname(agg_gv, '@', agg_targ, + : varname(agg_gv, '@', agg_targ, NULL, index_const_iv, FUV_SUBSCRIPT_ARRAY); - } - else { - /* index is an var */ - if (is_hv) { - SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); - if (keysv) - return varname(agg_gv, '%', agg_targ, - keysv, 0, FUV_SUBSCRIPT_HASH); - } - else { - const SSize_t index - = find_array_subscript((const AV *)sv, uninit_sv); - if (index >= 0) - return varname(agg_gv, '@', agg_targ, - NULL, index, FUV_SUBSCRIPT_ARRAY); - } + } + else { + /* index is an var */ + if (is_hv) { + SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); + if (keysv) + return varname(agg_gv, '%', agg_targ, + keysv, 0, FUV_SUBSCRIPT_HASH); + } + else { + const SSize_t index + = find_array_subscript((const AV *)sv, uninit_sv); + if (index >= 0) + return varname(agg_gv, '@', agg_targ, + NULL, index, FUV_SUBSCRIPT_ARRAY); + } /* look for an element not found */ if (!SvMAGICAL(sv)) { SV *index_sv = NULL; @@ -16813,80 +16813,80 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, } } } - if (match) - break; - return varname(agg_gv, - is_hv ? '%' : '@', - agg_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN); - } - NOT_REACHED; /* NOTREACHED */ + if (match) + break; + return varname(agg_gv, + is_hv ? '%' : '@', + agg_targ, NULL, 0, FUV_SUBSCRIPT_WITHIN); + } + NOT_REACHED; /* NOTREACHED */ } case OP_AASSIGN: - /* only examine RHS */ - return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, + /* only examine RHS */ + return find_uninit_var(cBINOPx(obase)->op_first, uninit_sv, match, desc_p); case OP_OPEN: - o = cUNOPx(obase)->op_first; - if ( o->op_type == OP_PUSHMARK - || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK) + o = cUNOPx(obase)->op_first; + if ( o->op_type == OP_PUSHMARK + || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK) ) o = OpSIBLING(o); - if (!OpHAS_SIBLING(o)) { - /* one-arg version of open is highly magical */ - - if (o->op_type == OP_GV) { /* open FOO; */ - gv = cGVOPx_gv(o); - if (match && GvSV(gv) != uninit_sv) - break; - return varname(gv, '$', 0, - NULL, 0, FUV_SUBSCRIPT_NONE); - } - /* other possibilities not handled are: - * open $x; or open my $x; should return '${*$x}' - * open expr; should return '$'.expr ideally - */ - break; - } - match = 1; - goto do_op; + if (!OpHAS_SIBLING(o)) { + /* one-arg version of open is highly magical */ + + if (o->op_type == OP_GV) { /* open FOO; */ + gv = cGVOPx_gv(o); + if (match && GvSV(gv) != uninit_sv) + break; + return varname(gv, '$', 0, + NULL, 0, FUV_SUBSCRIPT_NONE); + } + /* other possibilities not handled are: + * open $x; or open my $x; should return '${*$x}' + * open expr; should return '$'.expr ideally + */ + break; + } + match = 1; + goto do_op; /* ops where $_ may be an implicit arg */ case OP_TRANS: case OP_TRANSR: case OP_SUBST: case OP_MATCH: - if ( !(obase->op_flags & OPf_STACKED)) { - if (uninit_sv == DEFSV) - return newSVpvs_flags("$_", SVs_TEMP); - else if (obase->op_targ - && uninit_sv == PAD_SVl(obase->op_targ)) - return varname(NULL, '$', obase->op_targ, NULL, 0, - FUV_SUBSCRIPT_NONE); - } - goto do_op; + if ( !(obase->op_flags & OPf_STACKED)) { + if (uninit_sv == DEFSV) + return newSVpvs_flags("$_", SVs_TEMP); + else if (obase->op_targ + && uninit_sv == PAD_SVl(obase->op_targ)) + return varname(NULL, '$', obase->op_targ, NULL, 0, + FUV_SUBSCRIPT_NONE); + } + goto do_op; 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) + 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 || (o->op_type == OP_NULL && o->op_targ == OP_PUSHMARK))) o = OpSIBLING(OpSIBLING(o)); - goto do_op2; + goto do_op2; case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */ 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) */ + /* the following ops are capable of returning PL_sv_undef even for + * defined arg(s) */ case OP_BACKTICK: case OP_PIPE_OP: @@ -16956,85 +16956,85 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, case OP_UNPACK: case OP_SYSOPEN: case OP_SYSSEEK: - match = 1; - goto do_op; + 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; + /* 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_FLIP: case OP_FLOP: { - GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV); - if (gv && GvSV(gv) == uninit_sv) - return newSVpvs_flags("$.", SVs_TEMP); - goto do_op; + GV * const gv = gv_fetchpvs(".", GV_NOTQUAL, SVt_PV); + if (gv && GvSV(gv) == uninit_sv) + return newSVpvs_flags("$.", SVs_TEMP); + goto do_op; } case OP_POS: - /* def-ness of rval pos() is independent of the def-ness of its arg */ - if ( !(obase->op_flags & OPf_MOD)) - break; + /* def-ness of rval pos() is independent of the def-ness of its arg */ + if ( !(obase->op_flags & OPf_MOD)) + break; /* FALLTHROUGH */ case OP_SCHOMP: case OP_CHOMP: - if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) - return newSVpvs_flags("${$/}", SVs_TEMP); - /* FALLTHROUGH */ + if (SvROK(PL_rs) && uninit_sv == SvRV(PL_rs)) + return newSVpvs_flags("${$/}", SVs_TEMP); + /* FALLTHROUGH */ default: do_op: - if (!(obase->op_flags & OPf_KIDS)) - break; - o = cUNOPx(obase)->op_first; + if (!(obase->op_flags & OPf_KIDS)) + break; + o = cUNOPx(obase)->op_first; do_op2: - if (!o) - break; - - /* This loop checks all the kid ops, skipping any that cannot pos- - * sibly be responsible for the uninitialized value; i.e., defined - * constants and ops that return nothing. If there is only one op - * left that is not skipped, then we *know* it is responsible for - * the uninitialized value. If there is more than one op left, we - * have to look for an exact match in the while() loop below. + if (!o) + break; + + /* This loop checks all the kid ops, skipping any that cannot pos- + * sibly be responsible for the uninitialized value; i.e., defined + * constants and ops that return nothing. If there is only one op + * left that is not skipped, then we *know* it is responsible for + * the uninitialized value. If there is more than one op left, we + * have to look for an exact match in the while() loop below. * Note that we skip padrange, because the individual pad ops that * it replaced are still in the tree, so we work on them instead. - */ - o2 = NULL; - for (kid=o; kid; kid = OpSIBLING(kid)) { - const OPCODE type = kid->op_type; - if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) - || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) - || (type == OP_PUSHMARK) - || (type == OP_PADRANGE) - ) - continue; - - if (o2) { /* more than one found */ - o2 = NULL; - break; - } - o2 = kid; - } - if (o2) - return find_uninit_var(o2, uninit_sv, match, desc_p); - - /* scan all args */ - while (o) { - sv = find_uninit_var(o, uninit_sv, 1, desc_p); - if (sv) - return sv; - o = OpSIBLING(o); - } - break; + */ + o2 = NULL; + for (kid=o; kid; kid = OpSIBLING(kid)) { + const OPCODE type = kid->op_type; + if ( (type == OP_CONST && SvOK(cSVOPx_sv(kid))) + || (type == OP_NULL && ! (kid->op_flags & OPf_KIDS)) + || (type == OP_PUSHMARK) + || (type == OP_PADRANGE) + ) + continue; + + if (o2) { /* more than one found */ + o2 = NULL; + break; + } + o2 = kid; + } + if (o2) + return find_uninit_var(o2, uninit_sv, match, desc_p); + + /* scan all args */ + while (o) { + sv = find_uninit_var(o, uninit_sv, 1, desc_p); + if (sv) + return sv; + o = OpSIBLING(o); + } + break; } return NULL; } @@ -17055,17 +17055,17 @@ Perl_report_uninit(pTHX_ const SV *uninit_sv) SV* varname = NULL; if (PL_op) { - desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded - ? "join or string" + desc = PL_op->op_type == OP_STRINGIFY && PL_op->op_folded + ? "join or string" : PL_op->op_type == OP_MULTICONCAT && (PL_op->op_private & OPpMULTICONCAT_FAKE) ? "sprintf" - : OP_DESC(PL_op); - if (uninit_sv && PL_curpad) { - varname = find_uninit_var(PL_op, uninit_sv, 0, &desc); - if (varname) - sv_insert(varname, 0, 0, " ", 1); - } + : OP_DESC(PL_op); + if (uninit_sv && PL_curpad) { + varname = find_uninit_var(PL_op, uninit_sv, 0, &desc); + if (varname) + sv_insert(varname, 0, 0, " ", 1); + } } else if (PL_curstackinfo->si_type == PERLSI_SORT && cxstack_ix == 0) /* we've reached the end of a sort block or sub,