X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=util.c;h=77dd842f426fccc1fe3a667d8c71d35385fe7be8;hb=4651cd973dc1927af3b5d1c108970bc03fc01bb1;hp=b98965bed4f009412d9d2701a76ddefcb68dd67e;hpb=a0ed51b321531af4b47cce24205ab9656f043f0f;p=p5sagit%2Fp5-mst-13.2.git diff --git a/util.c b/util.c index b98965b..77dd842 100644 --- a/util.c +++ b/util.c @@ -97,7 +97,7 @@ safemalloc(MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; + PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH; my_exit(1); return Nullch; } @@ -151,7 +151,7 @@ saferealloc(Malloc_t where,MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; + PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH; my_exit(1); return Nullch; } @@ -206,7 +206,7 @@ safecalloc(MEM_SIZE count, MEM_SIZE size) else if (PL_nomemok) return Nullch; else { - PerlIO_puts(PerlIO_stderr(),no_mem) FLUSH; + PerlIO_puts(PerlIO_stderr(),PL_no_mem) FLUSH; my_exit(1); return Nullch; } @@ -486,11 +486,11 @@ perl_new_ctype(char *newctype) for (i = 0; i < 256; i++) { if (isUPPER_LC(i)) - fold_locale[i] = toLOWER_LC(i); + PL_fold_locale[i] = toLOWER_LC(i); else if (isLOWER_LC(i)) - fold_locale[i] = toUPPER_LC(i); + PL_fold_locale[i] = toUPPER_LC(i); else - fold_locale[i] = i; + PL_fold_locale[i] = i; } #endif /* USE_LOCALE_CTYPE */ @@ -621,6 +621,9 @@ perl_init_i18nl10n(int printwarn) #ifdef USE_LOCALE_NUMERIC char *curnum = NULL; #endif /* USE_LOCALE_NUMERIC */ +#ifdef __GLIBC__ + char *language = PerlEnv_getenv("LANGUAGE"); +#endif char *lc_all = PerlEnv_getenv("LC_ALL"); char *lang = PerlEnv_getenv("LANG"); bool setlocale_failure = FALSE; @@ -641,65 +644,53 @@ perl_init_i18nl10n(int printwarn) else setlocale_failure = TRUE; } - if (!setlocale_failure) -#endif /* LC_ALL */ - { + if (!setlocale_failure) { #ifdef USE_LOCALE_CTYPE - if (! (curctype = setlocale(LC_CTYPE, - (!done && (lang || PerlEnv_getenv("LC_CTYPE"))) + if (! (curctype = + setlocale(LC_CTYPE, + (!done && (lang || PerlEnv_getenv("LC_CTYPE"))) ? "" : Nullch))) setlocale_failure = TRUE; #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE - if (! (curcoll = setlocale(LC_COLLATE, - (!done && (lang || PerlEnv_getenv("LC_COLLATE"))) + if (! (curcoll = + setlocale(LC_COLLATE, + (!done && (lang || PerlEnv_getenv("LC_COLLATE"))) ? "" : Nullch))) setlocale_failure = TRUE; #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC - if (! (curnum = setlocale(LC_NUMERIC, - (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) + if (! (curnum = + setlocale(LC_NUMERIC, + (!done && (lang || PerlEnv_getenv("LC_NUMERIC"))) ? "" : Nullch))) setlocale_failure = TRUE; #endif /* USE_LOCALE_NUMERIC */ } -#else /* !LOCALE_ENVIRON_REQUIRED */ +#endif /* LC_ALL */ -#ifdef LC_ALL +#endif /* !LOCALE_ENVIRON_REQUIRED */ +#ifdef LC_ALL if (! setlocale(LC_ALL, "")) setlocale_failure = TRUE; - else { -#ifdef USE_LOCALE_CTYPE - curctype = setlocale(LC_CTYPE, Nullch); -#endif /* USE_LOCALE_CTYPE */ -#ifdef USE_LOCALE_COLLATE - curcoll = setlocale(LC_COLLATE, Nullch); -#endif /* USE_LOCALE_COLLATE */ -#ifdef USE_LOCALE_NUMERIC - curnum = setlocale(LC_NUMERIC, Nullch); -#endif /* USE_LOCALE_NUMERIC */ - } - -#else /* !LC_ALL */ +#endif /* LC_ALL */ + if (!setlocale_failure) { #ifdef USE_LOCALE_CTYPE - if (! (curctype = setlocale(LC_CTYPE, ""))) - setlocale_failure = TRUE; + if (! (curctype = setlocale(LC_CTYPE, ""))) + setlocale_failure = TRUE; #endif /* USE_LOCALE_CTYPE */ #ifdef USE_LOCALE_COLLATE - if (! (curcoll = setlocale(LC_COLLATE, ""))) - setlocale_failure = TRUE; + if (! (curcoll = setlocale(LC_COLLATE, ""))) + setlocale_failure = TRUE; #endif /* USE_LOCALE_COLLATE */ #ifdef USE_LOCALE_NUMERIC - if (! (curnum = setlocale(LC_NUMERIC, ""))) - setlocale_failure = TRUE; + if (! (curnum = setlocale(LC_NUMERIC, ""))) + setlocale_failure = TRUE; #endif /* USE_LOCALE_NUMERIC */ - -#endif /* LC_ALL */ - -#endif /* !LOCALE_ENVIRON_REQUIRED */ + } if (setlocale_failure) { char *p; @@ -736,6 +727,14 @@ perl_init_i18nl10n(int printwarn) PerlIO_printf(PerlIO_stderr(), "perl: warning: Please check that your locale settings:\n"); +#ifdef __GLIBC__ + PerlIO_printf(PerlIO_stderr(), + "\tLANGUAGE = %c%s%c,\n", + language ? '"' : '(', + language ? language : "unset", + language ? '"' : ')'); +#endif + PerlIO_printf(PerlIO_stderr(), "\tLC_ALL = %c%s%c,\n", lc_all ? '"' : '(', @@ -897,14 +896,15 @@ mem_collxfrm(const char *s, STRLEN len, STRLEN *xlen) void fbm_compile(SV *sv, U32 flags /* not used yet */) { - register unsigned char *s; - register unsigned char *table; + register U8 *s; + register U8 *table; register U32 i; - register U32 len = SvCUR(sv); + STRLEN len; I32 rarest = 0; U32 frequency = 256; - sv_upgrade(sv, SVt_PVBM); + s = (U8*)SvPV_force(sv, len); + (void)SvUPGRADE(sv, SVt_PVBM); if (len > 255 || len == 0) /* TAIL might be on on a zero-length string. */ return; /* can't have offsets that big */ if (len > 2) { @@ -927,9 +927,9 @@ fbm_compile(SV *sv, U32 flags /* not used yet */) s = (unsigned char*)(SvPVX(sv)); /* deeper magic */ for (i = 0; i < len; i++) { - if (freq[s[i]] < frequency) { + if (PL_freq[s[i]] < frequency) { rarest = i; - frequency = freq[s[i]]; + frequency = PL_freq[s[i]]; } } BmRARE(sv) = s[rarest]; @@ -1136,7 +1136,7 @@ ibcmp(char *s1, char *s2, register I32 len) register U8 *a = (U8 *)s1; register U8 *b = (U8 *)s2; while (len--) { - if (*a != *b && *a != fold[*b]) + if (*a != *b && *a != PL_fold[*b]) return 1; a++,b++; } @@ -1149,7 +1149,7 @@ ibcmp_locale(char *s1, char *s2, register I32 len) register U8 *a = (U8 *)s1; register U8 *b = (U8 *)s2; while (len--) { - if (*a != *b && *a != fold_locale[*b]) + if (*a != *b && *a != PL_fold_locale[*b]) return 1; a++,b++; } @@ -1186,39 +1186,43 @@ savepvn(char *sv, register I32 len) STATIC SV * mess_alloc(void) { + dTHR; SV *sv; XPVMG *any; + if (!PL_dirty) + return sv_2mortal(newSVpvn("",0)); + + if (PL_mess_sv) + return PL_mess_sv; + /* Create as PVMG now, to avoid any upgrading later */ New(905, sv, 1, SV); Newz(905, any, 1, XPVMG); SvFLAGS(sv) = SVt_PVMG; SvANY(sv) = (void*)any; SvREFCNT(sv) = 1 << 30; /* practically infinite */ + PL_mess_sv = sv; return sv; } char * form(const char* pat, ...) { + SV *sv = mess_alloc(); va_list args; va_start(args, pat); - if (!PL_mess_sv) - PL_mess_sv = mess_alloc(); - sv_vsetpvfn(PL_mess_sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); + sv_vsetpvfn(sv, pat, strlen(pat), &args, Null(SV**), 0, Null(bool*)); va_end(args); - return SvPVX(PL_mess_sv); + return SvPVX(sv); } char * mess(const char *pat, va_list *args) { - SV *sv; + SV *sv = mess_alloc(); static char dgd[] = " during global destruction.\n"; - if (!PL_mess_sv) - PL_mess_sv = mess_alloc(); - sv = PL_mess_sv; sv_vsetpvfn(sv, pat, strlen(pat), args, Null(SV**), 0, Null(bool*)); if (!SvCUR(sv) || *(SvEND(sv) - 1) != '\n') { dTHR; @@ -1253,21 +1257,17 @@ die(const char* pat, ...) GV *gv; CV *cv; -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: die: curstack = %p, mainstack = %p\n", thr, PL_curstack, PL_mainstack)); -#endif /* USE_THREADS */ va_start(args, pat); message = pat ? mess(pat, &args) : Nullch; va_end(args); -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: die: message = %s\ndiehook = %p\n", thr, message, PL_diehook)); -#endif /* USE_THREADS */ if (PL_diehook) { /* sv_2cv might call croak() */ SV *olddiehook = PL_diehook; @@ -1301,11 +1301,9 @@ die(const char* pat, ...) } PL_restartop = die_where(message); -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "%p: die: restartop = %p, was_in_eval = %d, top_env = %p\n", thr, PL_restartop, was_in_eval, PL_top_env)); -#endif /* USE_THREADS */ if ((!PL_restartop && was_in_eval) || PL_top_env->je_prev) JMPENV_JUMP(3); return PL_restartop; @@ -1324,9 +1322,7 @@ croak(const char* pat, ...) va_start(args, pat); message = mess(pat, &args); va_end(args); -#ifdef USE_THREADS - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); -#endif /* USE_THREADS */ + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); if (PL_diehook) { /* sv_2cv might call croak() */ SV *olddiehook = PL_diehook; @@ -1415,6 +1411,94 @@ warn(const char* pat,...) (void)PerlIO_flush(PerlIO_stderr()); } +void +warner(U32 err, const char* pat,...) +{ + dTHR; + va_list args; + char *message; + HV *stash; + GV *gv; + CV *cv; + + va_start(args, pat); + message = mess(pat, &args); + va_end(args); + + if (ckDEAD(err)) { +#ifdef USE_THREADS + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "croak: 0x%lx %s", (unsigned long) thr, message)); +#endif /* USE_THREADS */ + if (PL_diehook) { + /* sv_2cv might call croak() */ + SV *olddiehook = PL_diehook; + ENTER; + SAVESPTR(PL_diehook); + PL_diehook = Nullsv; + cv = sv_2cv(olddiehook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; + + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); + + PUSHMARK(sp); + XPUSHs(msg); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + + LEAVE; + } + } + if (PL_in_eval) { + PL_restartop = die_where(message); + JMPENV_JUMP(3); + } + PerlIO_puts(PerlIO_stderr(),message); + (void)PerlIO_flush(PerlIO_stderr()); + my_failure_exit(); + + } + else { + if (PL_warnhook) { + /* sv_2cv might call warn() */ + dTHR; + SV *oldwarnhook = PL_warnhook; + ENTER; + SAVESPTR(PL_warnhook); + PL_warnhook = Nullsv; + cv = sv_2cv(oldwarnhook, &stash, &gv, 0); + LEAVE; + if (cv && !CvDEPTH(cv) && (CvROOT(cv) || CvXSUB(cv))) { + dSP; + SV *msg; + + ENTER; + msg = newSVpv(message, 0); + SvREADONLY_on(msg); + SAVEFREESV(msg); + + PUSHMARK(sp); + XPUSHs(msg); + PUTBACK; + perl_call_sv((SV*)cv, G_DISCARD); + + LEAVE; + return; + } + } + PerlIO_puts(PerlIO_stderr(),message); +#ifdef LEAKTEST + DEBUG_L(xstat()); +#endif + (void)PerlIO_flush(PerlIO_stderr()); + } +} + #ifndef VMS /* VMS' my_setenv() is in VMS.c */ #ifndef WIN32 void @@ -1797,7 +1881,7 @@ VTOH(vtohl,long) #endif /* VMS' my_popen() is in VMS.c, same with OS/2. */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) PerlIO * my_popen(char *cmd, char *mode) { @@ -2049,7 +2133,7 @@ rsignal_restore(int signo, Sigsave_t *save) #endif /* !HAS_SIGACTION */ /* VMS' my_pclose() is in VMS.c; same with OS/2 */ -#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) +#if (!defined(DOSISH) || defined(HAS_FORK) || defined(AMIGAOS)) && !defined(VMS) && !defined(__OPEN_VM) I32 my_pclose(PerlIO *ptr) { @@ -2206,9 +2290,9 @@ repeatcpy(register char *to, register char *from, I32 len, register I32 count) register char *frombase = from; if (len == 1) { - todo = *from; + register char c = *from; while (count-- > 0) - *to++ = todo; + *to++ = c; return; } while (count-- > 0) { @@ -2219,10 +2303,8 @@ repeatcpy(register char *to, register char *from, I32 len, register I32 count) } } -#ifndef CASTNEGFLOAT U32 -cast_ulong(f) -double f; +cast_ulong(double f) { long along; @@ -2237,9 +2319,6 @@ double f; return (unsigned long)along; } # undef BIGDOUBLE -#endif - -#ifndef CASTI32 /* Unfortunately, on some systems the cast_uv() function doesn't work with the system-supplied definition of ULONG_MAX. The @@ -2262,8 +2341,7 @@ double f; #endif I32 -cast_i32(f) -double f; +cast_i32(double f) { if (f >= I32_MAX) return (I32) I32_MAX; @@ -2273,8 +2351,7 @@ double f; } IV -cast_iv(f) -double f; +cast_iv(double f) { if (f >= IV_MAX) return (IV) IV_MAX; @@ -2284,21 +2361,16 @@ double f; } UV -cast_uv(f) -double f; +cast_uv(double f) { if (f >= MY_UV_MAX) return (UV) MY_UV_MAX; return (UV) f; } -#endif - #ifndef HAS_RENAME I32 -same_dirent(a,b) -char *a; -char *b; +same_dirent(char *a, char *b) { char *fa = strrchr(a,'/'); char *fb = strrchr(b,'/'); @@ -2334,6 +2406,29 @@ char *b; #endif /* !HAS_RENAME */ UV +scan_bin(char *start, I32 len, I32 *retlen) +{ + register char *s = start; + register UV retval = 0; + bool overflowed = FALSE; + while (len && *s >= '0' && *s <= '1') { + register UV n = retval << 1; + if (!overflowed && (n >> 1) != retval) { + warn("Integer overflow in binary number"); + overflowed = TRUE; + } + retval = n | (*s++ - '0'); + len--; + } + if (len && (*s >= '2' || *s <= '9')) { + dTHR; + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE, "Illegal binary digit ignored"); + } + *retlen = s - start; + return retval; +} +UV scan_oct(char *start, I32 len, I32 *retlen) { register char *s = start; @@ -2349,8 +2444,11 @@ scan_oct(char *start, I32 len, I32 *retlen) retval = n | (*s++ - '0'); len--; } - if (PL_dowarn && len && (*s == '8' || *s == '9')) - warn("Illegal octal digit ignored"); + if (len && (*s == '8' || *s == '9')) { + dTHR; + if (ckWARN(WARN_OCTAL)) + warner(WARN_OCTAL, "Illegal octal digit ignored"); + } *retlen = s - start; return retval; } @@ -2367,12 +2465,13 @@ scan_hex(char *start, I32 len, I32 *retlen) while (len-- && *s) { tmp = strchr((char *) PL_hexdigit, *s++); if (!tmp) { - if (*s == '_') + if (*(s-1) == '_' || (*(s-1) == 'x' && retval == 0)) continue; else { + dTHR; --s; - if (PL_dowarn) - warn("Illegal hex digit ignored"); + if (ckWARN(WARN_UNSAFE)) + warner(WARN_UNSAFE,"Illegal hex digit ignored"); break; } } @@ -2393,7 +2492,7 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) dTHR; char *xfound = Nullch; char *xfailed = Nullch; - char tmpbuf[512]; + char tmpbuf[MAXPATHLEN]; register char *s; I32 len; int retval; @@ -2485,7 +2584,8 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",cur)); - if (PerlLIO_stat(cur,&PL_statbuf) >= 0) { + if (PerlLIO_stat(cur,&PL_statbuf) >= 0 + && !S_ISDIR(PL_statbuf.st_mode)) { dosearch = 0; scriptname = cur; #ifdef SEARCH_EXTS @@ -2535,7 +2635,7 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) if (len + 1 + strlen(scriptname) + MAX_EXT_LEN >= sizeof tmpbuf) continue; /* don't search dir with too-long name */ if (len -#if defined(atarist) || defined(DOSISH) +#if defined(atarist) || defined(__MINT__) || defined(DOSISH) && tmpbuf[len - 1] != '/' && tmpbuf[len - 1] != '\\' #endif @@ -2554,6 +2654,9 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) #endif DEBUG_p(PerlIO_printf(Perl_debug_log, "Looking for %s\n",tmpbuf)); retval = PerlLIO_stat(tmpbuf,&PL_statbuf); + if (S_ISDIR(PL_statbuf.st_mode)) { + retval = -1; + } #ifdef SEARCH_EXTS } while ( retval < 0 /* not there */ && extidx>=0 && ext[extidx] /* try an extension? */ @@ -2576,7 +2679,9 @@ find_script(char *scriptname, bool dosearch, char **search_ext, I32 flags) xfailed = savepv(tmpbuf); } #ifndef DOSISH - if (!xfound && !seen_dot && !xfailed && (PerlLIO_stat(scriptname,&PL_statbuf) < 0)) + if (!xfound && !seen_dot && !xfailed && + (PerlLIO_stat(scriptname,&PL_statbuf) < 0 + || S_ISDIR(PL_statbuf.st_mode))) #endif seen_dot = 1; /* Disable message. */ if (!xfound) { @@ -2607,15 +2712,13 @@ schedule(void) } void -perl_cond_init(cp) -perl_cond *cp; +perl_cond_init(perl_cond *cp) { *cp = 0; } void -perl_cond_signal(cp) -perl_cond *cp; +perl_cond_signal(perl_cond *cp) { perl_os_thread t; perl_cond cond = *cp; @@ -2635,8 +2738,7 @@ perl_cond *cp; } void -perl_cond_broadcast(cp) -perl_cond *cp; +perl_cond_broadcast(perl_cond *cp) { perl_os_thread t; perl_cond cond, cond_next; @@ -2657,8 +2759,7 @@ perl_cond *cp; } void -perl_cond_wait(cp) -perl_cond *cp; +perl_cond_wait(perl_cond *cp) { perl_cond cond; @@ -2676,7 +2777,7 @@ perl_cond *cp; } #endif /* FAKE_THREADS */ -#ifdef OLD_PTHREADS_API +#ifdef PTHREAD_GETSPECIFIC_INT struct perl_thread * getTHR _((void)) { @@ -2686,7 +2787,7 @@ getTHR _((void)) croak("panic: pthread_getspecific"); return (struct perl_thread *) t; } -#endif /* OLD_PTHREADS_API */ +#endif MAGIC * condpair_magic(SV *sv) @@ -2719,7 +2820,7 @@ condpair_magic(SV *sv) mg->mg_ptr = (char *)cp; mg->mg_len = sizeof(cp); UNLOCK_SV_MUTEX; - DEBUG_L(WITH_THR(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(WITH_THR(PerlIO_printf(PerlIO_stderr(), "%p: condpair_magic %p\n", thr, sv));) } } @@ -2745,7 +2846,7 @@ new_struct_thread(struct perl_thread *t) SvGROW(sv, sizeof(struct perl_thread) + 1); SvCUR_set(sv, sizeof(struct perl_thread)); thr = (Thread) SvPVX(sv); - /* debug */ +#ifdef DEBUGGING memset(thr, 0xab, sizeof(struct perl_thread)); PL_markstack = 0; PL_scopestack = 0; @@ -2753,7 +2854,10 @@ new_struct_thread(struct perl_thread *t) PL_retstack = 0; PL_dirty = 0; PL_localizing = 0; - /* end debug */ + Zero(&PL_hv_fetch_ent_mh, 1, HE); +#else + Zero(thr, 1, struct perl_thread); +#endif thr->oursv = sv; init_stacks(ARGS); @@ -2767,11 +2871,6 @@ new_struct_thread(struct perl_thread *t) thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); - PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */ - PL_defstash = t->Tdefstash; /* XXX maybe these should */ - PL_curstash = t->Tcurstash; /* always be set to main? */ - - /* top_env needs to be non-zero. It points to an area in which longjmp() stuff is stored, as C callstack info there at least is thread specific this has to @@ -2788,6 +2887,25 @@ new_struct_thread(struct perl_thread *t) PL_in_eval = FALSE; PL_restartop = 0; + PL_statname = NEWSV(66,0); + PL_maxscream = -1; + PL_regcompp = FUNC_NAME_TO_PTR(pregcomp); + PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags); + PL_regindent = 0; + PL_reginterp_cnt = 0; + PL_lastscream = Nullsv; + PL_screamfirst = 0; + PL_screamnext = 0; + PL_reg_start_tmp = 0; + PL_reg_start_tmpl = 0; + + /* parent thread's data needs to be locked while we make copy */ + MUTEX_LOCK(&t->mutex); + + PL_curcop = t->Tcurcop; /* XXX As good a guess as any? */ + PL_defstash = t->Tdefstash; /* XXX maybe these should */ + PL_curstash = t->Tcurstash; /* always be set to main? */ + PL_tainted = t->Ttainted; PL_curpm = t->Tcurpm; /* XXX No PMOP ref count */ PL_nrs = newSVsv(t->Tnrs); @@ -2801,18 +2919,6 @@ new_struct_thread(struct perl_thread *t) PL_bodytarget = newSVsv(t->Tbodytarget); PL_toptarget = newSVsv(t->Ttoptarget); - PL_statname = NEWSV(66,0); - PL_maxscream = -1; - PL_regcompp = FUNC_NAME_TO_PTR(pregcomp); - PL_regexecp = FUNC_NAME_TO_PTR(regexec_flags); - PL_regindent = 0; - PL_reginterp_cnt = 0; - PL_lastscream = Nullsv; - PL_screamfirst = 0; - PL_screamnext = 0; - PL_reg_start_tmp = 0; - PL_reg_start_tmpl = 0; - /* Initialise all per-thread SVs that the template thread used */ svp = AvARRAY(t->threadsv); for (i = 0; i <= AvFILLp(t->threadsv); i++, svp++) { @@ -2820,7 +2926,7 @@ new_struct_thread(struct perl_thread *t) SV *sv = newSVsv(*svp); av_store(thr->threadsv, i, sv); sv_magic(sv, 0, 0, &PL_threadsv_names[i], 1); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), + DEBUG_S(PerlIO_printf(PerlIO_stderr(), "new_struct_thread: copied threadsv %d %p->%p\n",i, t, thr)); } } @@ -2835,6 +2941,9 @@ new_struct_thread(struct perl_thread *t) thr->next->prev = thr; MUTEX_UNLOCK(&PL_threads_mutex); + /* done copying parent's state */ + MUTEX_UNLOCK(&t->mutex); + #ifdef HAVE_THREAD_INTERN init_thread_intern(thr); #endif /* HAVE_THREAD_INTERN */ @@ -2866,30 +2975,132 @@ Perl_GetVars(void) char ** get_op_names(void) { - return op_name; + return PL_op_name; } char ** get_op_descs(void) { - return op_desc; + return PL_op_desc; } char * get_no_modify(void) { - return (char*)no_modify; + return (char*)PL_no_modify; } U32 * get_opargs(void) { - return opargs; + return PL_opargs; } - SV ** get_specialsv_list(void) { return PL_specialsv_list; } + + +MGVTBL* +get_vtbl(int vtbl_id) +{ + MGVTBL* result = Null(MGVTBL*); + + switch(vtbl_id) { + case want_vtbl_sv: + result = &PL_vtbl_sv; + break; + case want_vtbl_env: + result = &PL_vtbl_env; + break; + case want_vtbl_envelem: + result = &PL_vtbl_envelem; + break; + case want_vtbl_sig: + result = &PL_vtbl_sig; + break; + case want_vtbl_sigelem: + result = &PL_vtbl_sigelem; + break; + case want_vtbl_pack: + result = &PL_vtbl_pack; + break; + case want_vtbl_packelem: + result = &PL_vtbl_packelem; + break; + case want_vtbl_dbline: + result = &PL_vtbl_dbline; + break; + case want_vtbl_isa: + result = &PL_vtbl_isa; + break; + case want_vtbl_isaelem: + result = &PL_vtbl_isaelem; + break; + case want_vtbl_arylen: + result = &PL_vtbl_arylen; + break; + case want_vtbl_glob: + result = &PL_vtbl_glob; + break; + case want_vtbl_mglob: + result = &PL_vtbl_mglob; + break; + case want_vtbl_nkeys: + result = &PL_vtbl_nkeys; + break; + case want_vtbl_taint: + result = &PL_vtbl_taint; + break; + case want_vtbl_substr: + result = &PL_vtbl_substr; + break; + case want_vtbl_vec: + result = &PL_vtbl_vec; + break; + case want_vtbl_pos: + result = &PL_vtbl_pos; + break; + case want_vtbl_bm: + result = &PL_vtbl_bm; + break; + case want_vtbl_fm: + result = &PL_vtbl_fm; + break; + case want_vtbl_uvar: + result = &PL_vtbl_uvar; + break; +#ifdef USE_THREADS + case want_vtbl_mutex: + result = &PL_vtbl_mutex; + break; +#endif + case want_vtbl_defelem: + result = &PL_vtbl_defelem; + break; + case want_vtbl_regexp: + result = &PL_vtbl_regexp; + break; + case want_vtbl_regdata: + result = &PL_vtbl_regdata; + break; + case want_vtbl_regdatum: + result = &PL_vtbl_regdatum; + break; +#ifdef USE_LOCALE_COLLATE + case want_vtbl_collxfrm: + result = &PL_vtbl_collxfrm; + break; +#endif + case want_vtbl_amagic: + result = &PL_vtbl_amagic; + break; + case want_vtbl_amagicelem: + result = &PL_vtbl_amagicelem; + break; + } + return result; +} +