I32
do_chomp(register SV *sv)
{
+ dTHR;
register I32 count;
STRLEN len;
char *s;
void
do_vop(I32 optype, SV *sv, SV *left, SV *right)
{
+ dTHR; /* just for taint */
#ifdef LIBERAL
register long *dl;
register long *ll;
#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
#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
#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)
#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
#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
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));
ncmp_amg
ne_amg
neg_amg
+new_struct_thread
nexttoke
nexttype
nextval
padix
padix_floor
patleave
+per_thread_magicals
pidstatus
pow_amg
pow_ass_amg
pp_socket
pp_sockpair
pp_sort
+pp_specific
pp_splice
pp_split
pp_sprintf
(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));
xhv = (XPVHV*)SvANY(hv);
if (SvMAGICAL(hv)) {
+ dTHR;
bool save_taint = tainted;
if (tainting)
tainted = SvTAINTED(keysv);
}
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 */
e_tmpname
endav
envgv
-errgv
+errhv
+errsv
eval_root
eval_start
fdpid
U32
magic_len(SV *sv, MAGIC *mg)
{
+ dTHR;
register I32 paren;
register char *s;
register I32 i;
int
magic_get(SV *sv, MAGIC *mg)
{
+ dTHR;
register I32 paren;
register char *s;
register I32 i;
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]) &&
break;
case '0':
break;
+#ifdef USE_THREADS
+ case '@':
+ sv_setsv(sv, errsv);
+ break;
+#endif /* USE_THREADS */
}
return 0;
}
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 */
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;
origargv[i] = Nullch;
}
break;
+#ifdef USE_THREADS
+ case '@':
+ sv_setsv(errsv, sv);
+ break;
+#endif /* USE_THREADS */
}
return 0;
}
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) ? "^" : "",
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:
case OP_SPECIFIC:
modcount++; /* XXX ??? */
#if 0
- if (!type)
+ if (!type)
croak("Can't localize thread-specific variable");
#endif
break;
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);
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);
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))
}
return newSVOP(OP_CONST, 0, sv);
}
-
+
nope:
if (!(opargs[type] & OA_OTHERINT))
return o;
UNOP *unop;
if (!first)
- first = newOP(OP_STUB, 0);
+ first = newOP(OP_STUB, 0);
if (opargs[type] & OA_MARK)
first = force_list(first);
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);
newUNOP(OP_METHOD, 0, meth)));
}
}
-
+
/* Fake up an import/unimport */
if (arg && arg->op_type == OP_STUB)
imop = arg; /* no import on explicit () */
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;
{
OP *o;
SV *sv;
-
+
if (!cv || !SvPOK(cv) || SvCUR(cv))
return Nullsv;
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));
}
}
}
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);
o->op_ppaddr = ppaddr[OP_PADSV];
return o;
}
+ else if (o->op_type == OP_SPECIFIC)
+ return o;
return newUNOP(OP_RV2SV, 0, scalar(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);
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;
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));
o->op_ppaddr = ppaddr[OP_GREPSTART];
Newz(1101, gwop, 1, LOGOP);
-
+
if (o->op_flags & OPf_STACKED) {
OP* k;
o = ck_sort(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;
ck_listiob(OP *o)
{
register OP *kid;
-
+
kid = cLISTOPo->op_first;
if (!kid) {
o = force_list(o);
{
register OP *kid;
PMOP* pm;
-
+
if (o->op_flags & OPf_STACKED)
return no_fh_allowed(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))
}
}
break;
-
+
case OP_HELEM: {
UNOP *rop;
SV *lexname;
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;
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[];
"getlogin",
"syscall",
"lock",
+ "specific",
};
#endif
"getlogin",
"syscall",
"lock",
+ "thread-specific",
};
#endif
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,
pp_getlogin,
pp_syscall,
pp_lock,
+ pp_specific,
};
#endif
ck_null, /* getlogin */
ck_fun, /* syscall */
ck_rfun, /* lock */
+ ck_null, /* specific */
};
#endif
0x0000000c, /* getlogin */
0x0002151d, /* syscall */
0x00001c04, /* lock */
+ 0x00000044, /* specific */
};
#endif
-
};
#endif
+START_EXTERN_C
+
END
# Emit function declarations.
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) {
$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{$_})) {
$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";
}
# For multi-threading
lock lock ck_rfun s% S
+specific thread-specific ck_null ds0
#define PATCHLEVEL 4
-#define SUBVERSION 52
+#define SUBVERSION 54
/*
local_patches -- list of locally applied less-than-subversion patches.
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;
/* 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);
envgv = Nullgv;
siggv = Nullgv;
incgv = Nullgv;
- errgv = Nullgv;
+ errhv = Nullhv;
+ errsv = Nullsv;
argvgv = Nullgv;
argvoutgv = Nullgv;
stdingv = Nullgv;
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();
if (flags & G_KEEPERR)
in_eval |= 4;
else
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(errsv,"");
}
markstack_ptr++;
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) {
runops();
retval = stack_sp - (stack_base + oldmark);
if (!(flags & G_KEEPERR))
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(errsv,"");
cleanup:
JMPENV_POP;
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;
}
switch (*s) {
case '0':
+ {
+ dTHR;
rschar = scan_oct(s, 4, &numlen);
SvREFCNT_dec(nrs);
if (rschar & ~((U8)~0))
nrs = newSVpv(&ch, 1);
}
return s + numlen;
+ }
case 'F':
minus_F = TRUE;
splitstr = savepv(s + 1);
s += numlen;
}
else {
+ dTHR;
if (RsPARA(nrs)) {
ors = "\n\n";
orslen = 2;
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));
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);
static void
init_postdump_symbols(register int argc, register char **argv, register char **env)
{
+ dTHR;
char *s;
SV *sv;
GV* tmpgv;
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:
JMPENV_JUMP(2);
}
+
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
IEXT SV * Ilastscream;
/* shortcuts to misc objects */
-IEXT GV * Ierrgv;
+IEXT HV * Ierrhv;
+IEXT SV * Ierrsv;
/* shortcuts to debugging objects */
IEXT GV * IDBgv;
else if (SvPADTMP(sv))
sv = newSVsv(sv);
else {
- dTHR; /* just for SvREFCNT_inc */
SvTEMP_off(sv);
(void)SvREFCNT_inc(sv);
}
#endif /* USE_THREADS */
RETURN;
}
+
+
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) {
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();
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;
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);
LEAVE;
if (!(save_flags & OPf_SPECIAL))
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(errsv,"");
RETURNOP(retop);
}
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);
}
curpm = newpm; /* Don't pop $1 et al till now */
LEAVE;
- sv_setpv(GvSV(errgv),"");
+ sv_setpv(errsv,"");
RETURN;
}
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";
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";
#undef __attribute__
#endif
#define __attribute__(attr)
-#endif
+#endif
#endif
#ifdef OVERLOAD
SV* amagic_call _((SV* left,SV* right,int method,int dir));
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, ...));
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));
void
sv_setiv(register SV *sv, IV i)
{
+ dTHR; /* just for taint */
sv_check_thinkfirst(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
void
sv_setnv(register SV *sv, double num)
{
+ dTHR; /* just for taint */
sv_check_thinkfirst(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
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);
void
sv_setpv(register SV *sv, register const char *ptr)
{
+ dTHR; /* just for taint */
register STRLEN len;
sv_check_thinkfirst(sv);
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;
void
sv_catpvn(register SV *sv, register char *ptr, register STRLEN len)
{
+ dTHR; /* just for taint */
STRLEN tlen;
char *junk;
void
sv_catpv(register SV *sv, register char *ptr)
{
+ dTHR; /* just for taint */
register STRLEN len;
STRLEN tlen;
char *junk;
char *
sv_gets(register SV *sv, register FILE *fp, I32 append)
{
+ dTHR;
char *rsptr;
STRLEN rslen;
register STDCHAR rslast;
}
+
SV *
-newRV_noinc(SV *ref)
+Perl_newRV_noinc(SV *ref)
{
register SV *sv;
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';
*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",
#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;})
#endif
#define SvREFCNT_dec(sv) sv_free((SV*)sv)
-#endif
#define SVTYPEMASK 0xff
#define SvTYPE(sv) ((sv)->sv_flags & SVTYPEMASK)
? 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 */
void
taint_proper(const char *f, char *s)
{
+ dTHR; /* just for taint */
char *ug;
DEBUG_u(PerlIO_printf(Perl_debug_log,
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}");
}
/* 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;
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);
}
/* 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;
#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
#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)
(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". */
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)
static void xstat _((void));
#endif
+#ifdef USE_THREADS
+static U32 threadnum = 0;
+#endif /* USE_THREADS */
+
#ifndef MYMALLOC
/* paranoid version of malloc */
* 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;
# 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
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
projects / p5sagit/p5-mst-13.2.git / commitdiff