diff options
| -rw-r--r-- | doop.c | 2 | ||||
| -rw-r--r-- | embed.h | 11 | ||||
| -rw-r--r-- | ext/Thread/Thread.xs | 17 | ||||
| -rw-r--r-- | global.sym | 3 | ||||
| -rw-r--r-- | gv.c | 1 | ||||
| -rw-r--r-- | hv.c | 2 | ||||
| -rw-r--r-- | interp.sym | 3 | ||||
| -rw-r--r-- | mg.c | 20 | ||||
| -rw-r--r-- | op.c | 61 | ||||
| -rw-r--r-- | opcode.h | 15 | ||||
| -rwxr-xr-x | opcode.pl | 12 | ||||
| -rw-r--r-- | patchlevel.h | 2 | ||||
| -rw-r--r-- | perl.c | 52 | ||||
| -rw-r--r-- | perl.h | 4 | ||||
| -rw-r--r-- | pp.c | 3 | ||||
| -rw-r--r-- | pp_ctl.c | 22 | ||||
| -rw-r--r-- | pp_sys.c | 18 | ||||
| -rw-r--r-- | proto.h | 8 | ||||
| -rw-r--r-- | sv.c | 13 | ||||
| -rw-r--r-- | sv.h | 32 | ||||
| -rw-r--r-- | taint.c | 5 | ||||
| -rw-r--r-- | thread.h | 42 | ||||
| -rw-r--r-- | toke.c | 21 | ||||
| -rw-r--r-- | util.c | 7 | ||||
| -rw-r--r-- | win32/makefile.mk | 4 |
25 files changed, 252 insertions, 128 deletions
@@ -244,6 +244,7 @@ do_chop(register SV *astr, register SV *sv) I32 do_chomp(register SV *sv) { + dTHR; register I32 count; STRLEN len; char *s; @@ -317,6 +318,7 @@ do_chomp(register SV *sv) void do_vop(I32 optype, SV *sv, SV *left, SV *right) { + dTHR; /* just for taint */ #ifdef LIBERAL register long *dl; register long *ll; @@ -460,6 +460,7 @@ #define newWHILEOP Perl_newWHILEOP #define newXS Perl_newXS #define newXSUB Perl_newXSUB +#define new_struct_thread Perl_new_struct_thread #define nextargv Perl_nextargv #define nexttoke Perl_nexttoke #define nexttype Perl_nexttype @@ -514,6 +515,7 @@ #define padix Perl_padix #define patleave Perl_patleave #define peep Perl_peep +#define per_thread_magicals Perl_per_thread_magicals #define pidgone Perl_pidgone #define pidstatus Perl_pidstatus #define pmflag Perl_pmflag @@ -1265,7 +1267,8 @@ #define e_tmpname (curinterp->Ie_tmpname) #define endav (curinterp->Iendav) #define envgv (curinterp->Ienvgv) -#define errgv (curinterp->Ierrgv) +#define errhv (curinterp->Ierrhv) +#define errsv (curinterp->Ierrsv) #define eval_root (curinterp->Ieval_root) #define eval_start (curinterp->Ieval_start) #define fdpid (curinterp->Ifdpid) @@ -1417,7 +1420,8 @@ #define Ie_tmpname e_tmpname #define Iendav endav #define Ienvgv envgv -#define Ierrgv errgv +#define Ierrhv errhv +#define Ierrsv errsv #define Ieval_root eval_root #define Ieval_start eval_start #define Ifdpid fdpid @@ -1578,7 +1582,8 @@ #define e_fp Perl_e_fp #define e_tmpname Perl_e_tmpname #define endav Perl_endav -#define errgv Perl_errgv +#define errhv Perl_errhv +#define errsv Perl_errsv #define eval_root Perl_eval_root #define eval_start Perl_eval_start #define fdpid Perl_fdpid diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs index d132394689..3a204b25b3 100644 --- a/ext/Thread/Thread.xs +++ b/ext/Thread/Thread.xs @@ -225,23 +225,6 @@ newthread (SV *startsv, AV *initargs, char *Class) savethread = thr; thr = new_struct_thread(thr); SPAGAIN; - defstash = savethread->Tdefstash; /* XXX maybe these should */ - curstash = savethread->Tcurstash; /* always be set to main? */ - /* top_env? */ - /* runlevel */ - cvcache = newHV(); - thr->flags = THRf_R_JOINABLE; - MUTEX_INIT(&thr->mutex); - thr->tid = ++threadnum; - /* Insert new thread into the circular linked list and bump nthreads */ - MUTEX_LOCK(&threads_mutex); - thr->next = savethread->next; - thr->prev = savethread; - savethread->next = thr; - thr->next->prev = thr; - nthreads++; - MUTEX_UNLOCK(&threads_mutex); - DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: newthread, tid is %u, preparing stack\n", savethread, thr->tid)); diff --git a/global.sym b/global.sym index 5702556528..c2c8b0b18e 100644 --- a/global.sym +++ b/global.sym @@ -120,6 +120,7 @@ na ncmp_amg ne_amg neg_amg +new_struct_thread nexttoke nexttype nextval @@ -162,6 +163,7 @@ pad_reset_pending padix padix_floor patleave +per_thread_magicals pidstatus pow_amg pow_ass_amg @@ -956,6 +958,7 @@ pp_snetent pp_socket pp_sockpair pp_sort +pp_specific pp_splice pp_split pp_sprintf @@ -219,7 +219,6 @@ gv_fetchmeth(HV *stash, char *name, STRLEN len, I32 level) (cv = GvCV(gv)) && (CvROOT(cv) || CvXSUB(cv))) { - dTHR; /* just for SvREFCNT_inc */ if (cv = GvCV(topgv)) SvREFCNT_dec(cv); GvCV(topgv) = (CV*)SvREFCNT_inc(GvCV(gv)); @@ -294,6 +294,7 @@ hv_store_ent(HV *hv, SV *keysv, SV *val, register U32 hash) xhv = (XPVHV*)SvANY(hv); if (SvMAGICAL(hv)) { + dTHR; bool save_taint = tainted; if (tainting) tainted = SvTAINTED(keysv); @@ -877,7 +878,6 @@ hv_iternext(HV *hv) } magic_nextpack((SV*) hv,mg,key); if (SvOK(key)) { - dTHR; /* just for SvREFCNT_inc */ /* force key to stay around until next time */ HeSVKEY_set(entry, SvREFCNT_inc(key)); return entry; /* beware, hent_val is not set */ diff --git a/interp.sym b/interp.sym index 1583ea217e..ae064a8031 100644 --- a/interp.sym +++ b/interp.sym @@ -47,7 +47,8 @@ e_fp e_tmpname endav envgv -errgv +errhv +errsv eval_root eval_start fdpid @@ -247,6 +247,7 @@ mg_free(SV *sv) U32 magic_len(SV *sv, MAGIC *mg) { + dTHR; register I32 paren; register char *s; register I32 i; @@ -310,6 +311,7 @@ magic_len(SV *sv, MAGIC *mg) int magic_get(SV *sv, MAGIC *mg) { + dTHR; register I32 paren; register char *s; register I32 i; @@ -396,7 +398,11 @@ magic_get(SV *sv, MAGIC *mg) case '1': case '2': case '3': case '4': case '5': case '6': case '7': case '8': case '9': case '&': if (curpm && (rx = curpm->op_pmregexp)) { - paren = atoi(GvENAME((GV*)mg->mg_obj)); + /* + * Pre-threads, this was paren = atoi(GvENAME((GV*)mg->mg_obj)); + * XXX Does the new way break anything? + */ + paren = atoi(mg->mg_ptr); getparen: if (paren <= rx->nparens && (s = rx->startp[paren]) && @@ -553,6 +559,11 @@ magic_get(SV *sv, MAGIC *mg) break; case '0': break; +#ifdef USE_THREADS + case '@': + sv_setsv(sv, errsv); + break; +#endif /* USE_THREADS */ } return 0; } @@ -718,7 +729,6 @@ magic_getsig(SV *sv, MAGIC *mg) if(psig_ptr[i]) sv_setsv(sv,psig_ptr[i]); else { - dTHR; /* just for SvREFCNT_inc */ Sighandler_t sigstate = rsignal_state(i); /* cache state so we don't fetch it again */ @@ -1098,6 +1108,7 @@ magic_setsubstr(SV *sv, MAGIC *mg) int magic_gettaint(SV *sv, MAGIC *mg) { + dTHR; TAINT_IF((mg->mg_len & 1) || (mg->mg_len & 2) && mg->mg_obj == sv); /* kludge */ return 0; @@ -1604,6 +1615,11 @@ magic_set(SV *sv, MAGIC *mg) origargv[i] = Nullch; } break; +#ifdef USE_THREADS + case '@': + sv_setsv(errsv, sv); + break; +#endif /* USE_THREADS */ } return 0; } @@ -523,7 +523,7 @@ find_thread_magical(char *name) sv_setpv(sv, "\034"); break; } - sv_magic(sv, 0, 0, name, 1); + sv_magic(sv, 0, 0, name, 1); DEBUG_L(PerlIO_printf(PerlIO_stderr(), "find_thread_magical: new SV %p for $%s%c\n", sv, (*name < 32) ? "^" : "", @@ -1147,7 +1147,7 @@ mod(OP *o, I32 type) case OP_RV2SV: if (!type && cUNOPo->op_first->op_type != OP_GV) croak("Can't localize through a reference"); - ref(cUNOPo->op_first, o->op_type); + ref(cUNOPo->op_first, o->op_type); /* FALL THROUGH */ case OP_GV: case OP_AV2ARYLEN: @@ -1175,7 +1175,7 @@ mod(OP *o, I32 type) case OP_SPECIFIC: modcount++; /* XXX ??? */ #if 0 - if (!type) + if (!type) croak("Can't localize thread-specific variable"); #endif break; @@ -1314,7 +1314,7 @@ ref(OP *o, I32 type) o->op_flags |= OPf_SPECIAL; } break; - + case OP_COND_EXPR: for (kid = cUNOPo->op_first->op_sibling; kid; kid = kid->op_sibling) ref(kid, type); @@ -1330,10 +1330,14 @@ ref(OP *o, I32 type) o->op_flags |= OPf_MOD; } break; - + + case OP_SPECIFIC: + o->op_flags |= OPf_MOD; /* XXX ??? */ + break; + case OP_RV2AV: case OP_RV2HV: - o->op_flags |= OPf_REF; + o->op_flags |= OPf_REF; /* FALL THROUGH */ case OP_RV2GV: ref(cUNOPo->op_first, o->op_type); @@ -1341,9 +1345,9 @@ ref(OP *o, I32 type) case OP_PADAV: case OP_PADHV: - o->op_flags |= OPf_REF; + o->op_flags |= OPf_REF; break; - + case OP_SCALAR: case OP_NULL: if (!(o->op_flags & OPf_KIDS)) @@ -1664,7 +1668,7 @@ fold_constants(register OP *o) } return newSVOP(OP_CONST, 0, sv); } - + nope: if (!(opargs[type] & OA_OTHERINT)) return o; @@ -1904,7 +1908,7 @@ newUNOP(I32 type, I32 flags, OP *first) UNOP *unop; if (!first) - first = newOP(OP_STUB, 0); + first = newOP(OP_STUB, 0); if (opargs[type] & OA_MARK) first = force_list(first); @@ -2063,7 +2067,7 @@ pmruntime(OP *o, OP *expr, OP *repl) pm->op_pmflags |= PMf_SKIPWHITE; } pm->op_pmregexp = pregcomp(p, p + plen, pm); - if (strEQ("\\s+", pm->op_pmregexp->precomp)) + if (strEQ("\\s+", pm->op_pmregexp->precomp)) pm->op_pmflags |= PMf_WHITE; hoistmust(pm); op_free(expr); @@ -2287,7 +2291,7 @@ utilize(int aver, I32 floor, OP *version, OP *id, OP *arg) newUNOP(OP_METHOD, 0, meth))); } } - + /* Fake up an import/unimport */ if (arg && arg->op_type == OP_STUB) imop = arg; /* no import on explicit () */ @@ -2845,7 +2849,7 @@ newWHILEOP(I32 flags, I32 debuggable, LOOP *loop, I32 whileline, OP *expr, OP *b op_free((OP*)loop); return Nullop; /* (listop already freed by newLOGOP) */ } - ((LISTOP*)listop)->op_last->op_next = condop = + ((LISTOP*)listop)->op_last->op_next = condop = (o == listop ? redo : LINKLIST(o)); if (!next) next = condop; @@ -3218,7 +3222,7 @@ cv_const_sv(CV *cv) { OP *o; SV *sv; - + if (!cv || !SvPOK(cv) || SvCUR(cv)) return Nullsv; @@ -3334,8 +3338,8 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) croak(not_safe); else { /* force display of errors found but not reported */ - sv_catpv(GvSV(errgv), not_safe); - croak("%s", SvPVx(GvSV(errgv), na)); + sv_catpv(errsv, not_safe); + croak("%s", SvPV(errsv, na)); } } } @@ -3462,8 +3466,9 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block) return cv; } + CV * -newXS(char *name, void (*subaddr) _((CV *)), char *filename) +newXS(char *name, void (*subaddr) (CV *), char *filename) { dTHR; GV *gv = gv_fetchpv(name ? name : "__ANON__", GV_ADDMULTI, SVt_PVCV); @@ -3702,6 +3707,8 @@ newSVREF(OP *o) o->op_ppaddr = ppaddr[OP_PADSV]; return o; } + else if (o->op_type == OP_SPECIFIC) + return o; return newUNOP(OP_RV2SV, 0, scalar(o)); } @@ -3757,7 +3764,7 @@ ck_spair(OP *o) !(opargs[newop->op_type] & OA_RETSCALAR) || newop->op_type == OP_PADAV || newop->op_type == OP_PADHV || newop->op_type == OP_RV2AV || newop->op_type == OP_RV2HV)) { - + return o; } op_free(kUNOP->op_first); @@ -3978,7 +3985,7 @@ ck_fun(OP *o) I32 numargs = 0; int type = o->op_type; register I32 oa = opargs[type] >> OASHIFT; - + if (o->op_flags & OPf_STACKED) { if ((oa & OA_OPTIONAL) && (oa >> 4) && !((oa >> 4) & OA_OPTIONAL)) oa &= ~OA_OPTIONAL; @@ -4127,7 +4134,7 @@ ck_glob(OP *o) cLISTOPo->op_first->op_type = OP_PUSHMARK; cLISTOPo->op_first->op_ppaddr = ppaddr[OP_PUSHMARK]; o = newUNOP(OP_ENTERSUB, OPf_STACKED, - append_elem(OP_LIST, o, + append_elem(OP_LIST, o, scalar(newUNOP(OP_RV2CV, 0, newGVOP(OP_GV, 0, gv))))); o = newUNOP(OP_NULL, 0, ck_subr(o)); @@ -4150,7 +4157,7 @@ ck_grep(OP *o) o->op_ppaddr = ppaddr[OP_GREPSTART]; Newz(1101, gwop, 1, LOGOP); - + if (o->op_flags & OPf_STACKED) { OP* k; o = ck_sort(o); @@ -4169,7 +4176,7 @@ ck_grep(OP *o) o = ck_fun(o); if (error_count) return o; - kid = cLISTOPo->op_first->op_sibling; + kid = cLISTOPo->op_first->op_sibling; if (kid->op_type != OP_NULL) croak("panic: ck_grep"); kid = kUNOP->op_first; @@ -4228,7 +4235,7 @@ OP * ck_listiob(OP *o) { register OP *kid; - + kid = cLISTOPo->op_first; if (!kid) { o = force_list(o); @@ -4445,7 +4452,7 @@ ck_split(OP *o) { register OP *kid; PMOP* pm; - + if (o->op_flags & OPf_STACKED) return no_fh_allowed(o); @@ -4747,7 +4754,7 @@ peep(register OP *o) o->op_next = o->op_next->op_next; } break; - + case OP_PADHV: if (o->op_next->op_type == OP_RV2HV && (o->op_next->op_flags && OPf_REF)) @@ -4798,7 +4805,7 @@ peep(register OP *o) } } break; - + case OP_HELEM: { UNOP *rop; SV *lexname; @@ -4807,7 +4814,7 @@ peep(register OP *o) I32 ind; char *key; STRLEN keylen; - + if (o->op_private & (OPpDEREF_HV|OPpDEREF_AV|OPpLVAL_INTRO) || ((BINOP*)o)->op_last->op_type != OP_CONST) break; @@ -349,10 +349,11 @@ typedef enum { OP_GETLOGIN, /* 342 */ OP_SYSCALL, /* 343 */ OP_LOCK, /* 344 */ + OP_SPECIFIC, /* 345 */ OP_max } opcode; -#define MAXO 345 +#define MAXO 346 #ifndef DOINIT EXT char *op_name[]; @@ -703,6 +704,7 @@ EXT char *op_name[] = { "getlogin", "syscall", "lock", + "specific", }; #endif @@ -1055,6 +1057,7 @@ EXT char *op_desc[] = { "getlogin", "syscall", "lock", + "thread-specific", }; #endif @@ -1438,14 +1441,14 @@ OP * pp_egrent _((ARGSproto)); OP * pp_getlogin _((ARGSproto)); OP * pp_syscall _((ARGSproto)); OP * pp_lock _((ARGSproto)); - +OP * pp_specific _((ARGSproto)); END_EXTERN_C #ifndef DOINIT -EXT OP * (*ppaddr[])_((ARGSproto)); +EXT OP * (*ppaddr[])(ARGSproto); #else -EXT OP * (*ppaddr[])_((ARGSproto)) = { +EXT OP * (*ppaddr[])(ARGSproto) = { pp_null, pp_stub, pp_scalar, @@ -1791,6 +1794,7 @@ EXT OP * (*ppaddr[])_((ARGSproto)) = { pp_getlogin, pp_syscall, pp_lock, + pp_specific, }; #endif @@ -2143,6 +2147,7 @@ EXT OP * (*check[]) _((OP *op)) = { ck_null, /* getlogin */ ck_fun, /* syscall */ ck_rfun, /* lock */ + ck_null, /* specific */ }; #endif @@ -2495,6 +2500,6 @@ EXT U32 opargs[] = { 0x0000000c, /* getlogin */ 0x0002151d, /* syscall */ 0x00001c04, /* lock */ + 0x00000044, /* specific */ }; #endif - @@ -77,6 +77,8 @@ print <<END; }; #endif +START_EXTERN_C + END # Emit function declarations. @@ -95,10 +97,12 @@ for (@ops) { print <<END; +END_EXTERN_C + #ifndef DOINIT -EXT OP * (*ppaddr[])(); +EXT OP * (*ppaddr[])(ARGSproto); #else -EXT OP * (*ppaddr[])() = { +EXT OP * (*ppaddr[])(ARGSproto) = { END for (@ops) { @@ -180,8 +184,6 @@ for (@ops) { $argsum |= 128 if $flags =~ /u/; # defaults to $_ $flags =~ /([^a-zA-Z])/ or die qq[Opcode "$_" has no class indicator]; - printf STDERR "op $_, class $1 => 0x%x, argsum 0x%x", - $opclass{$1}, $argsum; # debug $argsum |= $opclass{$1} << 8; $mul = 4096; # 2 ^ OASHIFT for $arg (split(' ',$args{$_})) { @@ -190,7 +192,6 @@ for (@ops) { $argsum += $argnum * $mul; $mul <<= 4; } - printf STDERR ", argsum now 0x%x\n", $argsum; # debug $argsum = sprintf("0x%08x", $argsum); print "\t", &tab(3, "$argsum,"), "/* $_ */\n"; } @@ -680,3 +681,4 @@ syscall syscall ck_fun imst@ S L # For multi-threading lock lock ck_rfun s% S +specific thread-specific ck_null ds0 diff --git a/patchlevel.h b/patchlevel.h index d8da982693..c5dff601ed 100644 --- a/patchlevel.h +++ b/patchlevel.h @@ -1,5 +1,5 @@ #define PATCHLEVEL 4 -#define SUBVERSION 52 +#define SUBVERSION 54 /* local_patches -- list of locally applied less-than-subversion patches. @@ -109,9 +109,12 @@ perl_alloc(void) void perl_construct(register PerlInterpreter *sv_interp) { -#if defined(USE_THREADS) && !defined(FAKE_THREADS) +#ifdef USE_THREADS + int i; +#ifndef FAKE_THREADS struct thread *thr; -#endif +#endif /* FAKE_THREADS */ +#endif /* USE_THREADS */ if (!(curinterp = sv_interp)) return; @@ -123,13 +126,18 @@ perl_construct(register PerlInterpreter *sv_interp) /* Init the real globals (and main thread)? */ if (!linestr) { #ifdef USE_THREADS - XPV *xpv; INIT_THREADS; - Newz(53, thr, 1, struct thread); +#ifndef WIN32 + if (pthread_key_create(&thr_key, 0)) + croak("panic: pthread_key_create"); +#endif MUTEX_INIT(&malloc_mutex); MUTEX_INIT(&sv_mutex); - /* Safe to use SVs from now on */ + /* + * Safe to use basic SV functions from now on (though + * not things like mortals or tainting yet). + */ MUTEX_INIT(&eval_mutex); COND_INIT(&eval_cond); MUTEX_INIT(&threads_mutex); @@ -462,7 +470,8 @@ perl_destruct(register PerlInterpreter *sv_interp) envgv = Nullgv; siggv = Nullgv; incgv = Nullgv; - errgv = Nullgv; + errhv = Nullhv; + errsv = Nullsv; argvgv = Nullgv; argvoutgv = Nullgv; stdingv = Nullgv; @@ -960,7 +969,7 @@ print \" \\@INC:\\n @INC\\n\";"); sv_setsv(*av_fetch(thr->magicals, find_thread_magical("/"), FALSE), rs); #else sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs); - +#endif /* USE_THREADS */ if (do_undump) my_unexec(); @@ -1221,7 +1230,7 @@ perl_call_sv(SV *sv, I32 flags) if (flags & G_KEEPERR) in_eval |= 4; else - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); } markstack_ptr++; @@ -1266,7 +1275,7 @@ perl_call_sv(SV *sv, I32 flags) runops(); retval = stack_sp - (stack_base + oldmark); if ((flags & G_EVAL) && !(flags & G_KEEPERR)) - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); cleanup: if (flags & G_EVAL) { @@ -1375,7 +1384,7 @@ perl_eval_sv(SV *sv, I32 flags) runops(); retval = stack_sp - (stack_base + oldmark); if (!(flags & G_KEEPERR)) - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); cleanup: JMPENV_POP; @@ -1403,8 +1412,8 @@ perl_eval_pv(char *p, I32 croak_on_error) sv = POPs; PUTBACK; - if (croak_on_error && SvTRUE(GvSV(errgv))) - croak(SvPVx(GvSV(errgv), na)); + if (croak_on_error && SvTRUE(errsv)) + croak(SvPV(errsv, na)); return sv; } @@ -1481,6 +1490,8 @@ moreswitches(char *s) switch (*s) { case '0': + { + dTHR; rschar = scan_oct(s, 4, &numlen); SvREFCNT_dec(nrs); if (rschar & ~((U8)~0)) @@ -1492,6 +1503,7 @@ moreswitches(char *s) nrs = newSVpv(&ch, 1); } return s + numlen; + } case 'F': minus_F = TRUE; splitstr = savepv(s + 1); @@ -1578,6 +1590,7 @@ moreswitches(char *s) s += numlen; } else { + dTHR; if (RsPARA(nrs)) { ors = "\n\n"; orslen = 2; @@ -1766,11 +1779,11 @@ init_main_stash(void) incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); GvMULTI_on(incgv); defgv = gv_fetchpv("_",TRUE, SVt_PVAV); - errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV)); - GvMULTI_on(errgv); + errsv = newSVpv("", 0); + errhv = newHV(); (void)form("%240s",""); /* Preallocate temp - for immediate signals. */ - sv_grow(GvSV(errgv), 240); /* Preallocate - for immediate signals. */ - sv_setpvn(GvSV(errgv), "", 0); + sv_grow(errsv, 240); /* Preallocate - for immediate signals. */ + sv_setpvn(errsv, "", 0); curstash = defstash; compiling.cop_stash = defstash; debstash = GvHV(gv_fetchpv("DB::", GV_ADDMULTI, SVt_PVHV)); @@ -2506,6 +2519,7 @@ init_predump_symbols(void) sv_setpvn(*av_fetch(thr->magicals,find_thread_magical("\""),FALSE)," ", 1); #else sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1); +#endif /* USE_THREADS */ stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO); GvMULTI_on(stdingv); @@ -2538,6 +2552,7 @@ init_predump_symbols(void) static void init_postdump_symbols(register int argc, register char **argv, register char **env) { + dTHR; char *s; SV *sv; GV* tmpgv; @@ -2913,8 +2928,8 @@ my_exit(U32 status) dTHR; #ifdef USE_THREADS - DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n", - (unsigned long) thr, (unsigned long) status)); + DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", + thr, (unsigned long) status)); #endif /* USE_THREADS */ switch (status) { case 0: @@ -2981,3 +2996,4 @@ my_exit_jump(void) JMPENV_JUMP(2); } + @@ -1367,6 +1367,7 @@ EXT struct thread * eval_owner; /* Owner thread for doeval */ EXT int nthreads; /* Number of threads currently */ EXT perl_mutex threads_mutex; /* Mutex for nthreads and thread list */ EXT perl_cond nthreads_cond; /* Condition variable for nthreads */ +EXT char * per_thread_magicals INIT(PER_THREAD_MAGICALS); #ifdef FAKE_THREADS EXT struct thread * thr; /* Currently executing (fake) thread */ #endif @@ -1869,7 +1870,8 @@ IEXT I32 Imaxscream IINIT(-1); IEXT SV * Ilastscream; /* shortcuts to misc objects */ -IEXT GV * Ierrgv; +IEXT HV * Ierrhv; +IEXT SV * Ierrsv; /* shortcuts to debugging objects */ IEXT GV * IDBgv; @@ -403,7 +403,6 @@ refto(SV *sv) else if (SvPADTMP(sv)) sv = newSVsv(sv); else { - dTHR; /* just for SvREFCNT_inc */ SvTEMP_off(sv); (void)SvREFCNT_inc(sv); } @@ -4313,3 +4312,5 @@ PP(pp_specific) #endif /* USE_THREADS */ RETURN; } + + @@ -1029,21 +1029,21 @@ die_where(char *message) SV **svp; STRLEN klen = strlen(message); - svp = hv_fetch(GvHV(errgv), message, klen, TRUE); + svp = hv_fetch(errhv, message, klen, TRUE); if (svp) { if (!SvIOK(*svp)) { static char prefix[] = "\t(in cleanup) "; sv_upgrade(*svp, SVt_IV); (void)SvIOK_only(*svp); - SvGROW(GvSV(errgv), SvCUR(GvSV(errgv))+sizeof(prefix)+klen); - sv_catpvn(GvSV(errgv), prefix, sizeof(prefix)-1); - sv_catpvn(GvSV(errgv), message, klen); + SvGROW(errsv, SvCUR(errsv)+sizeof(prefix)+klen); + sv_catpvn(errsv, prefix, sizeof(prefix)-1); + sv_catpvn(errsv, message, klen); } sv_inc(*svp); } } else - sv_setpv(GvSV(errgv), message); + sv_setpv(errsv, message); cxix = dopoptoeval(cxstack_ix); if (cxix >= 0) { @@ -1066,7 +1066,7 @@ die_where(char *message) LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(GvSV(errgv), na); + char* msg = SvPV(errsv, na); DIE("%s", *msg ? msg : "Compilation failed in require"); } return pop_return(); @@ -2171,7 +2171,7 @@ doeval(int gimme) if (saveop->op_flags & OPf_SPECIAL) in_eval |= 4; else - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); if (yyparse() || error_count || !eval_root) { SV **newsp; I32 gimme; @@ -2190,7 +2190,7 @@ doeval(int gimme) lex_end(); LEAVE; if (optype == OP_REQUIRE) { - char* msg = SvPVx(GvSV(errgv), na); + char* msg = SvPV(errsv, na); DIE("%s", *msg ? msg : "Compilation failed in require"); } SvREFCNT_dec(rs); @@ -2544,7 +2544,7 @@ PP(pp_leaveeval) LEAVE; if (!(save_flags & OPf_SPECIAL)) - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); RETURNOP(retop); } @@ -2564,7 +2564,7 @@ PP(pp_entertry) eval_root = op; /* Only needed so that goto works right. */ in_eval = 1; - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); PUTBACK; return DOCATCH(op->op_next); } @@ -2612,7 +2612,7 @@ PP(pp_leavetry) curpm = newpm; /* Don't pop $1 et al till now */ LEAVE; - sv_setpv(GvSV(errgv),""); + sv_setpv(errsv,""); RETURN; } @@ -284,11 +284,10 @@ PP(pp_warn) tmps = SvPV(TOPs, na); } if (!tmps || !*tmps) { - SV *error = GvSV(errgv); - (void)SvUPGRADE(error, SVt_PV); - if (SvPOK(error) && SvCUR(error)) - sv_catpv(error, "\t...caught"); - tmps = SvPV(error, na); + (void)SvUPGRADE(errsv, SVt_PV); + if (SvPOK(errsv) && SvCUR(errsv)) + sv_catpv(errsv, "\t...caught"); + tmps = SvPV(errsv, na); } if (!tmps || !*tmps) tmps = "Warning: something's wrong"; @@ -310,11 +309,10 @@ PP(pp_die) tmps = SvPV(TOPs, na); } if (!tmps || !*tmps) { - SV *error = GvSV(errgv); - (void)SvUPGRADE(error, SVt_PV); - if (SvPOK(error) && SvCUR(error)) - sv_catpv(error, "\t...propagated"); - tmps = SvPV(error, na); + (void)SvUPGRADE(errsv, SVt_PV); + if (SvPOK(errsv) && SvCUR(errsv)) + sv_catpv(errsv, "\t...propagated"); + tmps = SvPV(errsv, na); } if (!tmps || !*tmps) tmps = "Died"; @@ -4,7 +4,7 @@ #undef __attribute__ #endif #define __attribute__(attr) -#endif +#endif #endif #ifdef OVERLOAD SV* amagic_call _((SV* left,SV* right,int method,int dir)); @@ -134,6 +134,9 @@ void dump_packsubs _((HV* stash)); void dump_sub _((GV* gv)); void fbm_compile _((SV* sv)); char* fbm_instr _((unsigned char* big, unsigned char* bigend, SV* littlesv)); +#ifdef USE_THREADS +PADOFFSET find_thread_magical _((char *name)); +#endif OP* force_list _((OP* arg)); OP* fold_constants _((OP* arg)); char* form _((const char* pat, ...)); @@ -336,6 +339,9 @@ SV* newSVsv _((SV* old)); OP* newUNOP _((I32 type, I32 flags, OP* first)); OP* newWHILEOP _((I32 flags, I32 debuggable, LOOP* loop, I32 whileline, OP* expr, OP* block, OP* cont)); +#ifdef USE_THREADS +struct thread * new_struct_thread _((struct thread *t)); +#endif PerlIO* nextargv _((GV* gv)); char* ninstr _((char* big, char* bigend, char* little, char* lend)); OP* oopsCV _((OP* o)); @@ -1084,6 +1084,7 @@ sv_grow(SV* sv, unsigned long newlen) void sv_setiv(register SV *sv, IV i) { + dTHR; /* just for taint */ sv_check_thinkfirst(sv); switch (SvTYPE(sv)) { case SVt_NULL: @@ -1131,6 +1132,7 @@ sv_setuv(register SV *sv, UV u) void sv_setnv(register SV *sv, double num) { + dTHR; /* just for taint */ sv_check_thinkfirst(sv); switch (SvTYPE(sv)) { case SVt_NULL: @@ -2146,6 +2148,7 @@ sv_setsv(SV *dstr, register SV *sstr) void sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len) { + dTHR; /* just for taint */ assert(len >= 0); /* STRLEN is probably unsigned, so this may elicit a warning, but it won't hurt. */ sv_check_thinkfirst(sv); @@ -2170,6 +2173,7 @@ sv_setpvn(register SV *sv, register const char *ptr, register STRLEN len) void sv_setpv(register SV *sv, register const char *ptr) { + dTHR; /* just for taint */ register STRLEN len; sv_check_thinkfirst(sv); @@ -2194,6 +2198,7 @@ sv_setpv(register SV *sv, register const char *ptr) void sv_usepvn(register SV *sv, register char *ptr, register STRLEN len) { + dTHR; /* just for taint */ sv_check_thinkfirst(sv); if (!SvUPGRADE(sv, SVt_PV)) return; @@ -2254,6 +2259,7 @@ sv_chop(register SV *sv, register char *ptr) /* like set but assuming ptr is in void sv_catpvn(register SV *sv, register char *ptr, register STRLEN len) { + dTHR; /* just for taint */ STRLEN tlen; char *junk; @@ -2282,6 +2288,7 @@ sv_catsv(SV *dstr, register SV *sstr) void sv_catpv(register SV *sv, register char *ptr) { + dTHR; /* just for taint */ register STRLEN len; STRLEN tlen; char *junk; @@ -2977,6 +2984,7 @@ sv_collxfrm(SV *sv, STRLEN *nxp) char * sv_gets(register SV *sv, register FILE *fp, I32 append) { + dTHR; char *rsptr; STRLEN rslen; register STDCHAR rslast; @@ -3490,8 +3498,9 @@ newRV(SV *ref) } + SV * -newRV_noinc(SV *ref) +Perl_newRV_noinc(SV *ref) { register SV *sv; @@ -3570,6 +3579,7 @@ sv_reset(register char *s, HV *stash) sv = GvSV(gv); (void)SvOK_off(sv); if (SvTYPE(sv) >= SVt_PV) { + dTHR; /* just for taint */ SvCUR_set(sv, 0); if (SvPVX(sv) != Nullch) *SvPVX(sv) = '\0'; @@ -3788,6 +3798,7 @@ sv_pvn_force(SV *sv, STRLEN *lp) *SvEND(sv) = '\0'; } if (!SvPOK(sv)) { + dTHR; /* just for taint */ SvPOK_on(sv); /* validate pointer */ SvTAINT(sv); DEBUG_c(PerlIO_printf(Perl_debug_log, "0x%lx 2pv(%s)\n", @@ -70,6 +70,7 @@ struct io { #define SvANY(sv) (sv)->sv_any #define SvFLAGS(sv) (sv)->sv_flags +#define SvREFCNT(sv) (sv)->sv_refcnt #ifdef __GNUC__ # define SvREFCNT_inc(sv) ({SV* nsv=(SV*)(sv); if(nsv) ++SvREFCNT(nsv); nsv;}) @@ -82,7 +83,6 @@ struct io { #endif #define SvREFCNT_dec(sv) sv_free((SV*)sv) -#endif #define SVTYPEMASK 0xff #define SvTYPE(sv) ((sv)->sv_flags & SVTYPEMASK) @@ -546,19 +546,33 @@ struct xpvio { ? SvNVX(sv) != 0.0 \ : sv_2bool(sv) ) -#define SvIVx(sv) ((Sv = (sv)), SvIV(Sv)) -#define SvUVx(sv) ((Sv = (sv)), SvUV(Sv)) -#define SvNVx(sv) ((Sv = (sv)), SvNV(Sv)) -#define SvPVx(sv, lp) ((Sv = (sv)), SvPV(Sv, lp)) +#ifdef __GNUC__ +# define SvIVx(sv) ({SV *nsv = (SV*)(sv); SvIV(nsv); }) +# define SvUVx(sv) ({SV *nsv = (SV*)(sv); SvUV(nsv); }) +# define SvNVx(sv) ({SV *nsv = (SV*)(sv); SvNV(nsv); }) +# define SvPVx(sv, lp) ({SV *nsv = (sv); SvPV(nsv, lp); }) +#else +# define SvIVx(sv) ((Sv = (sv)), SvIV(Sv)) +# define SvUVx(sv) ((Sv = (sv)), SvUV(Sv)) +# define SvNVx(sv) ((Sv = (sv)), SvNV(Sv)) +# define SvPVx(sv, lp) ((Sv = (sv)), SvPV(Sv, lp)) +#endif /* __GNUC__ */ + #define SvTRUEx(sv) ((Sv = (sv)), SvTRUE(Sv)) #endif /* CRIPPLED_CC */ #define newRV_inc(sv) newRV(sv) -#ifndef CRIPPLED_CC -#undef newRV_noinc -#define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv) -#endif +#ifdef __GNUC__ +# undef newRV_noinc +# define newRV_noinc(sv) ({SV *nsv=newRV((sv)); --SvREFCNT(SvRV(nsv)); nsv;}) +#else +# if defined(CRIPPLED_CC) || defined(USE_THREADS) +# else +# undef newRV_noinc +# define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv) +# endif +#endif /* __GNUC__ */ /* the following macro updates any magic values this sv is associated with */ @@ -10,6 +10,7 @@ void taint_proper(const char *f, char *s) { + dTHR; /* just for taint */ char *ug; DEBUG_u(PerlIO_printf(Perl_debug_log, @@ -68,10 +69,12 @@ taint_env(void) svp = hv_fetch(GvHVn(envgv),"PATH",4,FALSE); if (svp && *svp) { if (SvTAINTED(*svp)) { + dTHR; TAINT; taint_proper("Insecure %s%s", "$ENV{PATH}"); } if ((mg = mg_find(*svp, 'e')) && MgTAINTEDDIR(mg)) { + dTHR; TAINT; taint_proper("Insecure directory in %s%s", "$ENV{PATH}"); } @@ -81,6 +84,7 @@ taint_env(void) /* tainted $TERM is okay if it contains no metachars */ svp = hv_fetch(GvHVn(envgv),"TERM",4,FALSE); if (svp && *svp && SvTAINTED(*svp)) { + dTHR; /* just for taint */ bool was_tainted = tainted; char *t = SvPV(*svp, na); char *e = t + na; @@ -99,6 +103,7 @@ taint_env(void) for (e = misc_env; *e; e++) { svp = hv_fetch(GvHVn(envgv), *e, strlen(*e), FALSE); if (svp && *svp != &sv_undef && SvTAINTED(*svp)) { + dTHR; /* just for taint */ TAINT; taint_proper("Insecure $ENV{%s}%s", *e); } @@ -172,10 +172,25 @@ struct thread { /* Now the fields that used to be "per interpreter" (even when global) */ - /* XXX What about magic variables such as $/, $? and so on? */ + /* Fields used by magic variables such as $@, $/ and so on */ + bool Ttainted; + PMOP * Tcurpm; + SV * Tnrs; + SV * Trs; + GV * Tlast_in_gv; + char * Tofs; + STRLEN Tofslen; + GV * Tdefoutgv; + char * Tchopset; + SV * Tformtarget; + SV * Tbodytarget; + SV * Ttoptarget; + + /* Stashes */ HV * Tdefstash; HV * Tcurstash; + /* Stacks */ SV ** Ttmps_stack; I32 Ttmps_ix; I32 Ttmps_floor; @@ -280,6 +295,18 @@ typedef struct condpair { #undef Xpv #undef statbuf #undef timesbuf +#undef tainted +#undef curpm +#undef nrs +#undef rs +#undef last_in_gv +#undef ofs +#undef ofslen +#undef defoutgv +#undef chopset +#undef formtarget +#undef bodytarget +#undef toptarget #undef top_env #undef runlevel #undef in_eval @@ -325,6 +352,19 @@ typedef struct condpair { #define Xpv (thr->TXpv) #define statbuf (thr->Tstatbuf) #define timesbuf (thr->Ttimesbuf) +#define tainted (thr->Ttainted) +#define tainted (thr->Ttainted) +#define curpm (thr->Tcurpm) +#define nrs (thr->Tnrs) +#define rs (thr->Trs) +#define last_in_gv (thr->Tlast_in_gv) +#define ofs (thr->Tofs) +#define ofslen (thr->Tofslen) +#define defoutgv (thr->Tdefoutgv) +#define chopset (thr->Tchopset) +#define formtarget (thr->Tformtarget) +#define bodytarget (thr->Tbodytarget) +#define toptarget (thr->Ttoptarget) #define defstash (thr->Tdefstash) #define curstash (thr->Tcurstash) @@ -1243,16 +1243,21 @@ yylex(void) (tokenbuf[1] == 'a' || tokenbuf[1] == 'b') && !tokenbuf[2]) { - if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { - croak("Can't use \"my %s\" in sort comparison", - tokenbuf); + for (d = in_eval ? oldoldbufptr : linestart; + d < bufend && *d != '\n'; + d++) + { + if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) { + croak("Can't use \"my %s\" in sort comparison", + tokenbuf); + } } } - } - yylval.opval = newOP(OP_PADANY, 0); - yylval.opval->op_targ = tmp; - return PRIVATEREF; + yylval.opval = newOP(OP_PADANY, 0); + yylval.opval->op_targ = tmp; + return PRIVATEREF; + } } /* Force them to make up their mind on "@foo". */ @@ -5365,7 +5370,7 @@ yyerror(char *s) if (in_eval & 2) warn("%_", msg); else if (in_eval) - sv_catsv(GvSV(errgv), msg); + sv_catsv(errsv, msg); else PerlIO_write(PerlIO_stderr(), SvPVX(msg), SvCUR(msg)); if (++error_count >= 10) @@ -56,6 +56,10 @@ static void xstat _((void)); #endif +#ifdef USE_THREADS +static U32 threadnum = 0; +#endif /* USE_THREADS */ + #ifndef MYMALLOC /* paranoid version of malloc */ @@ -2397,8 +2401,7 @@ condpair_magic(SV *sv) * thread calling new_struct_thread) clearly satisfies this constraint. */ struct thread * -new_struct_thread(t) -struct thread *t; +new_struct_thread(struct thread *t) { struct thread *thr; SV *sv; diff --git a/win32/makefile.mk b/win32/makefile.mk index bad3e775ab..7f5dad30e3 100644 --- a/win32/makefile.mk +++ b/win32/makefile.mk @@ -11,7 +11,7 @@ # newly built perl. INST_DRV=c: INST_TOP=$(INST_DRV)\perl\perl5004.5X -BUILDOPT=-DUSE_THREADS +BUILDOPT=-DUSE_THREADS -P # -DUSE_PERLIO -D__STDC__=1 -DUSE_SFIO -DI_SFIO -I\sfio97\include @@ -63,7 +63,7 @@ IMPLIB = implib RUNTIME = -D_RTLDLL INCLUDES = -I.\include -I. -I.. -I$(CCINCDIR) #PCHFLAGS = -H -H$(INTDIR)\bcmoduls.pch -DEFINES = -DWIN32 $(BUILDOPT) -D_WIN32_WINNT=0x400 +DEFINES = -DWIN32 $(BUILDOPT) LOCDEFS = -DPERLDLL SUBSYS = console LIBC = cw32mti.lib |