X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=sv.c;h=13b548bd5e16644fcba0fa18f5700d9396f6fb91;hb=158b3652342ca691c9e3b061a1d78456ae1a9b4a;hp=21de7ed654e6ecca725fb87963c096bc98fff12e;hpb=d6b7ef8642dbff7f74dde11fd4995a37e8f38c04;p=p5sagit%2Fp5-mst-13.2.git diff --git a/sv.c b/sv.c index 21de7ed..13b548b 100644 --- a/sv.c +++ b/sv.c @@ -2867,7 +2867,7 @@ uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) sign = 1; } do { - *--ptr = '0' + (uv % 10); + *--ptr = '0' + (char)(uv % 10); } while (uv /= 10); if (sign) *--ptr = '-'; @@ -2875,16 +2875,6 @@ uiv_2buf(char *buf, IV iv, UV uv, int is_uv, char **peob) return ptr; } -/* For backwards-compatibility only. sv_2pv() is normally #def'ed to - * C. See also C. - */ - -char * -Perl_sv_2pv(pTHX_ register SV *sv, STRLEN *lp) -{ - return sv_2pv_flags(sv, lp, SV_GMAGIC); -} - /* =for apidoc sv_2pv_flags @@ -2966,7 +2956,8 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) char ch; int left = 0; int right = 4; - U16 reganch = (re->reganch & PMf_COMPILETIME) >> 12; + char need_newline = 0; + U16 reganch = (U16)((re->reganch & PMf_COMPILETIME) >> 12); while((ch = *fptr++)) { if(reganch & 1) { @@ -2983,11 +2974,45 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) } mg->mg_len = re->prelen + 4 + left; + /* + * If /x was used, we have to worry about a regex + * ending with a comment later being embedded + * within another regex. If so, we don't want this + * regex's "commentization" to leak out to the + * right part of the enclosing regex, we must cap + * it with a newline. + * + * So, if /x was used, we scan backwards from the + * end of the regex. If we find a '#' before we + * find a newline, we need to add a newline + * ourself. If we find a '\n' first (or if we + * don't find '#' or '\n'), we don't need to add + * anything. -jfriedl + */ + if (PMf_EXTENDED & re->reganch) + { + char *endptr = re->precomp + re->prelen; + while (endptr >= re->precomp) + { + char c = *(endptr--); + if (c == '\n') + break; /* don't need another */ + if (c == '#') { + /* we end while in a comment, so we + need a newline */ + mg->mg_len++; /* save space for it */ + need_newline = 1; /* note to add it */ + } + } + } + New(616, mg->mg_ptr, mg->mg_len + 1 + left, char); Copy("(?", mg->mg_ptr, 2, char); Copy(reflags, mg->mg_ptr+2, left, char); Copy(":", mg->mg_ptr+left+2, 1, char); Copy(re->precomp, mg->mg_ptr+3+left, re->prelen, char); + if (need_newline) + mg->mg_ptr[mg->mg_len - 2] = '\n'; mg->mg_ptr[mg->mg_len - 1] = ')'; mg->mg_ptr[mg->mg_len] = 0; } @@ -3055,7 +3080,7 @@ Perl_sv_2pv_flags(pTHX_ register SV *sv, STRLEN *lp, I32 flags) ptr = uiv_2buf(buf, 0, SvUVX(sv), 1, &ebuf); else ptr = uiv_2buf(buf, SvIVX(sv), 0, 0, &ebuf); - SvGROW(sv, ebuf - ptr + 1); /* inlined from sv_setpvn */ + SvGROW(sv, (STRLEN)(ebuf - ptr + 1)); /* inlined from sv_setpvn */ Move(ptr,SvPVX(sv),ebuf - ptr,char); SvCUR_set(sv, ebuf - ptr); s = SvEND(sv); @@ -3167,14 +3192,16 @@ would lose the UTF-8'ness of the PV. void Perl_sv_copypv(pTHX_ SV *dsv, register SV *ssv) { - SV *tmpsv = sv_newmortal(); + SV *tmpsv; - if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) ) { - tmpsv = AMG_CALLun(ssv,string); + if ( SvTHINKFIRST(ssv) && SvROK(ssv) && SvAMAGIC(ssv) && + (tmpsv = AMG_CALLun(ssv,string))) { if (SvTYPE(tmpsv) != SVt_RV || (SvRV(tmpsv) != SvRV(ssv))) { SvSetSV(dsv,tmpsv); return; } + } else { + tmpsv = sv_newmortal(); } { STRLEN len; @@ -3283,7 +3310,7 @@ Perl_sv_2bool(pTHX_ register SV *sv) SV* tmpsv; if (SvAMAGIC(sv) && (tmpsv=AMG_CALLun(sv,bool_)) && (!SvROK(tmpsv) || (SvRV(tmpsv) != SvRV(sv)))) - return SvTRUE(tmpsv); + return (bool)SvTRUE(tmpsv); return SvRV(sv) != 0; } if (SvPOKp(sv)) { @@ -3319,16 +3346,6 @@ if all the bytes have hibit clear. This is not as a general purpose byte encoding to Unicode interface: use the Encode extension for that. -=cut -*/ - -STRLEN -Perl_sv_utf8_upgrade(pTHX_ register SV *sv) -{ - return sv_utf8_upgrade_flags(sv, SV_GMAGIC); -} - -/* =for apidoc sv_utf8_upgrade_flags Convert the PV of an SV to its UTF8-encoded form. @@ -3512,20 +3529,6 @@ You probably want to use one of the assortment of wrappers, such as C, C, C and C. - -=cut -*/ - -/* sv_setsv() is aliased to Perl_sv_setsv_macro; this function provided - for binary compatibility only -*/ -void -Perl_sv_setsv(pTHX_ SV *dstr, register SV *sstr) -{ - sv_setsv_flags(dstr, sstr, SV_GMAGIC); -} - -/* =for apidoc sv_setsv_flags Copies the contents of the source SV C into the destination SV @@ -3705,7 +3708,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) default: if (SvGMAGICAL(sstr) && (flags & SV_GMAGIC)) { mg_get(sstr); - if (SvTYPE(sstr) != stype) { + if ((int)SvTYPE(sstr) != stype) { stype = SvTYPE(sstr); if (stype == SVt_PVGV && dtype <= SVt_PVGV) goto glob_assign; @@ -3714,7 +3717,7 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) if (stype == SVt_PVLV) (void)SvUPGRADE(dstr, SVt_PVNV); else - (void)SvUPGRADE(dstr, stype); + (void)SvUPGRADE(dstr, (U32)stype); } sflags = SvFLAGS(sstr); @@ -3798,8 +3801,9 @@ Perl_sv_setsv_flags(pTHX_ SV *dstr, register SV *sstr, I32 flags) { Perl_warner(aTHX_ packWARN(WARN_REDEFINE), CvCONST(cv) - ? "Constant subroutine %s redefined" - : "Subroutine %s redefined", + ? "Constant subroutine %s::%s redefined" + : "Subroutine %s::%s redefined", + HvNAME(GvSTASH((GV*)dstr)), GvENAME((GV*)dstr)); } } @@ -4244,19 +4248,6 @@ C indicates number of bytes to copy. If the SV has the UTF8 status set, then the bytes appended should be valid UTF8. Handles 'get' magic, but not 'set' magic. See C. -=cut -*/ - -/* sv_catpvn() is aliased to Perl_sv_catpvn_macro; this function provided - for binary compatibility only -*/ -void -Perl_sv_catpvn(pTHX_ SV *dsv, const char* sstr, STRLEN slen) -{ - sv_catpvn_flags(dsv, sstr, slen, SV_GMAGIC); -} - -/* =for apidoc sv_catpvn_flags Concatenates the string onto the end of the string which is in the SV. The @@ -4308,18 +4299,6 @@ Concatenates the string from SV C onto the end of the string in SV C. Modifies C but not C. Handles 'get' magic, but not 'set' magic. See C. -=cut */ - -/* sv_catsv() is aliased to Perl_sv_catsv_macro; this function provided - for binary compatibility only -*/ -void -Perl_sv_catsv(pTHX_ SV *dstr, register SV *sstr) -{ - sv_catsv_flags(dstr, sstr, SV_GMAGIC); -} - -/* =for apidoc sv_catsv_flags Concatenates the string from SV C onto the end of the string in @@ -4489,7 +4468,9 @@ Perl_sv_magicext(pTHX_ SV* sv, SV* obj, int how, MGVTBL *vtable, (SvTYPE(obj) == SVt_PVGV && (GvSV(obj) == sv || GvHV(obj) == (HV*)sv || GvAV(obj) == (AV*)sv || GvCV(obj) == (CV*)sv || GvIOp(obj) == (IO*)sv || - GvFORM(obj) == (CV*)sv))) + GvFORM(obj) == (CV*)sv)) || + (how == PERL_MAGIC_tiedscalar && + SvROK(obj) && (SvRV(obj) == sv || GvIO(SvRV(obj)) == (IO*)sv))) { mg->mg_obj = obj; } @@ -5323,7 +5304,7 @@ Perl_sv_pos_b2u(pTHX_ register SV *sv, I32* offsetp) return; s = (U8*)SvPV(sv, len); - if (len < *offsetp) + if ((I32)len < *offsetp) Perl_croak(aTHX_ "panic: sv_pos_b2u: bad byte offset"); send = s + *offsetp; len = 0; @@ -5677,7 +5658,7 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) /* Grab the size of the record we're getting */ recsize = SvIV(SvRV(PL_rs)); (void)SvPOK_only(sv); /* Validate pointer */ - buffer = SvGROW(sv, recsize + 1); + buffer = SvGROW(sv, (STRLEN)(recsize + 1)); /* Go yank in */ #ifdef VMS /* VMS wants read instead of fread, because fread doesn't respect */ @@ -5763,15 +5744,15 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) cnt = PerlIO_get_cnt(fp); /* get count into register */ (void)SvPOK_only(sv); /* validate pointer */ - if (SvLEN(sv) - append <= cnt + 1) { /* make sure we have the room */ - if (cnt > 80 && SvLEN(sv) > append) { + if ((I32)(SvLEN(sv) - append) <= cnt + 1) { /* make sure we have the room */ + if (cnt > 80 && (I32)SvLEN(sv) > append) { shortbuffered = cnt - SvLEN(sv) + append + 1; cnt -= shortbuffered; } else { shortbuffered = 0; /* remember that cnt can be negative */ - SvGROW(sv, append + (cnt <= 0 ? 2 : (cnt + 1))); + SvGROW(sv, (STRLEN)(append + (cnt <= 0 ? 2 : (cnt + 1)))); } } else @@ -5845,14 +5826,14 @@ Perl_sv_gets(pTHX_ register SV *sv, register PerlIO *fp, I32 append) SvGROW(sv, bpx + cnt + 2); bp = (STDCHAR*)SvPVX(sv) + bpx; /* unbox after relocation */ - *bp++ = i; /* store character from PerlIO_getc */ + *bp++ = (STDCHAR)i; /* store character from PerlIO_getc */ if (rslen && (STDCHAR)i == rslast) /* all done for now? */ goto thats_all_folks; } thats_all_folks: - if ((rslen > 1 && (bp - (STDCHAR*)SvPVX(sv) < rslen)) || + if ((rslen > 1 && (STRLEN)(bp - (STDCHAR*)SvPVX(sv)) < rslen) || memNE((char*)bp - rslen, rsptr, rslen)) goto screamer; /* go back to the fray */ thats_really_all_folks: @@ -5888,7 +5869,7 @@ screamer2: if (rslen) { register STDCHAR *bpe = buf + sizeof(buf); bp = buf; - while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = i) != rslast && bp < bpe) + while ((i = PerlIO_getc(fp)) != EOF && (*bp++ = (STDCHAR)i) != rslast && bp < bpe) ; /* keep reading */ cnt = bp - buf; } @@ -6357,7 +6338,7 @@ Perl_newSVpvn_share(pTHX_ const char *src, I32 len, U32 hash) len = tmplen; } if (!hash) - PERL_HASH(hash, src, len); + PERL_HASH(hash, (U8*)src, len); new_SV(sv); sv_upgrade(sv, SVt_PVIV); SvPVX(sv) = sharepvn(src, is_utf8?-len:len, hash); @@ -6617,8 +6598,14 @@ Perl_sv_reset(pTHX_ register char *s, HV *stash) if (GvHV(gv) && !HvNAME(GvHV(gv))) { hv_clear(GvHV(gv)); #ifdef USE_ENVIRON_ARRAY - if (gv == PL_envgv) + if (gv == PL_envgv +# ifdef USE_ITHREADS + && PL_curinterp == aTHX +# endif + ) + { environ[0] = Nullch; + } #endif } } @@ -6847,24 +6834,8 @@ Perl_sv_nv(pTHX_ register SV *sv) /* =for apidoc sv_pv -A private implementation of the C macro for compilers which can't -cope with complex macro expressions. Always use the macro instead. +Use the C macro instead -=cut -*/ - -char * -Perl_sv_pv(pTHX_ SV *sv) -{ - STRLEN n_a; - - if (SvPOK(sv)) - return SvPVX(sv); - - return sv_2pv(sv, &n_a); -} - -/* =for apidoc sv_pvn A private implementation of the C macro for compilers which can't @@ -6883,8 +6854,6 @@ Perl_sv_pvn(pTHX_ SV *sv, STRLEN *lp) return sv_2pv(sv, lp); } -/* For -DCRIPPLED_CC only. See also C. - */ char * Perl_sv_pvn_nomg(pTHX_ register SV *sv, STRLEN *lp) @@ -6903,16 +6872,6 @@ Get a sensible string out of the SV somehow. A private implementation of the C macro for compilers which can't cope with complex macro expressions. Always use the macro instead. -=cut -*/ - -char * -Perl_sv_pvn_force(pTHX_ SV *sv, STRLEN *lp) -{ - return sv_pvn_force_flags(sv, lp, SV_GMAGIC); -} - -/* =for apidoc sv_pvn_force_flags Get a sensible string out of the SV somehow. @@ -6967,21 +6926,8 @@ Perl_sv_pvn_force_flags(pTHX_ SV *sv, STRLEN *lp, I32 flags) /* =for apidoc sv_pvbyte -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. - -=cut -*/ - -char * -Perl_sv_pvbyte(pTHX_ SV *sv) -{ - sv_utf8_downgrade(sv,0); - return sv_pv(sv); -} +Use C instead. -/* =for apidoc sv_pvbyten A private implementation of the C macro for compilers @@ -7018,21 +6964,8 @@ Perl_sv_pvbyten_force(pTHX_ SV *sv, STRLEN *lp) /* =for apidoc sv_pvutf8 -A private implementation of the C macro for compilers -which can't cope with complex macro expressions. Always use the macro -instead. - -=cut -*/ - -char * -Perl_sv_pvutf8(pTHX_ SV *sv) -{ - sv_utf8_upgrade(sv); - return sv_pv(sv); -} +Use the C macro instead -/* =for apidoc sv_pvutf8n A private implementation of the C macro for compilers @@ -7367,9 +7300,6 @@ Perl_sv_bless(pTHX_ SV *sv, HV *stash) } /* Downgrades a PVGV to a PVMG. - * - * XXX This function doesn't actually appear to be used anywhere - * DAPM 15-Jun-01 */ STATIC void @@ -7497,44 +7427,6 @@ Perl_sv_tainted(pTHX_ SV *sv) return FALSE; } -/* -=for apidoc sv_setpviv - -Copies an integer into the given SV, also updating its string value. -Does not handle 'set' magic. See C. - -=cut -*/ - -void -Perl_sv_setpviv(pTHX_ SV *sv, IV iv) -{ - char buf[TYPE_CHARS(UV)]; - char *ebuf; - char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); - - sv_setpvn(sv, ptr, ebuf - ptr); -} - -/* -=for apidoc sv_setpviv_mg - -Like C, but also handles 'set' magic. - -=cut -*/ - -void -Perl_sv_setpviv_mg(pTHX_ SV *sv, IV iv) -{ - char buf[TYPE_CHARS(UV)]; - char *ebuf; - char *ptr = uiv_2buf(buf, iv, 0, 0, &ebuf); - - sv_setpvn(sv, ptr, ebuf - ptr); - SvSETMAGIC(sv); -} - #if defined(PERL_IMPLICIT_CONTEXT) /* pTHX_ magic can't cope with varargs, so this is a no-context @@ -7837,7 +7729,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV SV *vecsv; U8 *vecstr = Null(U8*); STRLEN veclen = 0; - char c; + char c = 0; int i; unsigned base = 0; IV iv = 0; @@ -7999,6 +7891,25 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV /* SIZE */ switch (*q) { +#ifdef WIN32 + case 'I': /* Ix, I32x, and I64x */ +# ifdef WIN64 + if (q[1] == '6' && q[2] == '4') { + q += 3; + intsize = 'q'; + break; + } +# endif + if (q[1] == '3' && q[2] == '2') { + q += 3; + break; + } +# ifdef WIN64 + intsize = 'q'; +# endif + q++; + break; +#endif #if defined(HAS_QUAD) || (defined(HAS_LONG_DOUBLE) && defined(USE_LONG_DOUBLE)) case 'L': /* Ld */ /* FALL THROUGH */ @@ -8473,7 +8384,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV SvGROW(sv, SvCUR(sv) + need + dotstrlen + 1); p = SvEND(sv); if (esignlen && fill == '0') { - for (i = 0; i < esignlen; i++) + for (i = 0; i < (int)esignlen; i++) *p++ = esignbuf[i]; } if (gap && !left) { @@ -8481,7 +8392,7 @@ Perl_sv_vcatpvfn(pTHX_ SV *sv, const char *pat, STRLEN patlen, va_list *args, SV p += gap; } if (esignlen && fill != '0') { - for (i = 0; i < esignlen; i++) + for (i = 0; i < (int)esignlen; i++) *p++ = esignbuf[i]; } if (zeros) { @@ -9250,10 +9161,12 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) PERL_HV_ARRAY_ALLOC_BYTES(dxhv->xhv_max+1), char); while (i <= sxhv->xhv_max) { ((HE**)dxhv->xhv_array)[i] = he_dup(((HE**)sxhv->xhv_array)[i], - !!HvSHAREKEYS(sstr), param); + (bool)!!HvSHAREKEYS(sstr), + param); ++i; } - dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, !!HvSHAREKEYS(sstr), param); + dxhv->xhv_eiter = he_dup(sxhv->xhv_eiter, + (bool)!!HvSHAREKEYS(sstr), param); } else { SvPVX(dstr) = Nullch; @@ -9313,7 +9226,7 @@ Perl_sv_dup(pTHX_ SV *sstr, CLONE_PARAMS* param) CvFILE(dstr) = CvXSUB(sstr) ? CvFILE(sstr) : SAVEPV(CvFILE(sstr)); break; default: - Perl_croak(aTHX_ "Bizarre SvTYPE [%d]", SvTYPE(sstr)); + Perl_croak(aTHX_ "Bizarre SvTYPE [%" IVdf "]", (IV)SvTYPE(sstr)); break; } @@ -9989,11 +9902,9 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, #endif PL_encoding = sv_dup(proto_perl->Iencoding, param); -#ifdef DEBUGGING sv_setpvn(PERL_DEBUG_PAD(0), "", 0); /* For regex debugging. */ - sv_setpvn(PERL_DEBUG_PAD(1), "", 0); - sv_setpvn(PERL_DEBUG_PAD(2), "", 0); -#endif + sv_setpvn(PERL_DEBUG_PAD(1), "", 0); /* ext/re needs these */ + sv_setpvn(PERL_DEBUG_PAD(2), "", 0); /* even without DEBUGGING. */ /* Clone the regex array */ PL_regex_padav = newAV(); @@ -10259,6 +10170,8 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, 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_idstart = sv_dup_inc(proto_perl->Iutf8_idstart, param); + PL_utf8_idcont = sv_dup_inc(proto_perl->Iutf8_idcont, param); /* swatch cache */ PL_last_swash_hv = Nullhv; /* reinits on demand */ @@ -10336,7 +10249,7 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags, PL_retstack_ix = proto_perl->Tretstack_ix; PL_retstack_max = proto_perl->Tretstack_max; Newz(54, PL_retstack, PL_retstack_max, OP*); - Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, I32); + Copy(proto_perl->Tretstack, PL_retstack, PL_retstack_ix, OP*); /* NOTE: si_dup() looks at PL_markstack */ PL_curstackinfo = si_dup(proto_perl->Tcurstackinfo, param);