X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/dd1a3ba7882ca70c1e85b0fd6c03d07856672075..b8a2649a502a2760c6bc90d32f71a03c232eee81:/sv.c diff --git a/sv.c b/sv.c index ed07e68..a268002 100644 --- a/sv.c +++ b/sv.c @@ -130,8 +130,7 @@ static const char S_destroy[] = "DESTROY"; /* ============================================================================ -=head1 Allocation and deallocation of SVs. - +=for apidoc_section SV Handling An SV (or AV, HV, etc.) is allocated in two parts: the head (struct sv, av, hv...) contains type and reference count information, and for many types, a pointer to the body (struct xrv, xpv, xpviv...), which @@ -409,7 +408,7 @@ S_del_sv(pTHX_ SV *p) /* -=head1 SV Manipulation Functions +=for apidoc_section SV Handling =for apidoc sv_add_arena @@ -883,6 +882,23 @@ struct body_details { U32 arena_size; /* Size of arena to allocate */ }; +#define ALIGNED_TYPE_NAME(name) name##_aligned +#define ALIGNED_TYPE(name) \ + typedef union { \ + name align_me; \ + NV nv; \ + IV iv; \ + } ALIGNED_TYPE_NAME(name); + +ALIGNED_TYPE(regexp); +ALIGNED_TYPE(XPVGV); +ALIGNED_TYPE(XPVLV); +ALIGNED_TYPE(XPVAV); +ALIGNED_TYPE(XPVHV); +ALIGNED_TYPE(XPVCV); +ALIGNED_TYPE(XPVFM); +ALIGNED_TYPE(XPVIO); + #define HADNV FALSE #define NONV TRUE @@ -971,48 +987,48 @@ static const struct body_details bodies_by_type[] = { { sizeof(XPVMG), copy_length(XPVMG, xnv_u), 0, SVt_PVMG, FALSE, HADNV, HASARENA, FIT_ARENA(0, sizeof(XPVMG)) }, - { sizeof(regexp), + { sizeof(ALIGNED_TYPE_NAME(regexp)), sizeof(regexp), 0, SVt_REGEXP, TRUE, NONV, HASARENA, - FIT_ARENA(0, sizeof(regexp)) + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(regexp))) }, - { sizeof(XPVGV), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, - HASARENA, FIT_ARENA(0, sizeof(XPVGV)) }, + { sizeof(ALIGNED_TYPE_NAME(XPVGV)), sizeof(XPVGV), 0, SVt_PVGV, TRUE, HADNV, + HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVGV))) }, - { sizeof(XPVLV), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, - HASARENA, FIT_ARENA(0, sizeof(XPVLV)) }, + { sizeof(ALIGNED_TYPE_NAME(XPVLV)), sizeof(XPVLV), 0, SVt_PVLV, TRUE, HADNV, + HASARENA, FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVLV))) }, - { sizeof(XPVAV), + { sizeof(ALIGNED_TYPE_NAME(XPVAV)), copy_length(XPVAV, xav_alloc), 0, SVt_PVAV, TRUE, NONV, HASARENA, - FIT_ARENA(0, sizeof(XPVAV)) }, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVAV))) }, - { sizeof(XPVHV), + { sizeof(ALIGNED_TYPE_NAME(XPVHV)), copy_length(XPVHV, xhv_max), 0, SVt_PVHV, TRUE, NONV, HASARENA, - FIT_ARENA(0, sizeof(XPVHV)) }, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVHV))) }, - { sizeof(XPVCV), + { sizeof(ALIGNED_TYPE_NAME(XPVCV)), sizeof(XPVCV), 0, SVt_PVCV, TRUE, NONV, HASARENA, - FIT_ARENA(0, sizeof(XPVCV)) }, + FIT_ARENA(0, sizeof(ALIGNED_TYPE_NAME(XPVCV))) }, - { sizeof(XPVFM), + { sizeof(ALIGNED_TYPE_NAME(XPVFM)), sizeof(XPVFM), 0, SVt_PVFM, TRUE, NONV, NOARENA, - FIT_ARENA(20, sizeof(XPVFM)) }, + FIT_ARENA(20, sizeof(ALIGNED_TYPE_NAME(XPVFM))) }, - { sizeof(XPVIO), + { sizeof(ALIGNED_TYPE_NAME(XPVIO)), sizeof(XPVIO), 0, SVt_PVIO, TRUE, NONV, HASARENA, - FIT_ARENA(24, sizeof(XPVIO)) }, + FIT_ARENA(24, sizeof(ALIGNED_TYPE_NAME(XPVIO))) }, }; #define new_body_allocated(sv_type) \ @@ -1068,14 +1084,9 @@ Perl_more_bodies (pTHX_ const svtype sv_type, const size_t body_size, char *start; const char *end; const size_t good_arena_size = Perl_malloc_good_size(arena_size); -#if defined(DEBUGGING) && defined(PERL_GLOBAL_STRUCT) - dVAR; -#endif -#if defined(DEBUGGING) && !defined(PERL_GLOBAL_STRUCT) +#if defined(DEBUGGING) static bool done_sanity_check; - /* PERL_GLOBAL_STRUCT cannot coexist with global - * variables like done_sanity_check. */ if (!done_sanity_check) { unsigned int i = SVt_LAST; @@ -2394,7 +2405,7 @@ S_sv_2iuv_common(pTHX_ SV *const sv) SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); } } - else { + else { if (isGV_with_GP(sv)) return glob_2number(MUTABLE_GV(sv)); @@ -2789,7 +2800,7 @@ Perl_sv_2nv_flags(pTHX_ SV *const sv, const I32 flags) SvFLAGS(sv) &= ~(SVf_IOK|SVf_NOK); #endif /* NV_PRESERVES_UV */ } - else { + else { if (isGV_with_GP(sv)) { glob_2number(MUTABLE_GV(sv)); return 0.0; @@ -3048,8 +3059,8 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) return RX_WRAPPED(re); } else { - const char *const typestr = sv_reftype(referent, 0); - const STRLEN typelen = strlen(typestr); + 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 */ @@ -3092,7 +3103,7 @@ Perl_sv_2pv_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) *--retval = '('; retval -= typelen; - memcpy(retval, typestr, typelen); + memcpy(retval, typestring, typelen); if (stashname) { *--retval = '='; @@ -3308,8 +3319,9 @@ Perl_sv_copypv_flags(pTHX_ SV *const dsv, SV *const ssv, const I32 flags) =for apidoc sv_2pvbyte Return a pointer to the byte-encoded representation of the SV, and set C<*lp> -to its length. May cause the SV to be downgraded from UTF-8 as a -side-effect. +to its length. If the SV is marked as being encoded as UTF-8, it will +downgrade it to a byte string as a side-effect, if possible. If the SV cannot +be downgraded, this croaks. Usually accessed via the C macro. @@ -4943,6 +4955,9 @@ The C parameter indicates the number of bytes to be copied. If the C argument is NULL the SV will become undefined. Does not handle 'set' magic. See C>. +The UTF-8 flag is not changed by this function. A terminating NUL byte is +guaranteed. + =cut */ @@ -5489,6 +5504,9 @@ C on C afterwards if appropriate. C and C are implemented in terms of this function. +=for apidoc Amnh||SV_CATUTF8 +=for apidoc Amnh||SV_CATBYTES + =cut */ @@ -6560,7 +6578,6 @@ instead. void Perl_sv_clear(pTHX_ SV *const orig_sv) { - dVAR; HV *stash; U32 type; const struct body_details *sv_type_details; @@ -6654,9 +6671,6 @@ Perl_sv_clear(pTHX_ SV *const orig_sv) sv_del_backref(MUTABLE_SV(stash), sv); goto freescalar; case SVt_PVHV: - if (PL_last_swash_hv == (const HV *)sv) { - PL_last_swash_hv = NULL; - } if (HvTOTALKEYS((HV*)sv) > 0) { const HEK *hek; /* this statement should match the one at the beginning of @@ -7086,7 +7100,6 @@ Perl_sv_free(pTHX_ SV *const sv) void Perl_sv_free2(pTHX_ SV *const sv, const U32 rc) { - dVAR; PERL_ARGS_ASSERT_SV_FREE2; @@ -8832,13 +8845,7 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) else { /*The big, slow, and stupid way. */ -#ifdef USE_HEAP_INSTEAD_OF_STACK /* Even slower way. */ - STDCHAR *buf = NULL; - Newx(buf, 8192, STDCHAR); - assert(buf); -#else STDCHAR buf[8192]; -#endif screamer2: if (rslen) { @@ -8887,9 +8894,6 @@ Perl_sv_gets(pTHX_ SV *const sv, PerlIO *const fp, I32 append) goto screamer2; } -#ifdef USE_HEAP_INSTEAD_OF_STACK - Safefree(buf); -#endif } if (rspara) { /* have to do this both before and after */ @@ -9312,7 +9316,6 @@ C is a convenience wrapper for this function, defined as #define newSVpvn_utf8(s, len, u) \ newSVpvn_flags((s), (len), (u) ? SVf_UTF8 : 0) -=for apidoc Amnh||SVf_UTF8 =for apidoc Amnh||SVs_TEMP =cut @@ -9361,7 +9364,6 @@ C> and C>. SV * Perl_sv_2mortal(pTHX_ SV *const sv) { - dVAR; if (!sv) return sv; if (SvIMMORTAL(sv)) @@ -9508,7 +9510,6 @@ C and hash lookup will avoid string compare. SV * Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) { - dVAR; SV *sv; bool is_utf8 = FALSE; const char *const orig_src = src; @@ -9582,6 +9583,14 @@ Perl_newSVpvf_nocontext(const char *const pat, ...) Creates a new SV and initializes it with the string formatted like C. +=for apidoc newSVpvf_nocontext +Like C> but does not take a thread context (C) parameter, +so is used in situations where the caller doesn't already have the thread +context. + +=for apidoc vnewSVpvf +Like C> but but the arguments are an encapsulated argument list. + =cut */ @@ -10145,7 +10154,7 @@ Perl_sv_pvn_force_flags(pTHX_ SV *const sv, STRLEN *const lp, const I32 flags) =for apidoc sv_pvbyten_force The backend for the C macro. Always use the macro -instead. +instead. If the SV cannot be downgraded from UTF-8, this croaks. =cut */ @@ -10304,8 +10313,12 @@ Perl_sv_isobject(pTHX_ SV *sv) =for apidoc sv_isa Returns a boolean indicating whether the SV is blessed into the specified -class. This does not check for subtypes; use C to verify -an inheritance relationship. +class. + +This does not check for subtypes or method overloading. Use C to +verify an inheritance relationship in the same way as the C operator by +respecting any C method overloading; or C to test +directly on the actual object type. =cut */ @@ -10793,6 +10806,11 @@ Perl_sv_setpvf_mg_nocontext(SV *const sv, const char *const pat, ...) Works like C but copies the text into the SV instead of appending it. Does not handle 'set' magic. See C>. +=for apidoc sv_setpvf_nocontext +Like C> but does not take a thread context (C) parameter, +so is used in situations where the caller doesn't already have the thread +context. + =cut */ @@ -10832,6 +10850,11 @@ Perl_sv_vsetpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) Like C, but also handles 'set' magic. +=for apidoc sv_setpvf_mg_nocontext +Like C>, but does not take a thread context (C) +parameter, so is used in situations where the caller doesn't already have the +thread context. + =cut */ @@ -10919,6 +10942,11 @@ upgraded to UTF-8. Handles 'get' magic, but not 'set' magic. See C>. If the original SV was UTF-8, the pattern should be valid UTF-8; if the original SV was bytes, the pattern should be too. +=for apidoc sv_catpvf_nocontext +Like C> but does not take a thread context (C) parameter, +so is used in situations where the caller doesn't already have the thread +context. + =cut */ void @@ -10958,6 +10986,11 @@ Perl_sv_vcatpvf(pTHX_ SV *const sv, const char *const pat, va_list *const args) Like C, but also handles 'set' magic. +=for apidoc sv_catpvf_mg_nocontext +Like C> but does not take a thread context (C) parameter, +so is used in situations where the caller doesn't already have the thread +context. + =cut */ @@ -12191,15 +12224,15 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* the asterisk specified a width */ { int i = 0; - SV *sv = NULL; + SV *width_sv = NULL; if (args) i = va_arg(*args, int); else { ix = ix ? ix - 1 : svix++; - sv = (ix < sv_count) ? svargs[ix] + width_sv = (ix < sv_count) ? svargs[ix] : (arg_missing = TRUE, (SV*)NULL); } - width = S_sprintf_arg_num_val(aTHX_ args, i, sv, &left); + width = S_sprintf_arg_num_val(aTHX_ args, i, width_sv, &left); } } else if (*q == 'v') { @@ -12246,17 +12279,17 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p { int i = 0; - SV *sv = NULL; + SV *width_sv = NULL; bool neg = FALSE; if (args) i = va_arg(*args, int); else { ix = ix ? ix - 1 : svix++; - sv = (ix < sv_count) ? svargs[ix] + width_sv = (ix < sv_count) ? svargs[ix] : (arg_missing = TRUE, (SV*)NULL); } - precis = S_sprintf_arg_num_val(aTHX_ args, i, sv, &neg); + precis = S_sprintf_arg_num_val(aTHX_ args, i, width_sv, &neg); has_precis = !neg; /* ignore negative precision */ if (!has_precis) @@ -12356,7 +12389,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p goto string; } - if (vectorize && !strchr("BbDdiOouUXx", c)) + if (vectorize && !memCHRs("BbDdiOouUXx", c)) goto unknown; /* get next arg (individual branches do their own va_arg() @@ -12498,7 +12531,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p * being allowed for %c (ideally we should warn on e.g. '%hc'). * Setting a default intsize, along with a positive * (which signals unsigned) base, causes, for C-ish use, the - * va_arg to be interpreted as as unsigned int, when it's + * va_arg to be interpreted as an unsigned int, when it's * actually signed, which will convert -ve values to high +ve * values. Note that unlike the libc %c, values > 255 will * convert to high unicode points rather than being truncated @@ -12798,7 +12831,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p (!UVCHR_IS_INVARIANT(uv) && SvUTF8(sv))) && !IN_BYTES) { - assert(sizeof(ebuf) >= UTF8_MAXBYTES + 1); + STATIC_ASSERT_STMT(sizeof(ebuf) >= UTF8_MAXBYTES + 1); eptr = ebuf; elen = uvchr_to_utf8((U8*)eptr, uv) - (U8*)ebuf; is_utf8 = TRUE; @@ -13198,20 +13231,15 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p GCC_DIAG_IGNORE_STMT(-Wformat-nonliteral); #ifdef USE_QUADMATH { - const char* qfmt = quadmath_format_single(ptr); - if (!qfmt) + if (!quadmath_format_valid(ptr)) Perl_croak_nocontext("panic: quadmath invalid format \"%s\"", ptr); WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric, elen = quadmath_snprintf(PL_efloatbuf, PL_efloatsize, - qfmt, nv); + ptr, nv); ); if ((IV)elen == -1) { - if (qfmt != ptr) - SAVEFREEPV(qfmt); - Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", qfmt); + Perl_croak_nocontext("panic: quadmath_snprintf failed, format \"%s\"", ptr); } - if (qfmt != ptr) - Safefree(qfmt); } #elif defined(HAS_LONG_DOUBLE) WITH_LC_NUMERIC_SET_TO_NEEDED_IN(in_lc_numeric, @@ -13457,7 +13485,7 @@ Perl_sv_vcatpvfn_flags(pTHX_ SV *const sv, const char *const pat, const STRLEN p /* ========================================================================= -=head1 Cloning an interpreter +=for apidoc_section Embedding and Interpreter Cloning =cut @@ -14104,7 +14132,6 @@ S_sv_dup_inc_multiple(pTHX_ SV *const *source, SV **dest, static SV * S_sv_dup_common(pTHX_ const SV *const sstr, CLONE_PARAMS *const param) { - dVAR; SV *dstr; PERL_ARGS_ASSERT_SV_DUP_COMMON; @@ -14602,7 +14629,7 @@ Perl_cx_dup(pTHX_ PERL_CONTEXT *cxs, I32 ix, I32 max, CLONE_PARAMS* 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); - /* XXX what do do with cur_top_env ???? */ + /* XXX what to do with cur_top_env ???? */ break; case CXt_LOOP_LAZYSV: ncx->blk_loop.state_u.lazysv.end @@ -14762,7 +14789,6 @@ Perl_any_dup(pTHX_ void *v, const PerlInterpreter *proto_perl) ANY * Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) { - dVAR; ANY * const ss = proto_perl->Isavestack; const I32 max = proto_perl->Isavestack_max + SS_MAXPUSH; I32 ix = proto_perl->Isavestack_ix; @@ -14995,16 +15021,16 @@ Perl_ss_dup(pTHX_ PerlInterpreter *proto_perl, CLONE_PARAMS* param) 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; - if (i & HINT_LOCALIZE_HH) { - hv = (const HV *)POPPTR(ss,ix); - TOPPTR(nss,ix) = hv_dup_inc(hv, param); - } break; case SAVEt_PADSV_AND_MORTALIZE: longval = (long)POPLONG(ss,ix); @@ -15117,7 +15143,6 @@ perl_clone_host(PerlInterpreter* proto_perl, UV flags); PerlInterpreter * perl_clone(PerlInterpreter *proto_perl, UV flags) { - dVAR; #ifdef PERL_IMPLICIT_SYS PERL_ARGS_ASSERT_PERL_CLONE; @@ -15325,6 +15350,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_origalen = proto_perl->Iorigalen; PL_sighandlerp = proto_perl->Isighandlerp; + PL_sighandler1p = proto_perl->Isighandler1p; + PL_sighandler3p = proto_perl->Isighandler3p; PL_runops = proto_perl->Irunops; @@ -15332,10 +15359,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_cv_has_eval = proto_perl->Icv_has_eval; -#ifdef FCRYPT - PL_cryptseen = proto_perl->Icryptseen; -#endif - #ifdef USE_LOCALE_COLLATE PL_collation_ix = proto_perl->Icollation_ix; PL_collation_standard = proto_perl->Icollation_standard; @@ -15370,9 +15393,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* Recursion stopper for PerlIO_find_layer */ PL_in_load_module = proto_perl->Iin_load_module; - /* sort() routine */ - PL_sort_RealCmp = proto_perl->Isort_RealCmp; - /* Not really needed/useful since the reenrant_retint is "volatile", * but do it for consistency's sake. */ PL_reentrant_retint = proto_perl->Ireentrant_retint; @@ -15387,13 +15407,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_globhook = proto_perl->Iglobhook; - /* swatch cache */ - PL_last_swash_hv = NULL; /* reinits on demand */ - PL_last_swash_klen = 0; - PL_last_swash_key[0]= '\0'; - PL_last_swash_tmps = (U8*)NULL; - PL_last_swash_slen = 0; - PL_srand_called = proto_perl->Isrand_called; Copy(&(proto_perl->Irandom_state), &PL_random_state, 1, PL_RANDOM_STATE_TYPE); @@ -15689,12 +15702,64 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, # endif #endif /* !USE_LOCALE_NUMERIC */ +#ifdef HAS_MBRLEN + PL_mbrlen_ps = proto_perl->Imbrlen_ps; +#endif +#ifdef HAS_MBRTOWC + PL_mbrtowc_ps = proto_perl->Imbrtowc_ps; +#endif +#ifdef HAS_WCRTOMB + PL_wcrtomb_ps = proto_perl->Iwcrtomb_ps; +#endif + PL_langinfo_buf = NULL; PL_langinfo_bufsize = 0; PL_setlocale_buf = NULL; PL_setlocale_bufsize = 0; + /* Unicode inversion lists */ + + PL_AboveLatin1 = sv_dup_inc(proto_perl->IAboveLatin1, param); + PL_Assigned_invlist = sv_dup_inc(proto_perl->IAssigned_invlist, param); + PL_GCB_invlist = sv_dup_inc(proto_perl->IGCB_invlist, param); + PL_HasMultiCharFold = sv_dup_inc(proto_perl->IHasMultiCharFold, param); + PL_InMultiCharFold = sv_dup_inc(proto_perl->IInMultiCharFold, param); + PL_Latin1 = sv_dup_inc(proto_perl->ILatin1, param); + PL_LB_invlist = sv_dup_inc(proto_perl->ILB_invlist, param); + PL_SB_invlist = sv_dup_inc(proto_perl->ISB_invlist, param); + PL_SCX_invlist = sv_dup_inc(proto_perl->ISCX_invlist, param); + PL_UpperLatin1 = sv_dup_inc(proto_perl->IUpperLatin1, param); + PL_in_some_fold = sv_dup_inc(proto_perl->Iin_some_fold, param); + PL_utf8_foldclosures = sv_dup_inc(proto_perl->Iutf8_foldclosures, param); + PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param); + PL_utf8_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param); + PL_utf8_perl_idcont = sv_dup_inc(proto_perl->Iutf8_perl_idcont, param); + PL_utf8_perl_idstart = sv_dup_inc(proto_perl->Iutf8_perl_idstart, param); + PL_utf8_xidcont = sv_dup_inc(proto_perl->Iutf8_xidcont, param); + PL_utf8_xidstart = sv_dup_inc(proto_perl->Iutf8_xidstart, param); + PL_WB_invlist = sv_dup_inc(proto_perl->IWB_invlist, param); + for (i = 0; i < POSIX_CC_COUNT; i++) { + PL_XPosix_ptrs[i] = sv_dup_inc(proto_perl->IXPosix_ptrs[i], param); + if (i != _CC_CASED && i != _CC_VERTSPACE) { + PL_Posix_ptrs[i] = sv_dup_inc(proto_perl->IPosix_ptrs[i], param); + } + } + PL_Posix_ptrs[_CC_CASED] = PL_Posix_ptrs[_CC_ALPHA]; + PL_Posix_ptrs[_CC_VERTSPACE] = NULL; + + PL_utf8_toupper = sv_dup_inc(proto_perl->Iutf8_toupper, param); + PL_utf8_totitle = sv_dup_inc(proto_perl->Iutf8_totitle, param); + PL_utf8_tolower = sv_dup_inc(proto_perl->Iutf8_tolower, param); + PL_utf8_tofold = sv_dup_inc(proto_perl->Iutf8_tofold, param); + PL_utf8_tosimplefold = sv_dup_inc(proto_perl->Iutf8_tosimplefold, param); + PL_utf8_charname_begin = sv_dup_inc(proto_perl->Iutf8_charname_begin, param); + PL_utf8_charname_continue = sv_dup_inc(proto_perl->Iutf8_charname_continue, param); + PL_utf8_mark = sv_dup_inc(proto_perl->Iutf8_mark, param); + PL_InBitmap = sv_dup_inc(proto_perl->IInBitmap, param); + PL_CCC_non0_non230 = sv_dup_inc(proto_perl->ICCC_non0_non230, param); + PL_Private_Use = sv_dup_inc(proto_perl->IPrivate_Use, param); + #if 0 PL_seen_deprecated_macro = hv_dup_inc(proto_perl->Iseen_deprecated_macro, param); #endif @@ -15801,7 +15866,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* Call the ->CLONE method, if it exists, for each of the stashes identified by sv_dup() above. */ - while(av_tindex(param->stashes) != -1) { + 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)) { @@ -15884,11 +15949,9 @@ S_unreferenced_to_tmp_stack(pTHX_ AV *const unreferenced) void Perl_clone_params_del(CLONE_PARAMS *param) { - /* This seemingly funky ordering keeps the build with PERL_GLOBAL_STRUCT - happy: */ + PerlInterpreter *const was = PERL_GET_THX; PerlInterpreter *const to = param->new_perl; dTHXa(to); - PerlInterpreter *const was = PERL_GET_THX; PERL_ARGS_ASSERT_CLONE_PARAMS_DEL; @@ -15910,7 +15973,6 @@ Perl_clone_params_del(CLONE_PARAMS *param) CLONE_PARAMS * Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) { - dVAR; /* Need to play this game, as newAV() can call safesysmalloc(), and that does a dTHX; to get the context from thread local storage. FIXME - under PERL_CORE Newx(), Safefree() and friends should expand to @@ -15945,7 +16007,6 @@ Perl_clone_params_new(PerlInterpreter *const from, PerlInterpreter *const to) void Perl_init_constants(pTHX) { - dVAR; SvREFCNT(&PL_sv_undef) = SvREFCNT_IMMORTAL; SvFLAGS(&PL_sv_undef) = SVf_READONLY|SVf_PROTECT|SVt_NULL; @@ -16012,7 +16073,7 @@ Perl_init_constants(pTHX) } /* -=head1 Unicode Support +=for apidoc_section Unicode Support =for apidoc sv_recode_to_utf8 @@ -16158,7 +16219,6 @@ Perl_sv_cat_decode(pTHX_ SV *dsv, SV *encoding, STATIC SV* S_find_hash_subscript(pTHX_ const HV *const hv, const SV *const val) { - dVAR; HE **array; I32 i; @@ -16284,6 +16344,7 @@ Perl_varname(pTHX_ const GV *const gv, const char gvtype, PADOFFSET targ, /* +=apidoc_section Warning and Dieing =for apidoc find_uninit_var Find the name of the undefined variable (if any) that caused the operator @@ -16309,7 +16370,6 @@ STATIC SV * S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, bool match, const char **desc_p) { - dVAR; SV *sv; const GV *gv; const OP *o, *o2, *kid; @@ -16518,7 +16578,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, negate ? - SvIV(cSVOPx_sv(kid)) : SvIV(cSVOPx_sv(kid)), FUV_SUBSCRIPT_ARRAY); } - else { + else { /* index is an expression; * attempt to find a match within the aggregate */ if (obase->op_type == OP_HELEM) { @@ -16730,7 +16790,7 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, : varname(agg_gv, '@', agg_targ, NULL, index_const_iv, FUV_SUBSCRIPT_ARRAY); } - else { + else { /* index is an var */ if (is_hv) { SV * const keysv = find_hash_subscript((const HV*)sv, uninit_sv); @@ -16745,6 +16805,34 @@ S_find_uninit_var(pTHX_ const OP *const obase, const SV *const uninit_sv, return varname(agg_gv, '@', agg_targ, NULL, index, FUV_SUBSCRIPT_ARRAY); } + /* look for an element not found */ + if (!SvMAGICAL(sv)) { + SV *index_sv = NULL; + if (index_targ) { + index_sv = PL_curpad[index_targ]; + } + else if (index_gv) { + index_sv = GvSV(index_gv); + } + if (index_sv && !SvMAGICAL(index_sv) && !SvROK(index_sv)) { + if (is_hv) { + HE *he = hv_fetch_ent(MUTABLE_HV(sv), index_sv, 0, 0); + if (!he) { + return varname(agg_gv, '%', agg_targ, + index_sv, 0, FUV_SUBSCRIPT_HASH); + } + } + else { + SSize_t index = SvIV(index_sv); + SV * const * const svp = + av_fetch(MUTABLE_AV(sv), index, FALSE); + if (!svp) { + return varname(agg_gv, '@', agg_targ, + NULL, index, FUV_SUBSCRIPT_ARRAY); + } + } + } + } if (match) break; return varname(agg_gv,