X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=c2b41714acbfca6637a28bc771d4a8d6589188ea;hb=e27835eefa408ae52d4ae22eec67eea282a87949;hp=f2b24a67871a8ba007e6db8af681e88782cb18d8;hpb=cddfcddc190fa3c9953973822c35e3baa71181f0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index f2b24a6..c2b4171 100644 --- a/sv.c +++ b/sv.c @@ -249,13 +249,12 @@ S_new_SV(pTHX) SvREFCNT(sv) = 1; SvFLAGS(sv) = 0; sv->sv_debug_optype = PL_op ? PL_op->op_type : 0; - sv->sv_debug_line = (U16) (PL_parser - ? PL_parser->copline == NOLINE - ? PL_curcop + sv->sv_debug_line = (U16) (PL_parser && PL_parser->copline != NOLINE + ? PL_parser->copline + : PL_curcop ? CopLINE(PL_curcop) : 0 - : PL_parser->copline - : 0); + ); sv->sv_debug_inpad = 0; sv->sv_debug_cloned = 0; sv->sv_debug_file = PL_curcop ? savepv(CopFILE(PL_curcop)): NULL; @@ -1492,7 +1491,7 @@ Perl_sv_grow(pTHX_ register SV *const sv, register STRLEN newlen) s = SvPVX_mutable(sv); if (newlen > SvLEN(sv)) { /* need more room? */ -#ifndef MYMALLOC +#ifndef Perl_safesysmalloc_size newlen = PERL_STRLEN_ROUNDUP(newlen); #endif if (SvLEN(sv) && s) { @@ -1544,6 +1543,8 @@ Perl_sv_setiv(pTHX_ register SV *const sv, const IV i) break; case SVt_PVGV: + if (!isGV_with_GP(sv)) + break; case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -1651,6 +1652,8 @@ Perl_sv_setnv(pTHX_ register SV *const sv, const NV num) break; case SVt_PVGV: + if (!isGV_with_GP(sv)) + break; case SVt_PVAV: case SVt_PVHV: case SVt_PVCV: @@ -3163,13 +3166,21 @@ Perl_sv_utf8_upgrade_flags(pTHX_ register SV *const sv, const I32 flags) const U8 ch = *t++; /* Check for hi bit */ if (!NATIVE_IS_INVARIANT(ch)) { - STRLEN len = SvCUR(sv) + 1; /* Plus the \0 */ + STRLEN len = SvCUR(sv); + /* *Currently* bytes_to_utf8() adds a '\0' after every string + it converts. This isn't documented. It's not clear if it's + a bad thing to be doing, and should be changed to do exactly + what the documentation says. If so, this code will have to + be changed. + As is, we mustn't rely on our incoming SV being well formed + and having a trailing '\0', as certain code in pp_formline + can send us partially built SVs. */ U8 * const recoded = bytes_to_utf8((U8*)s, &len); SvPV_free(sv); /* No longer using what was there before. */ SvPV_set(sv, (char*)recoded); - SvCUR_set(sv, len - 1); - SvLEN_set(sv, len); /* No longer know the real size. */ + SvCUR_set(sv, len); + SvLEN_set(sv, len + 1); /* No longer know the real size. */ break; } } @@ -3553,7 +3564,6 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) { /* need to nuke the magic */ mg_free(dstr); - SvRMAGICAL_off(dstr); } /* There's a lot of redundancy below but we're going for speed here */ @@ -3718,8 +3728,10 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV* sstr, const I32 flags) GvMULTI_on(dstr); return; } - glob_assign_glob(dstr, sstr, dtype); - return; + if (isGV_with_GP(sstr)) { + glob_assign_glob(dstr, sstr, dtype); + return; + } } if (dtype >= SVt_PV) { @@ -4377,6 +4389,7 @@ Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr) #ifdef DEBUGGING const U8 *real_start; #endif + STRLEN max_delta; PERL_ARGS_ASSERT_SV_CHOP; @@ -4387,8 +4400,17 @@ Perl_sv_chop(pTHX_ register SV *const sv, register const char *const ptr) /* Nothing to do. */ return; } - assert(ptr > SvPVX_const(sv)); + /* SvPVX(sv) may move in SV_CHECK_THINKFIRST(sv), but after this line, + nothing uses the value of ptr any more. */ + if (ptr <= SvPVX_const(sv)) + Perl_croak(aTHX_ "panic: sv_chop ptr=%p, start=%p, end=%p", + ptr, SvPVX_const(sv), SvPVX_const(sv) + max_delta); SV_CHECK_THINKFIRST(sv); + max_delta = SvLEN(sv) ? SvLEN(sv) : SvCUR(sv); + if (delta > max_delta) + Perl_croak(aTHX_ "panic: sv_chop ptr=%p (was %p), start=%p, end=%p", + SvPVX_const(sv) + delta, ptr, SvPVX_const(sv), + SvPVX_const(sv) + max_delta); if (!SvOOK(sv)) { if (!SvLEN(sv)) { /* make copy of shared string */ @@ -5140,14 +5162,17 @@ Perl_sv_kill_backrefs(pTHX_ SV *const sv, AV *const av) =for apidoc sv_insert Inserts a string at the specified offset/length within the SV. Similar to -the Perl substr() function. +the Perl substr() function. Handles get magic. + +=for apidoc sv_insert_flags + +Same as C, but the extra C are passed the C that applies to C. =cut */ void -Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, - const char *const little, const STRLEN littlelen) +Perl_sv_insert_flags(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, const char *const little, const STRLEN littlelen, const U32 flags) { dVAR; register char *big; @@ -5157,11 +5182,11 @@ Perl_sv_insert(pTHX_ SV *const bigstr, const STRLEN offset, const STRLEN len, register I32 i; STRLEN curlen; - PERL_ARGS_ASSERT_SV_INSERT; + PERL_ARGS_ASSERT_SV_INSERT_FLAGS; if (!bigstr) Perl_croak(aTHX_ "Can't modify non-existent substring"); - SvPV_force(bigstr, curlen); + SvPV_force_flags(bigstr, curlen, flags); (void)SvPOK_only_UTF8(bigstr); if (offset + len > curlen) { SvGROW(bigstr, offset+len+1); @@ -6633,6 +6658,9 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) I32 bytesread; char *buffer; U32 recsize; +#ifdef VMS + int fd; +#endif /* Grab the size of the record we're getting */ recsize = SvUV(SvRV(PL_rs)); /* RsRECORD() guarantees > 0. */ @@ -6644,7 +6672,13 @@ Perl_sv_gets(pTHX_ register SV *const sv, register PerlIO *const fp, I32 append) /* doing, but we've got no other real choice - except avoid stdio as implementation - perhaps write a :vms layer ? */ - bytesread = PerlLIO_read(PerlIO_fileno(fp), buffer, recsize); + fd = PerlIO_fileno(fp); + if (fd == -1) { /* in-memory file from PerlIO::Scalar */ + bytesread = PerlIO_read(fp, buffer, recsize); + } + else { + bytesread = PerlLIO_read(fd, buffer, recsize); + } #else bytesread = PerlIO_read(fp, buffer, recsize); #endif @@ -7806,11 +7840,14 @@ Perl_sv_2io(pTHX_ SV *const sv) io = (IO*)sv; break; case SVt_PVGV: - gv = (GV*)sv; - io = GvIO(gv); - if (!io) - Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); - break; + if (isGV_with_GP(sv)) { + gv = (GV*)sv; + io = GvIO(gv); + if (!io) + Perl_croak(aTHX_ "Bad filehandle: %s", GvNAME(gv)); + break; + } + /* FALL THROUGH */ default: if (!SvOK(sv)) Perl_croak(aTHX_ PL_no_usym, "filehandle"); @@ -7863,15 +7900,18 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) *gvp = NULL; return NULL; case SVt_PVGV: - gv = (GV*)sv; - *gvp = gv; - *st = GvESTASH(gv); - goto fix_gv; + if (isGV_with_GP(sv)) { + gv = (GV*)sv; + *gvp = gv; + *st = GvESTASH(gv); + goto fix_gv; + } + /* FALL THROUGH */ default: - SvGETMAGIC(sv); if (SvROK(sv)) { SV * const *sp = &sv; /* Used in tryAMAGICunDEREF macro. */ + SvGETMAGIC(sv); tryAMAGICunDEREF(to_cv); sv = SvRV(sv); @@ -7881,22 +7921,24 @@ Perl_sv_2cv(pTHX_ SV *sv, HV **const st, GV **const gvp, const I32 lref) *st = CvSTASH(cv); return cv; } - else if(isGV(sv)) + else if(isGV_with_GP(sv)) gv = (GV*)sv; else Perl_croak(aTHX_ "Not a subroutine reference"); } - else if (isGV(sv)) + else if (isGV_with_GP(sv)) { + SvGETMAGIC(sv); gv = (GV*)sv; + } else - gv = gv_fetchsv(sv, lref, SVt_PVCV); + gv = gv_fetchsv(sv, lref, SVt_PVCV); /* Calls get magic */ *gvp = gv; if (!gv) { *st = NULL; return NULL; } /* Some flags to gv_fetchsv mean don't really create the GV */ - if (SvTYPE(gv) != SVt_PVGV) { + if (!isGV_with_GP(gv)) { *st = NULL; return NULL; } @@ -8111,7 +8153,8 @@ Perl_sv_reftype(pTHX_ const SV *const sv, const int ob) case SVt_PVAV: return "ARRAY"; case SVt_PVHV: return "HASH"; case SVt_PVCV: return "CODE"; - case SVt_PVGV: return "GLOB"; + case SVt_PVGV: return (char *) (isGV_with_GP(sv) + ? "GLOB" : "SCALAR"); case SVt_PVFM: return "FORMAT"; case SVt_PVIO: return "IO"; case SVt_BIND: return "BIND"; @@ -12310,8 +12353,10 @@ S_varname(pTHX_ GV *gv, const char gvtype, PADOFFSET targ, *SvPVX(name) = '$'; Perl_sv_catpvf(aTHX_ name, "[%"IVdf"]", (IV)aindex); } - else if (subscript_type == FUV_SUBSCRIPT_WITHIN) - Perl_sv_insert(aTHX_ name, 0, 0, STR_WITH_LEN("within ")); + else if (subscript_type == FUV_SUBSCRIPT_WITHIN) { + /* We know that name has no magic, so can use 0 instead of SV_GMAGIC */ + Perl_sv_insert_flags(aTHX_ name, 0, 0, STR_WITH_LEN("within "), 0); + } return name; } @@ -12569,6 +12614,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) case OP_PRTF: case OP_PRINT: case OP_SAY: + match = 1; /* print etc can return undef on defined args */ /* skip filehandle as it can't produce 'undef' warning */ o = cUNOPx(obase)->op_first; if ((obase->op_flags & OPf_STACKED) && o->op_type == OP_PUSHMARK) @@ -12578,8 +12624,81 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) case OP_ENTEREVAL: /* could be eval $undef or $x='$undef'; eval $x */ case OP_RV2SV: - case OP_CUSTOM: - match = 1; /* XS or custom code could trigger random warnings */ + case OP_CUSTOM: /* XS or custom code could trigger random warnings */ + + /* the following ops are capable of returning PL_sv_undef even for + * defined arg(s) */ + + case OP_BACKTICK: + case OP_PIPE_OP: + case OP_FILENO: + case OP_BINMODE: + case OP_TIED: + case OP_GETC: + case OP_SYSREAD: + case OP_SEND: + case OP_IOCTL: + case OP_SOCKET: + case OP_SOCKPAIR: + case OP_BIND: + case OP_CONNECT: + case OP_LISTEN: + case OP_ACCEPT: + case OP_SHUTDOWN: + case OP_SSOCKOPT: + case OP_GETPEERNAME: + case OP_FTRREAD: + case OP_FTRWRITE: + case OP_FTREXEC: + case OP_FTROWNED: + case OP_FTEREAD: + case OP_FTEWRITE: + case OP_FTEEXEC: + case OP_FTEOWNED: + case OP_FTIS: + case OP_FTZERO: + case OP_FTSIZE: + case OP_FTFILE: + case OP_FTDIR: + case OP_FTLINK: + case OP_FTPIPE: + case OP_FTSOCK: + case OP_FTBLK: + case OP_FTCHR: + case OP_FTTTY: + case OP_FTSUID: + case OP_FTSGID: + case OP_FTSVTX: + case OP_FTTEXT: + case OP_FTBINARY: + case OP_FTMTIME: + case OP_FTATIME: + case OP_FTCTIME: + case OP_READLINK: + case OP_OPEN_DIR: + case OP_READDIR: + case OP_TELLDIR: + case OP_SEEKDIR: + case OP_REWINDDIR: + case OP_CLOSEDIR: + case OP_GMTIME: + case OP_ALARM: + case OP_SEMGET: + case OP_GETLOGIN: + case OP_UNDEF: + case OP_SUBSTR: + case OP_AEACH: + case OP_EACH: + case OP_SORT: + case OP_CALLER: + case OP_DOFILE: + case OP_PROTOTYPE: + case OP_NCMP: + case OP_SMARTMATCH: + case OP_UNPACK: + case OP_SYSOPEN: + case OP_SYSSEEK: + match = 1; goto do_op; case OP_ENTERSUB: @@ -12591,6 +12710,7 @@ S_find_uninit_var(pTHX_ OP* obase, SV* uninit_sv, bool match) Need a better fix at dome point. DAPM 11/2007 */ break; + case OP_POS: /* def-ness of rval pos() is independent of the def-ness of its arg */ if ( !(obase->op_flags & OPf_MOD))