X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=cf1dee0a0a3dd6d6815faf20089676fc361b0c6d;hb=c721372142d4c809beb9dbba1d6d9e8702004478;hp=b72a8f2fefada9f2efd2a5561b922ae9cbf3bb0e;hpb=cae6d0e5ad55f3d6c7902bf7cfc560481e827bb3;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index b72a8f2..cf1dee0 100644 --- a/util.c +++ b/util.c @@ -26,17 +26,6 @@ #endif #endif -#ifdef I_VFORK -# include -#endif - -/* Put this after #includes because fork and vfork prototypes may - conflict. -*/ -#ifndef HAS_VFORK -# define vfork fork -#endif - #ifdef I_SYS_WAIT # include #endif @@ -515,7 +504,7 @@ Perl_fbm_compile(pTHX_ SV *sv, U32 flags) sv_catpvn(sv, "\n", 1); /* Taken into account in fbm_instr() */ s = (U8*)SvPV_force(sv, len); (void)SvUPGRADE(sv, SVt_PVBM); - if (len == 0) /* TAIL might be on on a zero-length string. */ + if (len == 0) /* TAIL might be on a zero-length string. */ return; if (len > 2) { U8 mlen; @@ -1003,17 +992,60 @@ Perl_mess(pTHX_ const char *pat, ...) return retval; } +STATIC COP* +S_closest_cop(pTHX_ COP *cop, OP *o) +{ + /* Look for PL_op starting from o. cop is the last COP we've seen. */ + + if (!o || o == PL_op) return cop; + + if (o->op_flags & OPf_KIDS) { + OP *kid; + for (kid = cUNOPo->op_first; kid; kid = kid->op_sibling) + { + COP *new_cop; + + /* If the OP_NEXTSTATE has been optimised away we can still use it + * the get the file and line number. */ + + if (kid->op_type == OP_NULL && kid->op_targ == OP_NEXTSTATE) + cop = (COP *)kid; + + /* Keep searching, and return when we've found something. */ + + new_cop = closest_cop(cop, kid); + if (new_cop) return new_cop; + } + } + + /* Nothing found. */ + + return 0; +} + SV * Perl_vmess(pTHX_ const char *pat, va_list *args) { SV *sv = mess_alloc(); static char dgd[] = " during global destruction.\n"; + COP *cop; sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { - if (CopLINE(PL_curcop)) + + /* + * Try and find the file and line for PL_op. This will usually be + * PL_curcop, but it might be a cop that has been optimised away. We + * can try to find such a cop by searching through the optree starting + * from the sibling of PL_curcop. + */ + + cop = closest_cop(PL_curcop, PL_curcop->op_sibling); + if (!cop) cop = PL_curcop; + + if (CopLINE(cop)) Perl_sv_catpvf(aTHX_ sv, " at %s line %"IVdf, - CopFILE(PL_curcop), (IV)CopLINE(PL_curcop)); + CopFILE(cop), (IV)CopLINE(cop)); if (GvIO(PL_last_in_gv) && IoLINES(GvIOp(PL_last_in_gv))) { bool line_mode = (RsSIMPLE(PL_rs) && SvCUR(PL_rs) == 1 && *SvPVX(PL_rs) == '\n'); @@ -1022,7 +1054,7 @@ Perl_vmess(pTHX_ const char *pat, va_list *args) line_mode ? "line" : "chunk", (IV)IoLINES(GvIOp(PL_last_in_gv))); } -#ifdef USE_THREADS +#ifdef USE_5005THREADS if (thr->tid) Perl_sv_catpvf(aTHX_ sv, " thread %ld", thr->tid); #endif @@ -1195,6 +1227,9 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) PL_restartop = die_where(message, msglen); JMPENV_JUMP(3); } + else if (!message) + message = SvPVx(ERRSV, msglen); + { #ifdef USE_SFIO /* SFIO can really mess with your errno */ @@ -1202,7 +1237,7 @@ Perl_vcroak(pTHX_ const char* pat, va_list *args) #endif PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); #ifdef USE_SFIO errno = e; @@ -1295,7 +1330,7 @@ Perl_vwarn(pTHX_ const char* pat, va_list *args) { PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); #ifdef LEAKTEST DEBUG_L(*message == '!' ? (xstat(message[1]=='!' @@ -1374,9 +1409,9 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) message = SvPV(msv, msglen); if (ckDEAD(err)) { -#ifdef USE_THREADS +#ifdef USE_5005THREADS DEBUG_S(PerlIO_printf(Perl_debug_log, "croak: 0x%"UVxf" %s", PTR2UV(thr), message)); -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ if (PL_diehook) { /* sv_2cv might call Perl_croak() */ SV *olddiehook = PL_diehook; @@ -1410,7 +1445,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } { PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); (void)PerlIO_flush(serr); } my_failure_exit(); @@ -1447,7 +1482,7 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } { PerlIO *serr = Perl_error_log; - PerlIO_write(serr, message, msglen); + PERL_WRITE_MSG_TO_CONSOLE(serr, message, msglen); #ifdef LEAKTEST DEBUG_L(*message == '!' ? (xstat(message[1]=='!' @@ -1461,6 +1496,16 @@ Perl_vwarner(pTHX_ U32 err, const char* pat, va_list* args) } } +/* since we've already done strlen() for both nam and val + * we can use that info to make things faster than + * sprintf(s, "%s=%s", nam, val) + */ +#define my_setenv_format(s, nam, nlen, val, vlen) \ + Copy(nam, s, nlen, char); \ + *(s+nlen) = '='; \ + Copy(val, s+(nlen+1), vlen, char); \ + *(s+(nlen+1+vlen)) = '\0' + #ifdef USE_ENVIRON_ARRAY /* VMS' and EPOC's my_setenv() is in vms.c and epoc.c */ #if !defined(WIN32) && !defined(NETWARE) @@ -1470,6 +1515,7 @@ Perl_my_setenv(pTHX_ char *nam, char *val) #ifndef PERL_USE_SAFE_PUTENV /* most putenv()s leak, so we manipulate environ directly */ register I32 i=setenv_getix(nam); /* where does it go? */ + int nlen, vlen; if (environ == PL_origenviron) { /* need we copy environment? */ I32 j; @@ -1480,8 +1526,9 @@ Perl_my_setenv(pTHX_ char *nam, char *val) for (max = i; environ[max]; max++) ; tmpenv = (char**)safesysmalloc((max+2) * sizeof(char*)); for (j=0; j= 0) did_pipes = 1; - while ((pid = vfork()) < 0) { + while ((pid = PerlProc_fork()) < 0) { if (errno != EAGAIN) { PerlLIO_close(p[This]); if (did_pipes) { @@ -1867,7 +1923,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) #undef THAT } /* Parent */ - do_execfree(); /* free any memory malloced by child on vfork */ + do_execfree(); /* free any memory malloced by child on fork */ /* Close child's end of pipe */ PerlLIO_close(p[that]); if (did_pipes) @@ -1901,6 +1957,7 @@ Perl_my_popen_list(pTHX_ char *mode, int n, SV **args) did_pipes = 0; if (n) { /* Error */ int pid2, status; + PerlLIO_close(p[This]); if (n != sizeof(int)) Perl_croak(aTHX_ "panic: kid popen errno read"); do { @@ -1948,7 +2005,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) return Nullfp; if (doexec && PerlProc_pipe(pp) >= 0) did_pipes = 1; - while ((pid = (doexec?vfork():fork())) < 0) { + while ((pid = PerlProc_fork()) < 0) { if (errno != EAGAIN) { PerlLIO_close(p[This]); if (did_pipes) { @@ -2001,15 +2058,18 @@ 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))) { + SvREADONLY_off(GvSV(tmpgv)); sv_setiv(GvSV(tmpgv), PerlProc_getpid()); + SvREADONLY_on(GvSV(tmpgv)); + } PL_forkprocess = 0; hv_clear(PL_pidstatus); /* we have no children */ return Nullfp; #undef THIS #undef THAT } - do_execfree(); /* free any memory malloced by child on vfork */ + do_execfree(); /* free any memory malloced by child on fork */ PerlLIO_close(p[that]); if (did_pipes) PerlLIO_close(pp[1]); @@ -2040,6 +2100,7 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) did_pipes = 0; if (n) { /* Error */ int pid2, status; + PerlLIO_close(p[This]); if (n != sizeof(int)) Perl_croak(aTHX_ "panic: kid popen errno read"); do { @@ -2084,6 +2145,54 @@ Perl_my_popen(pTHX_ char *cmd, char *mode) #endif /* !DOSISH */ +/* this is called in parent before the fork() */ +void +Perl_atfork_lock(void) +{ +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) + /* locks must be held in locking order (if any) */ +# ifdef MYMALLOC + MUTEX_LOCK(&PL_malloc_mutex); +# endif + OP_REFCNT_LOCK; +#endif +} + +/* this is called in both parent and child after the fork() */ +void +Perl_atfork_unlock(void) +{ +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) + /* locks must be released in same order as in atfork_lock() */ +# ifdef MYMALLOC + MUTEX_UNLOCK(&PL_malloc_mutex); +# endif + OP_REFCNT_UNLOCK; +#endif +} + +Pid_t +Perl_my_fork(void) +{ +#if defined(HAS_FORK) + Pid_t pid; +#if (defined(USE_5005THREADS) || defined(USE_ITHREADS)) && !defined(HAS_PTHREAD_ATFORK) + atfork_lock(); + pid = fork(); + atfork_unlock(); +#else + /* atfork_lock() and atfork_unlock() are installed as pthread_atfork() + * handlers elsewhere in the code */ + pid = fork(); +#endif + return pid; +#else + /* this "canna happen" since nothing should be calling here if !HAS_FORK */ + Perl_croak_nocontext("fork() not available"); + return 0; +#endif /* HAS_FORK */ +} + #ifdef DUMP_FDS void Perl_dump_fds(pTHX_ char *s) @@ -2205,7 +2314,8 @@ Perl_rsignal(pTHX_ int signo, Sighandler_t handler) return PerlProc_signal(signo, handler); } -static int sig_trapped; +static int sig_trapped; /* XXX signals are process-wide anyway, so we + ignore the implications of this for threading */ static Signal_t @@ -2481,7 +2591,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f char *xfailed = Nullch; char tmpbuf[MAXPATHLEN]; register char *s; - I32 len; + I32 len = 0; int retval; #if defined(DOSISH) && !defined(OS2) && !defined(atarist) # define SEARCH_EXTS ".bat", ".cmd", NULL @@ -2710,7 +2820,7 @@ Perl_find_script(pTHX_ char *scriptname, bool dosearch, char **search_ext, I32 f void * Perl_get_context(void) { -#if defined(USE_THREADS) || defined(USE_ITHREADS) +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) # ifdef OLD_PTHREADS_API pthread_addr_t t; if (pthread_getspecific(PL_thr_key, &t)) @@ -2731,7 +2841,7 @@ Perl_get_context(void) void Perl_set_context(void *t) { -#if defined(USE_THREADS) || defined(USE_ITHREADS) +#if defined(USE_5005THREADS) || defined(USE_ITHREADS) # ifdef I_MACH_CTHREADS cthread_set_data(cthread_self(), t); # else @@ -2743,7 +2853,7 @@ Perl_set_context(void *t) #endif /* !PERL_GET_CONTEXT_DEFINED */ -#ifdef USE_THREADS +#ifdef USE_5005THREADS #ifdef FAKE_THREADS /* Very simplistic scheduler for now */ @@ -2957,6 +3067,8 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_reg_start_tmpl = 0; PL_reg_poscache = Nullch; + PL_peepp = MEMBER_TO_FPTR(Perl_peep); + /* parent thread's data needs to be locked while we make copy */ MUTEX_LOCK(&t->mutex); @@ -2970,8 +3082,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) PL_tainted = t->Ttainted; PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ - PL_nrs = newSVsv(t->Tnrs); - PL_rs = t->Tnrs ? SvREFCNT_inc(PL_nrs) : Nullsv; + PL_rs = newSVsv(t->Trs); PL_last_in_gv = Nullgv; PL_ofs_sv = t->Tofs_sv ? SvREFCNT_inc(PL_ofs_sv) : Nullsv; PL_defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv); @@ -3014,7 +3125,7 @@ Perl_new_struct_thread(pTHX_ struct perl_thread *t) #endif /* HAVE_THREAD_INTERN */ return thr; } -#endif /* USE_THREADS */ +#endif /* USE_5005THREADS */ #ifdef PERL_GLOBAL_STRUCT struct perl_vars * @@ -3135,7 +3246,7 @@ Perl_get_vtbl(pTHX_ int vtbl_id) case want_vtbl_uvar: result = &PL_vtbl_uvar; break; -#ifdef USE_THREADS +#ifdef USE_5005THREADS case want_vtbl_mutex: result = &PL_vtbl_mutex; break; @@ -3637,6 +3748,10 @@ Perl_getcwd_sv(pTHX_ register SV *sv) { #ifndef PERL_MICRO +#ifndef INCOMPLETE_TAINTS + SvTAINTED_on(sv); +#endif + #ifdef HAS_GETCWD { char buf[MAXPATHLEN]; @@ -3774,3 +3889,76 @@ Perl_getcwd_sv(pTHX_ register SV *sv) #endif } +/* +=for apidoc new_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 = new_vstring(s,sv); + +The sv must already be large enough to store the vstring +passed in. + +=cut +*/ + +char * +Perl_new_vstring(pTHX_ char *s, SV *sv) +{ + char *pos = 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; + if ( *(s-1) == '_') { + mult = 10; + } + while (--end >= s) { + UV orev; + orev = rev; + rev += (*end - '0') * mult; + mult *= 10; + if (orev > rev && ckWARN_d(WARN_OVERFLOW)) + Perl_warner(aTHX_ WARN_OVERFLOW, + "Integer overflow in decimal number"); + } + } + /* 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 == '.' || *pos == '_') && isDIGIT(pos[1])) + s = ++pos; + else { + s = pos; + break; + } + while (isDIGIT(*pos) ) + pos++; + } + SvPOK_on(sv); + SvREADONLY_on(sv); + } + return s; +} + +