X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=520a3b69abf737ba14a4b2ca31a53dba4e6b60fb;hb=b0ce926a45891e83ffb4badae874161f93c0eb49;hp=97044c934526453ed5e402cd2b07668e0e80ca8b;hpb=0453d815b8a74697ff1e5451c27aba2fe537b8e0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 97044c9..520a3b6 100644 --- a/sv.c +++ b/sv.c @@ -38,15 +38,22 @@ #endif #ifdef PERL_OBJECT -#define FCALL this->*f #define VTBL this->*vtbl #else /* !PERL_OBJECT */ #define VTBL *vtbl -#define FCALL *f #endif /* PERL_OBJECT */ +#define FCALL *f #define SV_CHECK_THINKFIRST(sv) if (SvTHINKFIRST(sv)) sv_force_normal(sv) +static void do_report_used(pTHXo_ SV *sv); +static void do_clean_objs(pTHXo_ SV *sv); +#ifndef DISABLE_DESTRUCTOR_KLUDGE +static void do_clean_named_objs(pTHXo_ SV *sv); +#endif +static void do_clean_all(pTHXo_ SV *sv); + + #ifdef PURIFY #define new_SV(p) \ @@ -277,87 +284,36 @@ S_visit(pTHX_ SVFUNC_t f) svend = &sva[SvREFCNT(sva)]; for (sv = sva + 1; sv < svend; ++sv) { if (SvTYPE(sv) != SVTYPEMASK) - (FCALL)(aTHX_ sv); + (FCALL)(aTHXo_ sv); } } } #endif /* PURIFY */ -STATIC void -S_do_report_used(pTHX_ SV *sv) -{ - if (SvTYPE(sv) != SVTYPEMASK) { - /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */ - PerlIO_printf(PerlIO_stderr(), "****\n"); - sv_dump(sv); - } -} - void Perl_sv_report_used(pTHX) { - visit(FUNC_NAME_TO_PTR(S_do_report_used)); -} - -STATIC void -S_do_clean_objs(pTHX_ SV *sv) -{ - SV* rv; - - if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));) - SvROK_off(sv); - SvRV(sv) = 0; - SvREFCNT_dec(rv); - } - - /* XXX Might want to check arrays, etc. */ -} - -#ifndef DISABLE_DESTRUCTOR_KLUDGE -STATIC void -S_do_clean_named_objs(pTHX_ SV *sv) -{ - if (SvTYPE(sv) == SVt_PVGV) { - if ( SvOBJECT(GvSV(sv)) || - GvAV(sv) && SvOBJECT(GvAV(sv)) || - GvHV(sv) && SvOBJECT(GvHV(sv)) || - GvIO(sv) && SvOBJECT(GvIO(sv)) || - GvCV(sv) && SvOBJECT(GvCV(sv)) ) - { - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));) - SvREFCNT_dec(sv); - } - } + visit(do_report_used); } -#endif void Perl_sv_clean_objs(pTHX) { PL_in_clean_objs = TRUE; - visit(FUNC_NAME_TO_PTR(S_do_clean_objs)); + visit(do_clean_objs); #ifndef DISABLE_DESTRUCTOR_KLUDGE /* some barnacles may yet remain, clinging to typeglobs */ - visit(FUNC_NAME_TO_PTR(S_do_clean_named_objs)); + visit(do_clean_named_objs); #endif PL_in_clean_objs = FALSE; } -STATIC void -S_do_clean_all(pTHX_ SV *sv) -{ - DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );) - SvFLAGS(sv) |= SVf_BREAK; - SvREFCNT_dec(sv); -} - void Perl_sv_clean_all(pTHX) { PL_in_clean_all = TRUE; - visit(FUNC_NAME_TO_PTR(S_do_clean_all)); + visit(do_clean_all); PL_in_clean_all = FALSE; } @@ -1112,7 +1068,7 @@ S_not_a_number(pTHX_ SV *sv) Perl_warner(aTHX_ WARN_NUMERIC, "Argument \"%s\" isn't numeric", tmpbuf); } -/* the number can be converted to _integer_ with atol() */ +/* the number can be converted to integer with atol() or atoll() */ #define IS_NUMBER_TO_INT_BY_ATOL 0x01 #define IS_NUMBER_TO_INT_BY_ATOF 0x02 /* atol() may be != atof() */ #define IS_NUMBER_NOT_IV 0x04 /* (IV)atof() may be != atof() */ @@ -1151,17 +1107,10 @@ Perl_sv_2iv(pTHX_ register SV *sv) return SvIV(tmpstr); return (IV)SvRV(sv); } - if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { - return I_V(SvNVX(sv)); - } - if (SvPOKp(sv) && SvLEN(sv)) - return asIV(sv); - { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); return 0; } } @@ -1176,7 +1125,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (SvNOKp(sv)) { /* We can cache the IV/UV value even if it not good enough * to reconstruct NV, since the conversion to PV will prefer - * NV over IV/UV. XXXX 64-bit? + * NV over IV/UV. */ if (SvTYPE(sv) == SVt_NV) @@ -1189,10 +1138,17 @@ Perl_sv_2iv(pTHX_ register SV *sv) SvUVX(sv) = U_V(SvNVX(sv)); SvIsUV_on(sv); ret_iv_max: +#ifdef IV_IS_QUAD + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%" PERL_PRIx64 " 2iv(%" PERL_PRIu64 " => %" PERL_PRId64 ") (as unsigned)\n", + (UV)sv, + (UV)SvUVX(sv), (IV)SvUVX(sv))); +#else DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2iv(%lu => %ld) (as unsigned)\n", (unsigned long)sv, (unsigned long)SvUVX(sv), (long)(IV)SvUVX(sv))); +#endif return (IV)SvUVX(sv); } } @@ -1220,7 +1176,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) (void)SvNOK_on(sv); (void)SvIOK_on(sv); #if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n", (unsigned long)sv, SvNVX(sv))); #else DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n", @@ -1240,7 +1196,7 @@ Perl_sv_2iv(pTHX_ register SV *sv) if (SvTYPE(sv) == SVt_PV) sv_upgrade(sv, SVt_PVIV); (void)SvIOK_on(sv); - SvIVX(sv) = atol(SvPVX(sv)); /* XXXX 64-bit? */ + SvIVX(sv) = Atol(SvPVX(sv)); } else { /* Not a number. Cache 0. */ dTHR; @@ -1296,17 +1252,10 @@ Perl_sv_2uv(pTHX_ register SV *sv) return SvUV(tmpstr); return (UV)SvRV(sv); } - if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { - return U_V(SvNVX(sv)); - } - if (SvPOKp(sv) && SvLEN(sv)) - return asUV(sv); - { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); return 0; } } @@ -1321,7 +1270,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (SvNOKp(sv)) { /* We can cache the IV/UV value even if it not good enough * to reconstruct NV, since the conversion to PV will prefer - * NV over IV/UV. XXXX 64-bit? + * NV over IV/UV. */ if (SvTYPE(sv) == SVt_NV) sv_upgrade(sv, SVt_PVNV); @@ -1333,10 +1282,17 @@ Perl_sv_2uv(pTHX_ register SV *sv) else { SvIVX(sv) = I_V(SvNVX(sv)); ret_zero: +#ifdef IV_IS_QUAD + DEBUG_c(PerlIO_printf(Perl_debug_log, + "0x%" PERL_PRIx64 " 2uv(%" PERL_PRId64 " => %" PERL_PRIu64 ") (as signed)\n", + (unsigned long)sv,(long)SvIVX(sv), + (long)(UV)SvIVX(sv))); +#else DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2uv(%ld => %lu) (as signed)\n", (unsigned long)sv,(long)SvIVX(sv), (long)(UV)SvIVX(sv))); +#endif return (UV)SvIVX(sv); } } @@ -1356,7 +1312,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) * - otherwise future conversion to NV will be wrong. */ NV d; - d = Atof(SvPVX(sv)); /* XXXX 64-bit? */ + d = Atof(SvPVX(sv)); if (SvTYPE(sv) < SVt_PVNV) sv_upgrade(sv, SVt_PVNV); @@ -1364,7 +1320,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) (void)SvNOK_on(sv); (void)SvIOK_on(sv); #if defined(USE_LONG_DOUBLE) - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n", + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n", (unsigned long)sv, SvNVX(sv))); #else DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%g)\n", @@ -1384,7 +1340,7 @@ Perl_sv_2uv(pTHX_ register SV *sv) if (SvTYPE(sv) == SVt_PV) sv_upgrade(sv, SVt_PVIV); (void)SvIOK_on(sv); - SvIVX(sv) = (IV)atol(SvPVX(sv)); /* XXXX 64-bit? */ + SvIVX(sv) = (IV)Atol(SvPVX(sv)); } else if (numtype) { /* Non-negative */ /* The NV may be reconstructed from UV - safe to cache UV, @@ -1394,10 +1350,10 @@ Perl_sv_2uv(pTHX_ register SV *sv) (void)SvIOK_on(sv); (void)SvIsUV_on(sv); #ifdef HAS_STRTOUL - SvUVX(sv) = strtoul(SvPVX(sv), Null(char**), 10); /* XXXX 64-bit? */ + SvUVX(sv) = Strtoul(SvPVX(sv), Null(char**), 10); #else /* no atou(), but we know the number fits into IV... */ /* The only problem may be if it is negative... */ - SvUVX(sv) = (UV)atol(SvPVX(sv)); /* XXXX 64-bit? */ + SvUVX(sv) = (UV)Atol(SvPVX(sv)); #endif } else { /* Not a number. Cache 0. */ @@ -1467,19 +1423,8 @@ Perl_sv_2nv(pTHX_ register SV *sv) return SvNV(tmpstr); return (NV)(unsigned long)SvRV(sv); } - if (SvREADONLY(sv)) { + if (SvREADONLY(sv) && !SvOK(sv)) { dTHR; - if (SvPOKp(sv) && SvLEN(sv)) { - if (ckWARN(WARN_NUMERIC) && !SvIOKp(sv) && !looks_like_number(sv)) - not_a_number(sv); - return Atof(SvPVX(sv)); - } - if (SvIOKp(sv)) { - if (SvIsUV(sv)) - return (NV)SvUVX(sv); - else - return (NV)SvIVX(sv); - } if (ckWARN(WARN_UNINITIALIZED)) Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); return 0.0; @@ -1493,7 +1438,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) #if defined(USE_LONG_DOUBLE) DEBUG_c({ RESTORE_NUMERIC_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%lx num(%Lg)\n", + PerlIO_printf(Perl_debug_log, "0x%lx num(%" PERL_PRIgldbl ")\n", (unsigned long)sv, SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); @@ -1532,7 +1477,7 @@ Perl_sv_2nv(pTHX_ register SV *sv) #if defined(USE_LONG_DOUBLE) DEBUG_c({ RESTORE_NUMERIC_STANDARD(); - PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%Lg)\n", + PerlIO_printf(Perl_debug_log, "0x%lx 2nv(%" PERL_PRIgldbl ")\n", (unsigned long)sv, SvNVX(sv)); RESTORE_NUMERIC_LOCAL(); }); @@ -1554,7 +1499,7 @@ S_asIV(pTHX_ SV *sv) NV d; if (numtype & IS_NUMBER_TO_INT_BY_ATOL) - return atol(SvPVX(sv)); /* XXXX 64-bit? */ + return Atol(SvPVX(sv)); if (!numtype) { dTHR; if (ckWARN(WARN_NUMERIC)) @@ -1571,7 +1516,7 @@ S_asUV(pTHX_ SV *sv) #ifdef HAS_STRTOUL if (numtype & IS_NUMBER_TO_INT_BY_ATOL) - return strtoul(SvPVX(sv), Null(char**), 10); + return Strtoul(SvPVX(sv), Null(char**), 10); #endif if (!numtype) { dTHR; @@ -1597,8 +1542,6 @@ S_asUV(pTHX_ SV *sv) I32 Perl_looks_like_number(pTHX_ SV *sv) { - /* XXXX 64-bit? It may be not IS_NUMBER_TO_INT_BY_ATOL, but - * using atof() may lose precision. */ register char *s; register char *send; register char *sbegin; @@ -1752,11 +1695,18 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) *lp = SvCUR(sv); return SvPVX(sv); } - if (SvIOKp(sv)) { /* XXXX 64-bit? */ + if (SvIOKp(sv)) { +#ifdef IV_IS_QUAD + if (SvIsUV(sv)) + (void)sprintf(tmpbuf,"%" PERL_PRIu64,(UV)SvUVX(sv)); + else + (void)sprintf(tmpbuf,"%" PERL_PRId64,(IV)SvIVX(sv)); +#else if (SvIsUV(sv)) (void)sprintf(tmpbuf,"%lu",(unsigned long)SvUVX(sv)); else (void)sprintf(tmpbuf,"%ld",(long)SvIVX(sv)); +#endif tsv = Nullsv; goto tokensave; } @@ -1854,36 +1804,20 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); else sv_setpv(tsv, s); - /* XXXX 64-bit? */ +#ifdef IV_IS_QUAD + Perl_sv_catpvf(aTHX_ tsv, "(0x%" PERL_PRIx64")", (UV)sv); +#else Perl_sv_catpvf(aTHX_ tsv, "(0x%lx)", (unsigned long)sv); +#endif goto tokensaveref; } *lp = strlen(s); return s; } - if (SvREADONLY(sv)) { - if (SvNOKp(sv)) { /* See note in sv_2uv() */ - /* XXXX 64-bit? IV may have better precision... */ - Gconvert(SvNVX(sv), DBL_DIG, 0, tmpbuf); - tsv = Nullsv; - goto tokensave; - } - if (SvIOKp(sv)) { - char *ebuf; - - if (SvIsUV(sv)) - tmpbuf = uiv_2buf(tbuf, 0, SvUVX(sv), 1, &ebuf); - else - tmpbuf = uiv_2buf(tbuf, SvIVX(sv), 0, 0, &ebuf); - *ebuf = 0; - tsv = Nullsv; - goto tokensave; - } - { - dTHR; - if (ckWARN(WARN_UNINITIALIZED)) - Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); - } + if (SvREADONLY(sv) && !SvOK(sv)) { + dTHR; + if (ckWARN(WARN_UNINITIALIZED)) + Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); *lp = 0; return ""; } @@ -1916,30 +1850,36 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) } else if (SvIOKp(sv)) { U32 isIOK = SvIOK(sv); + U32 isUIOK = SvIsUV(sv); char buf[TYPE_CHARS(UV)]; char *ebuf, *ptr; if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv, SVt_PVIV); - if (SvIsUV(sv)) { + if (isUIOK) ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); - sv_setpvn(sv, ptr, ebuf - ptr); - SvIsUV_on(sv); - } - else { + else ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); - sv_setpvn(sv, ptr, ebuf - ptr); - } + SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */ + Move(ptr,SvPVX(sv),ebuf - ptr,char); + SvCUR_set(sv, ebuf - ptr); s = SvEND(sv); + *s = '\0'; if (isIOK) SvIOK_on(sv); else SvIOKp_on(sv); + if (isUIOK) + SvIsUV_on(sv); + SvPOK_on(sv); } else { dTHR; - if (ckWARN(WARN_UNINITIALIZED) && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + if (ckWARN(WARN_UNINITIALIZED) + && !PL_localizing && !(SvFLAGS(sv) & SVs_PADTMP)) + { Perl_warner(aTHX_ WARN_UNINITIALIZED, PL_warn_uninit); + } *lp = 0; if (SvTYPE(sv) < SVt_PV) /* Typically the caller expects that sv_any is not NULL now. */ @@ -1949,7 +1889,8 @@ Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) *lp = s - SvPVX(sv); SvCUR_set(sv, *lp); SvPOK_on(sv); - DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n",(unsigned long)sv,SvPVX(sv))); + DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n", + (unsigned long)sv,SvPVX(sv))); return SvPVX(sv); tokensave: @@ -3060,7 +3001,7 @@ Perl_sv_clear(pTHX_ register SV *sv) IoIFP(sv) != PerlIO_stdout() && IoIFP(sv) != PerlIO_stderr()) { - io_close((IO*)sv); + io_close((IO*)sv, FALSE); } if (IoDIRP(sv)) { PerlDir_close(IoDIRP(sv)); @@ -3214,8 +3155,8 @@ Perl_sv_free(pTHX_ SV *sv) #ifdef DEBUGGING if (SvTEMP(sv)) { if (ckWARN_d(WARN_DEBUGGING)) - Perl_warner(aTHX_ WARN_DEBUGGING, - "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv); + Perl_warner(aTHX_ WARN_DEBUGGING, + "Attempt to free temp prematurely: SV 0x%lx", (unsigned long)sv); return; } #endif @@ -3993,10 +3934,8 @@ Perl_newSVpvf_nocontext(const char* pat, ...) dTHX; register SV *sv; va_list args; - - new_SV(sv); va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv = vnewSVpvf(pat, &args); va_end(args); return sv; } @@ -4007,15 +3946,22 @@ Perl_newSVpvf(pTHX_ const char* pat, ...) { register SV *sv; va_list args; - - new_SV(sv); va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv = vnewSVpvf(pat, &args); va_end(args); return sv; } SV * +Perl_vnewSVpvf(pTHX_ const char* pat, va_list* args) +{ + register SV *sv; + new_SV(sv); + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); + return sv; +} + +SV * Perl_newSVnv(pTHX_ NV n) { register SV *sv; @@ -4090,7 +4036,7 @@ Perl_sv_reset(pTHX_ register char *s, HV *stash) register I32 i; register PMOP *pm; register I32 max; - char todo[256]; + char todo[PERL_UCHAR_MAX+1]; if (!stash) return; @@ -4109,11 +4055,11 @@ Perl_sv_reset(pTHX_ register char *s, HV *stash) Zero(todo, 256, char); while (*s) { - i = *s; + i = (unsigned char)*s; if (s[1] == '-') { s += 2; } - max = *s++; + max = (unsigned char)*s++; for ( ; i <= max; i++) { todo[i] = 1; } @@ -4623,7 +4569,7 @@ Perl_sv_setpvf_nocontext(SV *sv, const char* pat, ...) dTHX; va_list args; va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vsetpvf(sv, pat, &args); va_end(args); } @@ -4634,9 +4580,8 @@ Perl_sv_setpvf_mg_nocontext(SV *sv, const char* pat, ...) dTHX; va_list args; va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vsetpvf_mg(sv, pat, &args); va_end(args); - SvSETMAGIC(sv); } #endif @@ -4645,18 +4590,29 @@ Perl_sv_setpvf(pTHX_ SV *sv, const char* pat, ...) { va_list args; va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vsetpvf(sv, pat, &args); va_end(args); } +void +Perl_sv_vsetpvf(pTHX_ SV *sv, const char* pat, va_list* args) +{ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); +} void Perl_sv_setpvf_mg(pTHX_ SV *sv, const char* pat, ...) { va_list args; va_start(args, pat); - sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vsetpvf_mg(sv, pat, &args); va_end(args); +} + +void +Perl_sv_vsetpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) +{ + sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); } @@ -4667,7 +4623,7 @@ Perl_sv_catpvf_nocontext(SV *sv, const char* pat, ...) dTHX; va_list args; va_start(args, pat); - sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vcatpvf(sv, pat, &args); va_end(args); } @@ -4677,9 +4633,8 @@ Perl_sv_catpvf_mg_nocontext(SV *sv, const char* pat, ...) dTHX; va_list args; va_start(args, pat); - sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vcatpvf_mg(sv, pat, &args); va_end(args); - SvSETMAGIC(sv); } #endif @@ -4688,17 +4643,29 @@ Perl_sv_catpvf(pTHX_ SV *sv, const char* pat, ...) { va_list args; va_start(args, pat); - sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vcatpvf(sv, pat, &args); va_end(args); } void +Perl_sv_vcatpvf(pTHX_ SV *sv, const char* pat, va_list* args) +{ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); +} + +void Perl_sv_catpvf_mg(pTHX_ SV *sv, const char* pat, ...) { va_list args; va_start(args, pat); - sv_vcatpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vcatpvf_mg(sv, pat, &args); va_end(args); +} + +void +Perl_sv_vcatpvf_mg(pTHX_ SV *sv, const char* pat, va_list* args) +{ + sv_vcatpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); SvSETMAGIC(sv); } @@ -4858,15 +4825,20 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV switch (*q) { case 'l': -#if 0 /* when quads have better support within Perl */ - if (*(q + 1) == 'l') { +#ifdef HAS_QUAD + if (*(q + 1) == 'l') { /* lld */ intsize = 'q'; q += 2; break; - } + } + case 'L': /* Ld */ + case 'q': /* qd */ + intsize = 'q'; + q++; + break; #endif - /* FALL THROUGH */ case 'h': + /* FALL THROUGH */ case 'V': intsize = *q++; break; @@ -4953,25 +4925,43 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto integer; case 'D': +#ifdef IV_IS_QUAD + /* nothing */ +#else intsize = 'l'; +#endif /* FALL THROUGH */ case 'd': case 'i': if (args) { switch (intsize) { case 'h': iv = (short)va_arg(*args, int); break; +#ifdef IV_IS_QUAD + default: iv = va_arg(*args, IV); break; +#else default: iv = va_arg(*args, int); break; +#endif case 'l': iv = va_arg(*args, long); break; case 'V': iv = va_arg(*args, IV); break; +#ifdef HAS_QUAD + case 'q': iv = va_arg(*args, Quad_t); break; +#endif } } else { iv = (svix < svmax) ? SvIVx(svargs[svix++]) : 0; switch (intsize) { case 'h': iv = (short)iv; break; +#ifdef IV_IS_QUAD + default: break; +#else default: iv = (int)iv; break; +#endif case 'l': iv = (long)iv; break; case 'V': break; +#ifdef HAS_QUAD + case 'q': iv = (Quad_t)iv; break; +#endif } } if (iv >= 0) { @@ -4987,7 +4977,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto integer; case 'U': +#ifdef IV_IS_QUAD + /* nothing */ +#else intsize = 'l'; +#endif /* FALL THROUGH */ case 'u': base = 10; @@ -4998,7 +4992,11 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV goto uns_integer; case 'O': +#ifdef IV_IS_QUAD + /* nothing */ +#else intsize = 'l'; +#endif /* FALL THROUGH */ case 'o': base = 8; @@ -5012,18 +5010,32 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (args) { switch (intsize) { case 'h': uv = (unsigned short)va_arg(*args, unsigned); break; +#ifdef UV_IS_QUAD + default: uv = va_arg(*args, UV); break; +#else default: uv = va_arg(*args, unsigned); break; +#endif case 'l': uv = va_arg(*args, unsigned long); break; case 'V': uv = va_arg(*args, UV); break; +#ifdef HAS_QUAD + case 'q': uv = va_arg(*args, Quad_t); break; +#endif } } else { uv = (svix < svmax) ? SvUVx(svargs[svix++]) : 0; switch (intsize) { case 'h': uv = (unsigned short)uv; break; +#ifdef UV_IS_QUAD + default: break; +#else default: uv = (unsigned)uv; break; +#endif case 'l': uv = (unsigned long)uv; break; case 'V': break; +#ifdef HAS_QUAD + case 'q': uv = (Quad_t)uv; break; +#endif } } @@ -5116,7 +5128,10 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV *--eptr = '\0'; *--eptr = c; #ifdef USE_LONG_DOUBLE - *--eptr = 'L'; + { + char* p = PERL_PRIfldbl + sizeof(PERL_PRIfldbl) - 3; + while (p >= PERL_PRIfldbl) { *--eptr = *p--; } + } #endif if (has_precis) { base = precis; @@ -5165,9 +5180,16 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV if (args) { switch (intsize) { case 'h': *(va_arg(*args, short*)) = i; break; +#ifdef IV_IS_QUAD + default: *(va_arg(*args, IV*)) = i; break; +#else default: *(va_arg(*args, int*)) = i; break; +#endif case 'l': *(va_arg(*args, long*)) = i; break; case 'V': *(va_arg(*args, IV*)) = i; break; +#ifdef HAS_QUAD + case 'q': *(va_arg(*args, Quad_t*)) = i; break; +#endif } } else if (svix < svmax) @@ -5183,10 +5205,21 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV SV *msg = sv_newmortal(); Perl_sv_setpvf(aTHX_ msg, "Invalid conversion in %s: ", (PL_op->op_type == OP_PRTF) ? "printf" : "sprintf"); - if (c) - Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? "\"%%%c\"" : "\"%%\\%03o\"", - c & 0xFF); - else + if (c) { +#ifdef UV_IS_QUAD + if (isPRINT(c)) + Perl_sv_catpvf(aTHX_ msg, + "\"%%%c\"", c & 0xFF); + else + Perl_sv_catpvf(aTHX_ msg, + "\"%%\\%03" PERL_PRIo64 "\"", + (UV)c & 0xFF); +#else + Perl_sv_catpvf(aTHX_ msg, isPRINT(c) ? + "\"%%%c\"" : "\"%%\\%03o\"", + c & 0xFF); +#endif + } else sv_catpv(msg, "end of string"); Perl_warner(aTHX_ WARN_PRINTF, "%_", msg); /* yes, this is reentrant */ } @@ -5241,3 +5274,61 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV SvCUR(sv) = p - SvPVX(sv); } } + + +#ifdef PERL_OBJECT +#define NO_XSLOCKS +#include "XSUB.h" +#endif + +static void +do_report_used(pTHXo_ SV *sv) +{ + if (SvTYPE(sv) != SVTYPEMASK) { + /* XXX Perhaps this ought to go to Perl_debug_log, if DEBUGGING. */ + PerlIO_printf(PerlIO_stderr(), "****\n"); + sv_dump(sv); + } +} + +static void +do_clean_objs(pTHXo_ SV *sv) +{ + SV* rv; + + if (SvROK(sv) && SvOBJECT(rv = SvRV(sv))) { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning object ref:\n "), sv_dump(sv));) + SvROK_off(sv); + SvRV(sv) = 0; + SvREFCNT_dec(rv); + } + + /* XXX Might want to check arrays, etc. */ +} + +#ifndef DISABLE_DESTRUCTOR_KLUDGE +static void +do_clean_named_objs(pTHXo_ SV *sv) +{ + if (SvTYPE(sv) == SVt_PVGV) { + if ( SvOBJECT(GvSV(sv)) || + GvAV(sv) && SvOBJECT(GvAV(sv)) || + GvHV(sv) && SvOBJECT(GvHV(sv)) || + GvIO(sv) && SvOBJECT(GvIO(sv)) || + GvCV(sv) && SvOBJECT(GvCV(sv)) ) + { + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning named glob object:\n "), sv_dump(sv));) + SvREFCNT_dec(sv); + } + } +} +#endif + +static void +do_clean_all(pTHXo_ SV *sv) +{ + DEBUG_D((PerlIO_printf(Perl_debug_log, "Cleaning loops: SV at 0x%lx\n", sv) );) + SvFLAGS(sv) |= SVf_BREAK; + SvREFCNT_dec(sv); +} +