X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=556abb715da8e076742a54afb16f5e4c650e2a63;hb=d2aeed1648166d254ac68525c35b77dec4ba8772;hp=058d0c22be92842367ec53e0f0fd95633c755a30;hpb=9c12f1e5a87cce227357eea4b0780c0323f952f0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 058d0c2..556abb7 100644 --- a/util.c +++ b/util.c @@ -1025,7 +1025,7 @@ S_mess_alloc(pTHX) XPVMG *any; if (!PL_dirty) - return sv_2mortal(newSVpvs("")); + return newSVpvs_flags("", SVs_TEMP); if (PL_mess_sv) return PL_mess_sv; @@ -1216,7 +1216,7 @@ Perl_write_to_stderr(pTHX_ const char* message, int msglen) PUSHMARK(SP); EXTEND(SP,2); PUSHs(SvTIED_obj((SV*)io, mg)); - PUSHs(sv_2mortal(newSVpvn(message, msglen))); + mPUSHp(message, msglen); PUTBACK; call_method("PRINT", G_SCALAR); @@ -1270,8 +1270,7 @@ S_vdie_common(pTHX_ const char *message, STRLEN msglen, I32 utf8, bool warn) *hook = NULL; } if (warn || message) { - msg = newSVpvn(message, msglen); - SvFLAGS(msg) |= utf8; + msg = newSVpvn_flags(message, msglen, utf8); SvREADONLY_on(msg); SAVEFREESV(msg); } @@ -2343,7 +2342,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) return PerlIO_fdopen(p[This], mode); #else # ifdef OS2 /* Same, without fork()ing and all extra overhead... */ - return my_syspopen4(aTHX_ Nullch, mode, n, args); + return my_syspopen4(aTHX_ NULL, mode, n, args); # else Perl_croak(aTHX_ "List form of piped open not implemented"); return (PerlIO *) NULL; @@ -4139,6 +4138,7 @@ Perl_getcwd_sv(pTHX_ register SV *sv) #endif } +#define VERSION_MAX 0x7FFFFFFF /* =for apidoc scan_version @@ -4170,14 +4170,11 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) int saw_period = 0; int alpha = 0; int width = 3; + bool vinf = FALSE; AV * const av = newAV(); SV * const hv = newSVrv(rv, "version"); /* create an SV and upgrade the RV */ (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ -#ifndef NODEFAULT_SHAREKEYS - HvSHAREKEYS_on(hv); /* key-sharing on by default */ -#endif - while (isSPACE(*s)) /* leading whitespace is OK */ s++; @@ -4219,14 +4216,15 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) if ( saw_period > 1 ) qv = 1; /* force quoted version processing */ + last = pos; pos = s; if ( qv ) - hv_store((HV *)hv, "qv", 2, newSViv(qv), 0); + (void)hv_stores((HV *)hv, "qv", newSViv(qv)); if ( alpha ) - hv_store((HV *)hv, "alpha", 5, newSViv(alpha), 0); + (void)hv_stores((HV *)hv, "alpha", newSViv(alpha)); if ( !qv && width < 3 ) - hv_store((HV *)hv, "width", 5, newSViv(width), 0); + (void)hv_stores((HV *)hv, "width", newSViv(width)); while (isDIGIT(*pos)) pos++; @@ -4239,7 +4237,7 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) /* this is atoi() that delimits on underscores */ const char *end = pos; I32 mult = 1; - I32 orev; + I32 orev; /* the following if() will only be true after the decimal * point of a version originally created with a bare @@ -4248,11 +4246,18 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) if ( !qv && s > start && saw_period == 1 ) { mult *= 100; while ( s < end ) { - orev = rev; + orev = rev; rev += (*s - '0') * mult; mult /= 10; - if ( PERL_ABS(orev) > PERL_ABS(rev) ) - Perl_croak(aTHX_ "Integer overflow in version"); + if ( (PERL_ABS(orev) > PERL_ABS(rev)) + || (PERL_ABS(rev) > VERSION_MAX )) { + if(ckWARN(WARN_OVERFLOW)) + Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in version %d",VERSION_MAX); + s = end - 1; + rev = VERSION_MAX; + vinf = 1; + } s++; if ( *s == '_' ) s++; @@ -4260,18 +4265,29 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) } else { while (--end >= s) { - orev = rev; + orev = rev; rev += (*end - '0') * mult; mult *= 10; - if ( PERL_ABS(orev) > PERL_ABS(rev) ) - Perl_croak(aTHX_ "Integer overflow in version"); + if ( (PERL_ABS(orev) > PERL_ABS(rev)) + || (PERL_ABS(rev) > VERSION_MAX )) { + if(ckWARN(WARN_OVERFLOW)) + Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), + "Integer overflow in version"); + end = s - 1; + rev = VERSION_MAX; + vinf = 1; + } } } } /* Append revision */ av_push(av, newSViv(rev)); - if ( *pos == '.' ) + if ( vinf ) { + s = last; + break; + } + else if ( *pos == '.' ) s = ++pos; else if ( *pos == '_' && isDIGIT(pos[1]) ) s = ++pos; @@ -4310,21 +4326,26 @@ Perl_scan_version(pTHX_ const char *s, SV *rv, bool qv) } /* need to save off the current version string for later */ - if ( s > start ) { + if ( vinf ) { + SV * orig = newSVpvn("v.Inf", sizeof("v.Inf")-1); + (void)hv_stores((HV *)hv, "original", orig); + (void)hv_stores((HV *)hv, "vinf", newSViv(1)); + } + else if ( s > start ) { SV * orig = newSVpvn(start,s-start); if ( qv && saw_period == 1 && *start != 'v' ) { /* need to insert a v to be consistent */ sv_insert(orig, 0, 0, "v", 1); } - hv_store((HV *)hv, "original", 8, orig, 0); + (void)hv_stores((HV *)hv, "original", orig); } else { - hv_store((HV *)hv, "original", 8, newSVpvn("0",1), 0); + (void)hv_stores((HV *)hv, "original", newSVpvn("0",1)); av_push(av, newSViv(0)); } /* And finally, store the AV in the hash */ - hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); + (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av)); /* fix RT#19517 - special case 'undef' as string */ if ( *s == 'u' && strEQ(s,"undef") ) { @@ -4360,30 +4381,27 @@ Perl_new_version(pTHX_ SV *ver) /* This will get reblessed later if a derived class*/ SV * const hv = newSVrv(rv, "version"); (void)sv_upgrade(hv, SVt_PVHV); /* needs to be an HV type */ -#ifndef NODEFAULT_SHAREKEYS - HvSHAREKEYS_on(hv); /* key-sharing on by default */ -#endif if ( SvROK(ver) ) ver = SvRV(ver); /* Begin copying all of the elements */ if ( hv_exists((HV *)ver, "qv", 2) ) - hv_store((HV *)hv, "qv", 2, &PL_sv_yes, 0); + (void)hv_stores((HV *)hv, "qv", newSViv(1)); if ( hv_exists((HV *)ver, "alpha", 5) ) - hv_store((HV *)hv, "alpha", 5, &PL_sv_yes, 0); + (void)hv_stores((HV *)hv, "alpha", newSViv(1)); if ( hv_exists((HV*)ver, "width", 5 ) ) { const I32 width = SvIV(*hv_fetchs((HV*)ver, "width", FALSE)); - hv_store((HV *)hv, "width", 5, newSViv(width), 0); + (void)hv_stores((HV *)hv, "width", newSViv(width)); } if ( hv_exists((HV*)ver, "original", 8 ) ) { SV * pv = *hv_fetchs((HV*)ver, "original", FALSE); - hv_store((HV *)hv, "original", 8, newSVsv(pv), 0); + (void)hv_stores((HV *)hv, "original", newSVsv(pv)); } sav = (AV *)SvRV(*hv_fetchs((HV*)ver, "version", FALSE)); @@ -4394,7 +4412,7 @@ Perl_new_version(pTHX_ SV *ver) av_push(av, newSViv(rev)); } - hv_store((HV *)hv, "version", 7, newRV_noinc((SV *)av), 0); + (void)hv_stores((HV *)hv, "version", newRV_noinc((SV *)av)); return rv; } #ifdef SvVOK @@ -5086,6 +5104,26 @@ Perl_sv_nosharing(pTHX_ SV *sv) PERL_UNUSED_ARG(sv); } +/* + +=for apidoc sv_destroyable + +Dummy routine which reports that object can be destroyed when there is no +sharing module present. It ignores its single SV argument, and returns +'true'. Exists to avoid test for a NULL function pointer and because it +could potentially warn under some level of strict-ness. + +=cut +*/ + +bool +Perl_sv_destroyable(pTHX_ SV *sv) +{ + PERL_UNUSED_CONTEXT; + PERL_UNUSED_ARG(sv); + return TRUE; +} + U32 Perl_parse_unicode_opts(pTHX_ const char **popt) { @@ -5659,7 +5697,8 @@ Perl_my_clearenv(pTHX) bsiz = l + 1; /* + 1 for the \0. */ buf = (char*)safesysmalloc(bufsiz); } - my_strlcpy(buf, *environ, l + 1); + memcpy(buf, *environ, l); + buf[l] = '\0'; (void)unsetenv(buf); } (void)safesysfree(buf); @@ -5871,6 +5910,24 @@ Perl_my_dirfd(pTHX_ DIR * dir) { #endif } +REGEXP * +Perl_get_re_arg(pTHX_ SV *sv) { + SV *tmpsv; + + if (sv) { + if (SvMAGICAL(sv)) + mg_get(sv); + if (SvROK(sv) && + (tmpsv = (SV*)SvRV(sv)) && /* assign deliberate */ + SvTYPE(tmpsv) == SVt_REGEXP) + { + return (REGEXP*) tmpsv; + } + } + + return NULL; +} + /* * Local variables: * c-indentation-style: bsd