X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=4e6d930ed215c9f0ae0852236d7329b82d250777;hb=ca9279baf07d6843f58a31f1ce3ff7dc875faf1a;hp=5280c08f44c3828060e7217e22b973fa4536944b;hpb=dd28f7bb7eebdb0b562c940b3c4f89457e829ea6;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 5280c08..4e6d930 100644 --- a/sv.c +++ b/sv.c @@ -3080,7 +3080,10 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } tsv = NEWSV(0,0); if (SvOBJECT(sv)) - Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); + if (HvNAME(SvSTASH(sv))) + Perl_sv_setpvf(aTHX_ tsv, "%s=%s", HvNAME(SvSTASH(sv)), s); + else + Perl_sv_setpvf(aTHX_ tsv, "__ANON__=%s", s); else sv_setpv(tsv, s); Perl_sv_catpvf(aTHX_ tsv, "(0x%"UVxf")", PTR2UV(sv)); @@ -4498,6 +4501,8 @@ Efficient removal of characters from the beginning of the string buffer. SvPOK(sv) must be true and the C must be a pointer to somewhere inside the string buffer. The C becomes the first character of the adjusted string. Uses the "OOK hack". +Beware: after this function returns, C and SvPVX(sv) may no longer +refer to the same chunk of data. =cut */ @@ -4506,9 +4511,9 @@ void Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) { register STRLEN delta; - if (!ptr || !SvPOKp(sv)) return; + delta = ptr - SvPVX(sv); SV_CHECK_THINKFIRST(sv); if (SvTYPE(sv) < SVt_PVIV) sv_upgrade(sv,SVt_PVIV); @@ -4528,7 +4533,6 @@ Perl_sv_chop(pTHX_ register SV *sv, register char *ptr) SvFLAGS(sv) |= SVf_OOK; } SvNIOK_off(sv); - delta = ptr - SvPVX(sv); SvLEN(sv) -= delta; SvCUR(sv) -= delta; SvPVX(sv) += delta; @@ -5914,13 +5918,13 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) mg = mg_find(sv, PERL_MAGIC_utf8); if (mg && mg->mg_ptr) { cache = (STRLEN *) mg->mg_ptr; - if (cache[1] == *offsetp) { + if (cache[1] == (STRLEN)*offsetp) { /* An exact match. */ *offsetp = cache[0]; return; } - else if (cache[1] < *offsetp) { + else if (cache[1] < (STRLEN)*offsetp) { /* We already know part of the way. */ len = cache[0]; s += cache[1]; @@ -5943,13 +5947,15 @@ Perl_sv_pos_b2u(pTHX_ register SV* sv, I32* offsetp) while (backw--) { p--; - while (UTF8_IS_CONTINUATION(*p)) + while (UTF8_IS_CONTINUATION(*p)) { p--; + backw--; + } ubackw++; } cache[0] -= ubackw; - + *offsetp = cache[0]; return; } } @@ -6354,7 +6360,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) Stat_t st; if (!PerlLIO_fstat(PerlIO_fileno(fp), &st) && S_ISREG(st.st_mode)) { Off_t offset = PerlIO_tell(fp); - if (offset != (Off_t) -1) { + if (offset != (Off_t) -1 && st.st_size + append > offset) { (void) SvGROW(sv, (STRLEN)((st.st_size - offset) + append + 1)); } } @@ -6379,6 +6385,8 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) #else bytesread = PerlIO_read(fp, buffer, recsize); #endif + if (bytesread < 0) + bytesread = 0; SvCUR_set(sv, bytesread += append); buffer[bytesread] = '\0'; goto return_string_or_null; @@ -7771,7 +7779,10 @@ char * Perl_sv_reftype(pTHX_ SV *sv, int ob) { if (ob && SvOBJECT(sv)) { - return HvNAME(SvSTASH(sv)); + if (HvNAME(SvSTASH(sv))) + return HvNAME(SvSTASH(sv)); + else + return "__ANON__"; } else { switch (SvTYPE(sv)) { @@ -7849,6 +7860,8 @@ Perl_sv_isa(pTHX_ SV *sv, const char *name) sv = (SV*)SvRV(sv); if (!SvOBJECT(sv)) return 0; + if (!HvNAME(SvSTASH(sv))) + return 0; return strEQ(HvNAME(SvSTASH(sv)), name); } @@ -9316,6 +9329,13 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV p = SvEND(sv); *p = '\0'; } + /* Use memchr() instead of strchr(), as eptr is not guaranteed */ + /* to point to a null-terminated string. */ + if (left && ckWARN(WARN_PRINTF) && memchr(eptr, '\n', elen) && + (PL_op->op_type == OP_PRTF || PL_op->op_type == OP_SPRINTF)) + Perl_warner(aTHX_ packWARN(WARN_PRINTF), + "Newline in left-justified string for %sprintf", + (PL_op->op_type == OP_PRTF) ? "" : "s"); have = esignlen + zeros + elen; need = (have > width ? have : width); @@ -10070,12 +10090,21 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) IoPAGE(dstr) = IoPAGE(sstr); IoPAGE_LEN(dstr) = IoPAGE_LEN(sstr); IoLINES_LEFT(dstr) = IoLINES_LEFT(sstr); + if(IoFLAGS(sstr) & IOf_FAKE_DIRP) { + /* I have no idea why fake dirp (rsfps) + should be treaded differently but otherwise + we end up with leaks -- sky*/ + IoTOP_GV(dstr) = gv_dup_inc(IoTOP_GV(sstr), param); + IoFMT_GV(dstr) = gv_dup_inc(IoFMT_GV(sstr), param); + IoBOTTOM_GV(dstr) = gv_dup_inc(IoBOTTOM_GV(sstr), param); + } else { + IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param); + IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param); + IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param); + } IoTOP_NAME(dstr) = SAVEPV(IoTOP_NAME(sstr)); - IoTOP_GV(dstr) = gv_dup(IoTOP_GV(sstr), param); IoFMT_NAME(dstr) = SAVEPV(IoFMT_NAME(sstr)); - IoFMT_GV(dstr) = gv_dup(IoFMT_GV(sstr), param); IoBOTTOM_NAME(dstr) = SAVEPV(IoBOTTOM_NAME(sstr)); - IoBOTTOM_GV(dstr) = gv_dup(IoBOTTOM_GV(sstr), param); IoSUBPROCESS(dstr) = IoSUBPROCESS(sstr); IoTYPE(dstr) = IoTYPE(sstr); IoFLAGS(dstr) = IoFLAGS(sstr); @@ -11202,6 +11231,23 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, /* 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; + + /* Hooks to shared SVs and locks. */ + PL_sharehook = proto_perl->Isharehook; + PL_lockhook = proto_perl->Ilockhook; + PL_unlockhook = proto_perl->Iunlockhook; + PL_threadhook = proto_perl->Ithreadhook; + + PL_runops_std = proto_perl->Irunops_std; + PL_runops_dbg = proto_perl->Irunops_dbg; + +#ifdef THREADS_HAVE_PIDS + PL_ppid = proto_perl->Ippid; +#endif + /* swatch cache */ PL_last_swash_hv = Nullhv; /* reinits on demand */ PL_last_swash_klen = 0;