X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=7f3813527741c09f5ba01a93346ed522a560bdb8;hb=dc6d0c4f0dc8290035f9541d4ee259b8bfea7456;hp=48f905839783467e40cb68ad4265af6b5c0c740d;hpb=132efe8bfb7cd0fb1beb15aaf284e33bf44eb1fa;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 48f9058..7f38135 100644 --- a/util.c +++ b/util.c @@ -1033,6 +1033,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) CV *cv; SV *msv; STRLEN msglen; + I32 utf8 = 0; DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: die: curstack = %p, mainstack = %p\n", @@ -1047,6 +1048,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) } else message = SvPV(msv,msglen); + utf8 = SvUTF8(msv); } else { message = Nullch; @@ -1072,6 +1074,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) save_re_context(); if (message) { msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; SvREADONLY_on(msg); SAVEFREESV(msg); } @@ -1090,6 +1093,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) } PL_restartop = die_where(message, msglen); + SvFLAGS(ERRSV) |= utf8; DEBUG_S(PerlIO_printf(Perl_debug_log, "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", thr, PL_restartop, was_in_eval, PL_top_env)); @@ -1132,6 +1136,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) CV *cv; SV *msv; STRLEN msglen; + I32 utf8 = 0; if (pat) { msv = vmess(pat, args); @@ -1142,6 +1147,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) } else message = SvPV(msv,msglen); + utf8 = SvUTF8(msv); } else { message = Nullch; @@ -1167,6 +1173,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) save_re_context(); if (message) { msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; SvREADONLY_on(msg); SAVEFREESV(msg); } @@ -1185,6 +1192,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) } if (PL_in_eval) { PL_restartop = die_where(message, msglen); + SvFLAGS(ERRSV) |= utf8; JMPENV_JUMP(3); } else if (!message) @@ -1245,8 +1253,10 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) CV *cv; SV *msv; STRLEN msglen; + I32 utf8 = 0; msv = vmess(pat, args); + utf8 = SvUTF8(msv); message = SvPV(msv, msglen); if (PL_warnhook) { @@ -1264,6 +1274,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) ENTER; save_re_context(); msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; SvREADONLY_on(msg); SAVEFREESV(msg); @@ -1342,9 +1353,11 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) CV *cv; SV *msv; STRLEN msglen; + I32 utf8 = 0; msv = vmess(pat, args); message = SvPV(msv, msglen); + utf8 = SvUTF8(msv); if (ckDEAD(err)) { if (PL_diehook) { @@ -1362,6 +1375,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) ENTER; save_re_context(); msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; SvREADONLY_on(msg); SAVEFREESV(msg); @@ -1376,6 +1390,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } if (PL_in_eval) { PL_restartop = die_where(message, msglen); + SvFLAGS(ERRSV) |= utf8; JMPENV_JUMP(3); } write_to_stderr(message, msglen); @@ -1397,6 +1412,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) ENTER; save_re_context(); msg = newSVpvn(message, msglen); + SvFLAGS(msg) |= utf8; SvREADONLY_on(msg); SAVEFREESV(msg); @@ -1516,6 +1532,7 @@ Perl_my_setenv(pTHX_ char *nam,char *val) #endif /* WIN32 || NETWARE */ +#ifndef PERL_MICRO I32 Perl_setenv_getix(pTHX_ char *nam) { @@ -1533,6 +1550,7 @@ Perl_setenv_getix(pTHX_ char *nam) } /* potential SEGV's */ return i; } +#endif /* !PERL_MICRO */ #endif /* !VMS && !EPOC*/ @@ -3634,85 +3652,6 @@ Perl_getcwd_sv(pTHX_ register SV *sv) } /* -=head1 SV Manipulation Functions - -=for apidoc scan_vstring - -Returns a pointer to the next character after the parsed -vstring, as well as updating the passed in sv. - -Function must be called like - - sv = NEWSV(92,5); - s = scan_vstring(s,sv); - -The sv should already be large enough to store the vstring -passed in, for performance reasons. - -=cut -*/ - -char * -Perl_scan_vstring(pTHX_ char *s, SV *sv) -{ - char *pos = s; - char *start = s; - if (*pos == 'v') pos++; /* get past 'v' */ - while (isDIGIT(*pos) || *pos == '_') - pos++; - if (!isALPHA(*pos)) { - UV rev; - U8 tmpbuf[UTF8_MAXLEN+1]; - U8 *tmpend; - - if (*s == 'v') s++; /* get past 'v' */ - - sv_setpvn(sv, "", 0); - - for (;;) { - rev = 0; - { - /* this is atoi() that tolerates underscores */ - char *end = pos; - UV mult = 1; - while (--end >= s) { - UV orev; - if (*end == '_') - continue; - orev = rev; - rev += (*end - '0') * mult; - mult *= 10; - if (orev > rev && ckWARN_d(WARN_OVERFLOW)) - Perl_warner(aTHX_ packWARN(WARN_OVERFLOW), - "Integer overflow in decimal number"); - } - } -#ifdef EBCDIC - if (rev > 0x7FFFFFFF) - Perl_croak(aTHX_ "In EBCDIC the v-string components cannot exceed 2147483647"); -#endif - /* Append native character for the rev point */ - tmpend = uvchr_to_utf8(tmpbuf, rev); - sv_catpvn(sv, (const char*)tmpbuf, tmpend - tmpbuf); - if (!UNI_IS_INVARIANT(NATIVE_TO_UNI(rev))) - SvUTF8_on(sv); - if (*pos == '.' && isDIGIT(pos[1])) - s = ++pos; - else { - s = pos; - break; - } - while (isDIGIT(*pos) || *pos == '_') - pos++; - } - SvPOK_on(sv); - sv_magic(sv,NULL,PERL_MAGIC_vstring,(const char*)start, pos-start); - SvRMAGICAL_on(sv); - } - return s; -} - -/* =for apidoc scan_version Returns a pointer to the next character after the parsed @@ -4456,3 +4395,35 @@ Perl_seed(pTHX) return u; } +UV +Perl_get_hash_seed(pTHX) +{ + char *s = PerlEnv_getenv("PERL_HASH_SEED"); + UV myseed = 0; + + if (s) + while (isSPACE(*s)) s++; + if (s && isDIGIT(*s)) + myseed = (UV)Atoul(s); + else +#ifdef USE_HASH_SEED_EXPLICIT + if (s) +#endif + { + /* Compute a random seed */ + (void)seedDrand01((Rand_seed_t)seed()); + PL_srand_called = TRUE; + myseed = (UV)(Drand01() * (NV)UV_MAX); +#if RANDBITS < (UVSIZE * 8) + /* Since there are not enough randbits to to reach all + * the bits of a UV, the low bits might need extra + * help. Sum in another random number that will + * fill in the low bits. */ + myseed += + (UV)(Drand01() * (NV)((1 << ((UVSIZE * 8 - RANDBITS))) - 1)); +#endif /* RANDBITS < (UVSIZE * 8) */ + } + PL_hash_seed_set = TRUE; + + return myseed; +}