X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=2dfbfaaaf813c1f5dbbbc88e07619c97c885d46d;hb=976cc4b324252da88ff069ecdaa817a11ac6364f;hp=031922a9f9883ac8aa792fae368cc43b2a62955f;hpb=cb50131aab68ac6dda048612c6e853b8cb08701e;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index 031922a9..2dfbfaa 100644 --- a/util.c +++ b/util.c @@ -40,13 +40,6 @@ # define vfork fork #endif -#ifdef I_FCNTL -# include -#endif -#ifdef I_SYS_FILE -# include -#endif - #ifdef I_SYS_WAIT # include #endif @@ -116,7 +109,7 @@ Perl_safesysrealloc(Malloc_t where,MEM_SIZE size) { dTHX; Malloc_t ptr; -#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) +#if !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) && !defined(PERL_MICRO) Malloc_t PerlMem_realloc(); #endif /* !defined(STANDARD_C) && !defined(HAS_REALLOC_PROTOTYPE) */ @@ -161,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*/ @@ -706,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 @@ -1002,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! */ @@ -1164,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 */ @@ -1504,6 +1496,7 @@ Perl_vdie(pTHX_ const char* pat, va_list *args) } else { message = Nullch; + msglen = 0; } DEBUG_S(PerlIO_printf(Perl_debug_log, @@ -1522,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); @@ -1611,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); @@ -1704,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); @@ -1817,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; } } @@ -1850,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; } @@ -2362,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 */ @@ -2657,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); @@ -2877,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; @@ -2902,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) { @@ -2942,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 @@ -2967,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) { @@ -3010,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; @@ -3035,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) { @@ -3297,8 +3312,46 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f return (scriptname ? savepv(scriptname) : Nullch); } +#ifndef PERL_GET_CONTEXT_DEFINED + +void * +Perl_get_context(void) +{ +#if defined(USE_THREADS) || defined(USE_ITHREADS) +# ifdef OLD_PTHREADS_API + pthread_addr_t t; + if (pthread_getspecific(PL_thr_key, &t)) + Perl_croak_nocontext("panic: pthread_getspecific"); + return (void*)t; +# else +# ifdef I_MACH_CTHREADS + return (void*)cthread_data(cthread_self()); +# else + return (void*)pthread_getspecific(PL_thr_key); +# endif +# endif +#else + return (void*)NULL; +#endif +} + +void +Perl_set_context(void *t) +{ +#if defined(USE_THREADS) || defined(USE_ITHREADS) +# ifdef I_MACH_CTHREADS + cthread_set_data(cthread_self(), t); +# else + if (pthread_setspecific(PL_thr_key, t)) + Perl_croak_nocontext("panic: pthread_setspecific"); +# endif +#endif +} + +#endif /* !PERL_GET_CONTEXT_DEFINED */ #ifdef USE_THREADS + #ifdef FAKE_THREADS /* Very simplistic scheduler for now */ void @@ -3373,18 +3426,6 @@ Perl_cond_wait(pTHX_ perl_cond *cp) } #endif /* FAKE_THREADS */ -#ifdef PTHREAD_GETSPECIFIC_INT -struct perl_thread * -Perl_getTHR(pTHX) -{ - pthread_addr_t t; - - if (pthread_getspecific(PL_thr_key, &t)) - Perl_croak(aTHX_ "panic: pthread_getspecific"); - return (struct perl_thread *) t; -} -#endif - MAGIC * Perl_condpair_magic(pTHX_ SV *sv) { @@ -3494,7 +3535,9 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) /* parent thread's data needs to be locked while we make copy */ MUTEX_LOCK(&t->mutex); +#ifdef PERL_FLEXIBLE_EXCEPTIONS PL_protect = t->Tprotect; +#endif PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */ PL_defstash = t->Tdefstash; /* XXX maybe these should */ @@ -3796,6 +3839,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); }