X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=8d6ecadaa8b0cfe6ee8a1cd3d2d2247962fd9051;hb=9ec58fb7ec19e41fee2f2944750a45a2a85e4a03;hp=091e162e6999cb9e28679dcc195a33d1113f2e3f;hpb=c44d3fdb45c0c48dcd8af6dc9f4a4166137bf839;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 091e162..8d6ecad 100644 --- a/util.c +++ b/util.c @@ -154,7 +154,9 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) Free_t Perl_safesysfree(Malloc_t where) { +#ifdef PERL_IMPLICIT_SYS dTHX; +#endif DEBUG_m( PerlIO_printf(Perl_debug_log, "0x%"UVxf": (%05ld) free\n",PTR2UV(where),(long)PL_an++)); if (where) { /*SUPPRESS 701*/ @@ -699,8 +701,8 @@ Perl_init_i18nl10n(pTHX_ int printwarn) if (setlocale_failure) { char *p; bool locwarn = (printwarn > 1 || - printwarn && - (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p))); + (printwarn && + (!(p = PerlEnv_getenv("PERL_BADLANG")) || atoi(p)))); if (locwarn) { #ifdef LC_ALL @@ -995,17 +997,15 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit register I32 multiline = flags & FBMrf_MULTILINE; if (bigend - big < littlelen) { - check_tail: if ( SvTAIL(littlestr) && (bigend - big == littlelen - 1) && (littlelen == 1 - || *big == *little && memEQ(big, little, littlelen - 1))) + || (*big == *little && memEQ(big, little, littlelen - 1)))) return (char*)big; return Nullch; } if (littlelen <= 2) { /* Special-cased */ - register char c; if (littlelen == 1) { if (SvTAIL(littlestr) && !multiline) { /* Anchor only! */ @@ -1157,7 +1157,6 @@ Perl_fbm_instr(pTHX_ unsigned char *big, register unsigned char *bigend, SV *lit while (tmp--) { if (*--s == *--little) continue; - differ: s = olds + 1; /* here we pay the price for failure */ little = oldlittle; if (s < bigend) /* fake up continue to outer loop */ @@ -1516,6 +1515,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) SV *msg; ENTER; + save_re_context(); if (message) { msg = newSVpvn(message, msglen); SvREADONLY_on(msg); @@ -1605,6 +1605,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) SV *msg; ENTER; + save_re_context(); msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); @@ -1698,6 +1699,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) SV *msg; ENTER; + save_re_context(); msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); @@ -1811,15 +1813,17 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) SV *msg; ENTER; + save_re_context(); msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); + PUSHSTACKi(PERLSI_DIEHOOK); PUSHMARK(sp); XPUSHs(msg); PUTBACK; call_sv((SV*)cv, G_DISCARD); - + POPSTACK; LEAVE; } } @@ -1844,21 +1848,23 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) SAVESPTR(PL_warnhook); PL_warnhook = Nullsv; cv = sv_2cv(oldwarnhook, &stash, &gv, 0); - LEAVE; + LEAVE; if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { dSP; SV *msg; ENTER; + save_re_context(); msg = newSVpvn(message, msglen); SvREADONLY_on(msg); SAVEFREESV(msg); + PUSHSTACKi(PERLSI_WARNHOOK); PUSHMARK(sp); XPUSHs(msg); PUTBACK; call_sv((SV*)cv, G_DISCARD); - + POPSTACK; LEAVE; return; } @@ -2356,7 +2362,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) } #endif /* defined OS2 */ /*SUPPRESS 560*/ - if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV)) + if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) sv_setiv(GvSV(tmpgv), PerlProc_getpid()); PL_forkprocess = 0; hv_clear(PL_pidstatus); /* we have no children */ @@ -2651,7 +2657,7 @@ Perl_wait4pid(pTHX_ Pid_t pid, int *statusp, int flags) HE *entry; hv_iterinit(PL_pidstatus); - if (entry = hv_iternext(PL_pidstatus)) { + if ((entry = hv_iternext(PL_pidstatus))) { pid = atoi(hv_iterkey(entry,(I32*)statusp)); sv = hv_iterval(PL_pidstatus,entry); *statusp = SvIVX(sv); @@ -2871,9 +2877,13 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) for (; len-- && *s; s++) { if (!(*s == '0' || *s == '1')) { - if (*s == '_') - continue; /* Note: does not check for __ and the like. */ - if (seenb == FALSE && *s == 'b' && ruv == 0) { + if (*s == '_' && len && *retlen + && (s[1] == '0' || s[1] == '1')) + { + --len; + ++s; + } + else if (seenb == FALSE && *s == 'b' && ruv == 0) { /* Disallow 0bbb0b0bbb... */ seenb = TRUE; continue; @@ -2896,7 +2906,8 @@ Perl_scan_bin(pTHX_ char *start, I32 len, I32 *retlen) if (ckWARN_d(WARN_OVERFLOW)) Perl_warner(aTHX_ WARN_OVERFLOW, "Integer overflow in binary number"); - } else + } + else ruv = xuv | (*s - '0'); } if (overflowed) { @@ -2936,8 +2947,12 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) for (; len-- && *s; s++) { if (!(*s >= '0' && *s <= '7')) { - if (*s == '_') - continue; /* Note: does not check for __ and the like. */ + if (*s == '_' && len && *retlen + && (s[1] >= '0' && s[1] <= '7')) + { + --len; + ++s; + } else { /* Allow \octal to work the DWIM way (that is, stop scanning * as soon as non-octal characters are seen, complain only iff @@ -2961,7 +2976,8 @@ Perl_scan_oct(pTHX_ char *start, I32 len, I32 *retlen) if (ckWARN_d(WARN_OVERFLOW)) Perl_warner(aTHX_ WARN_OVERFLOW, "Integer overflow in octal number"); - } else + } + else ruv = xuv | (*s - '0'); } if (overflowed) { @@ -3004,9 +3020,13 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) for (; len-- && *s; s++) { hexdigit = strchr((char *) PL_hexdigit, *s); if (!hexdigit) { - if (*s == '_') - continue; /* Note: does not check for __ and the like. */ - if (seenx == FALSE && *s == 'x' && ruv == 0) { + if (*s == '_' && len && *retlen && s[1] + && (hexdigit = strchr((char *) PL_hexdigit, s[1]))) + { + --len; + ++s; + } + else if (seenx == FALSE && *s == 'x' && ruv == 0) { /* Disallow 0xxx0x0xxx... */ seenx = TRUE; continue; @@ -3029,7 +3049,8 @@ Perl_scan_hex(pTHX_ char *start, I32 len, I32 *retlen) if (ckWARN_d(WARN_OVERFLOW)) Perl_warner(aTHX_ WARN_OVERFLOW, "Integer overflow in hexadecimal number"); - } else + } + else ruv = xuv | ((hexdigit - PL_hexdigit) & 15); } if (overflowed) { @@ -3571,7 +3592,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) } #endif /* USE_THREADS */ -#ifdef HUGE_VAL +#if defined(HUGE_VAL) || (defined(USE_LONG_DOUBLE) && defined(HUGE_VALL)) /* * This hack is to force load of "huge" support from libm.a * So it is in perl for (say) POSIX to use. @@ -3580,7 +3601,10 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) NV Perl_huge(void) { - return HUGE_VAL; +# if defined(USE_LONG_DOUBLE) && defined(HUGE_VALL) + return HUGE_VALL; +# endif + return HUGE_VAL; } #endif @@ -3818,6 +3842,6 @@ Perl_report_closed_fh(pTHX_ GV *gv, IO *io, const char *func, const char *obj) if (io && IoDIRP(io)) Perl_warner(aTHX_ WARN_CLOSED, - "(Are you trying to call %s() on dirhandle %s?)\n", + "\t(Are you trying to call %s() on dirhandle %s?)\n", func, name); }