and the associated new OP_SPECIFIC and find_thread_magical stuff.
perl will compile but plenty of the magicals are still broken.
p4raw-id: //depot/perl@195
do_chomp(sv)
register SV *sv;
{
+ dTHR;
register I32 count;
STRLEN len;
char *s;
SV *left;
SV *right;
{
+ dTHR; /* just for taint */
#ifdef LIBERAL
register long *dl;
register long *ll;
#define inc_amg Perl_inc_amg
#define ingroup Perl_ingroup
#define init_stacks Perl_init_stacks
+#define init_thread_intern Perl_init_thread_intern
#define instr Perl_instr
#define intro_my Perl_intro_my
#define intuit_more Perl_intuit_more
#define invert Perl_invert
#define io_close Perl_io_close
#define jmaybe Perl_jmaybe
+#define key_create Perl_key_create
+#define key_destroy Perl_key_destroy
#define keyword Perl_keyword
#define know_next Perl_know_next
#define last_lop Perl_last_lop
#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 nomemok Perl_nomemok
#define nomethod_amg Perl_nomethod_amg
#define not_amg Perl_not_amg
+#define nthreads Perl_nthreads
#define numer_amg Perl_numer_amg
#define numeric_local Perl_numeric_local
#define numeric_name Perl_numeric_name
#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 taint_env Perl_taint_env
#define taint_proper Perl_taint_proper
#define thisexpr Perl_thisexpr
+#define thr_key Perl_thr_key
#define timesbuf Perl_timesbuf
#define tokenbuf Perl_tokenbuf
#define too_few_arguments Perl_too_few_arguments
#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 incgv (curinterp->Iincgv)
#define initav (curinterp->Iinitav)
#define inplace (curinterp->Iinplace)
+#define keys (curinterp->Ikeys)
+#define keys_mutex (curinterp->Ikeys_mutex)
#define last_in_gv (curinterp->Ilast_in_gv)
#define lastfd (curinterp->Ilastfd)
#define lastretstr (curinterp->Ilastretstr)
#define lineary (curinterp->Ilineary)
#define localizing (curinterp->Ilocalizing)
#define localpatches (curinterp->Ilocalpatches)
+#define magical_keys (curinterp->Imagical_keys)
#define main_cv (curinterp->Imain_cv)
#define main_root (curinterp->Imain_root)
#define main_start (curinterp->Imain_start)
#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 Iincgv incgv
#define Iinitav initav
#define Iinplace inplace
+#define Ikeys keys
+#define Ikeys_mutex keys_mutex
#define Ilast_in_gv last_in_gv
#define Ilastfd lastfd
#define Ilastretstr lastretstr
#define Ilineary lineary
#define Ilocalizing localizing
#define Ilocalpatches localpatches
+#define Imagical_keys magical_keys
#define Imain_cv main_cv
#define Imain_root main_root
#define Imain_start main_start
#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
#define incgv Perl_incgv
#define initav Perl_initav
#define inplace Perl_inplace
+#define keys Perl_keys
+#define keys_mutex Perl_keys_mutex
#define last_in_gv Perl_last_in_gv
#define lastfd Perl_lastfd
#define lastretstr Perl_lastretstr
#define lineary Perl_lineary
#define localizing Perl_localizing
#define localpatches Perl_localpatches
+#define magical_keys Perl_magical_keys
#define main_cv Perl_main_cv
#define main_root Perl_main_root
#define main_start Perl_main_start
#endif
savethread = thr;
- sv = newSVpv("", 0);
- SvGROW(sv, sizeof(struct thread) + 1);
- SvCUR_set(sv, sizeof(struct thread));
- thr = (Thread) SvPVX(sv);
- DEBUG_L(PerlIO_printf(PerlIO_stderr(), "%p: newthread(%s) = %p)\n",
- savethread, SvPEEK(startsv), thr));
- oursv = sv;
- /* If we don't zero these foostack pointers, init_stacks won't init them */
- markstack = 0;
- scopestack = 0;
- savestack = 0;
- retstack = 0;
+ thr = new_struct_thread(thr);
init_stacks(ARGS);
- curcop = savethread->Tcurcop; /* XXX As good a guess as any? */
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));
in_my_stash
inc_amg
io_close
+key_create
+key_destroy
know_next
last_lop
last_lop_op
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
incgv
initav
inplace
+keys
+keys_mutex
last_in_gv
lastfd
lastretstr
lineary
localizing
localpatches
+magical_keys
main_cv
main_root
main_start
SV *sv;
MAGIC *mg;
{
+ dTHR;
register I32 paren;
register char *s;
register I32 i;
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 */
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;
}
warn("Variable \"%s\" will not stay shared", name);
}
}
- av_store(comppad, newoff, SvREFCNT_inc(oldsv));
+ av_store(comppad, newoff, oldsv ? SvREFCNT_inc(oldsv) : 0);
return newoff;
}
}
pad_reset_pending = FALSE;
}
+#ifdef USE_THREADS
+PADOFFSET
+find_thread_magical(name)
+char *name;
+{
+ dTHR;
+ char *p;
+ PADOFFSET key;
+ /* We currently only handle single character magicals */
+ p = strchr(per_thread_magicals, *name);
+ if (!p)
+ return NOT_IN_PAD;
+ key = magical_keys[p - per_thread_magicals];
+ if (key == NOT_IN_PAD) {
+ SV *sv;
+ key = magical_keys[p - per_thread_magicals] = key_create();
+ sv = NEWSV(0, 0);
+ av_store(thr->specific, key, sv);
+ sv_magic(sv, 0, 0, name, 1);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+ "find_thread_magical: key %d new SV %p for %d\n",
+ (int)key, sv, (int)*name));
+ }
+ return key;
+}
+#endif /* USE_THREADS */
+
/* Destructor */
void
goto nomod;
/* FALL THROUGH */
case OP_PADSV:
+ case OP_SPECIFIC:
modcount++;
if (!type)
croak("Can't localize lexical variable %s",
}
break;
+ case OP_SPECIFIC:
+ o->op_flags |= OPf_MOD; /* XXX ??? */
+ break;
+
case OP_RV2AV:
case OP_RV2HV:
o->op_flags |= OPf_REF;
else if (curop->op_type == OP_PADSV ||
curop->op_type == OP_PADAV ||
curop->op_type == OP_PADHV ||
- curop->op_type == OP_PADANY) {
+ curop->op_type == OP_PADANY ||
+ curop->op_type == OP_SPECIFIC) {
/* is okay */
}
else
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));
}
}
}
o->op_ppaddr = ppaddr[OP_PADSV];
return o;
}
+ else if (o->op_type == OP_SPECIFIC)
+ return o;
return newUNOP(OP_RV2SV, 0, scalar(o));
}
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));
#ifndef DOINIT
EXT OP * (*ppaddr[])();
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
$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
perl_construct( sv_interp )
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);
+ if (pthread_key_create(&thr_key, 0))
+ croak("panic: pthread_key_create");
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);
COND_INIT(&nthreads_cond);
- nthreads = 1;
- cvcache = newHV();
- curcop = &compiling;
- thr->flags = THRf_R_JOINABLE;
- MUTEX_INIT(&thr->mutex);
- thr->next = thr;
- thr->prev = thr;
- thr->tid = 0;
-
- /* Handcraft thrsv similarly to mess_sv */
- New(53, thrsv, 1, SV);
- Newz(53, xpv, 1, XPV);
- SvFLAGS(thrsv) = SVt_PV;
- SvANY(thrsv) = (void*)xpv;
- SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
- SvPVX(thrsv) = (char*)thr;
- SvCUR_set(thrsv, sizeof(thr));
- SvLEN_set(thrsv, sizeof(thr));
- *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
- oursv = thrsv;
-#ifdef HAVE_THREAD_INTERN
- init_thread_intern(thr);
-#else
- thr->self = pthread_self();
- if (pthread_key_create(&thr_key, 0))
- croak("panic: pthread_key_create");
-#endif /* HAVE_THREAD_INTERN */
- SET_THR(thr);
+ MUTEX_INIT(&keys_mutex);
+
+ thr = new_struct_thread(0);
#endif /* USE_THREADS */
linestr = NEWSV(65,80);
fdpid = newAV(); /* for remembering popen pids by fd */
+ for (i = 0; i < N_PER_THREAD_MAGICALS; i++)
+ magical_keys[i] = NOT_IN_PAD;
+ keys = newSVpv("", 0);
init_stacks(ARGS);
DEBUG( {
New(51,debname,128,char);
envgv = Nullgv;
siggv = Nullgv;
incgv = Nullgv;
- errgv = Nullgv;
+ errhv = Nullhv;
+ errsv = Nullsv;
argvgv = Nullgv;
argvoutgv = Nullgv;
stdingv = Nullgv;
/* now that script is parsed, we can modify record separator */
SvREFCNT_dec(rs);
rs = SvREFCNT_inc(nrs);
+#ifdef USE_THREADS
+ sv_setsv(*av_fetch(thr->specific, find_thread_magical("/"), TRUE), 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));
GV *tmpgv;
GV *othergv;
+#ifdef USE_THREADS
+ sv_setpvn(*av_fetch(thr->specific,find_thread_magical("\""),TRUE), " ", 1);
+#else
sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
+#endif /* USE_THREADS */
stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
GvMULTI_on(stdingv);
register char **argv;
register char **env;
{
+ dTHR;
char *s;
SV *sv;
GV* tmpgv;
JMPENV_PUSH(ret);
switch (ret) {
case 0: {
- SV* atsv = GvSV(errgv);
+ SV* atsv = sv_mortalcopy(errsv);
PUSHMARK(stack_sp);
perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
(void)SvPV(atsv, len);
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:
int runops_debug _((void));
#endif
+#define PER_THREAD_MAGICALS "123456789&`'+/.,\\\";^-%=|~:\001\005!@"
+#define N_PER_THREAD_MAGICALS 30
+
/****************/
/* Truly global */
/****************/
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;
#ifdef USE_THREADS
/* threads stuff */
IEXT SV * Ithrsv; /* holds struct thread for main thread */
+IEXT perl_mutex Ikeys_mutex; /* protects keys and magical_keys */
+IEXT SV * Ikeys; /* each char marks a per-thread key in-use */
+IEXT PADOFFSET Imagical_keys[N_PER_THREAD_MAGICALS];
+ /* index is position in per_thread_magicals */
#endif /* USE_THREADS */
#undef IEXT
else if (SvPADTMP(sv))
sv = newSVsv(sv);
else {
- dTHR; /* just for SvREFCNT_inc */
SvTEMP_off(sv);
(void)SvREFCNT_inc(sv);
}
SETs(retsv);
RETURN;
}
+
+PP(pp_specific)
+{
+#ifdef USE_THREADS
+ dSP;
+ SV **svp = av_fetch(thr->specific, op->op_targ, TRUE);
+ XPUSHs(svp ? *svp : &sv_undef);
+#else
+ DIE("tried to access thread-specific data in non-threaded perl");
+#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();
CvPADLIST(compcv) = comppadlist;
if (saveop->op_type != OP_REQUIRE)
- CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(caller);
+ CvOUTSIDE(compcv) = caller ? (CV*)SvREFCNT_inc(caller) : 0;
SAVEFREESV(compcv);
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";
OP* invert _((OP* cmd));
OP* jmaybe _((OP* arg));
I32 keyword _((char* d, I32 len));
+PADOFFSET key_create _((void));
+void key_destroy _((PADOFFSET key));
void leave_scope _((I32 base));
void lex_end _((void));
void lex_start _((SV* line));
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));
register SV *sv;
IV i;
{
+ dTHR; /* just for taint */
sv_check_thinkfirst(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
register SV *sv;
double num;
{
+ dTHR; /* just for taint */
sv_check_thinkfirst(sv);
switch (SvTYPE(sv)) {
case SVt_NULL:
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);
register SV *sv;
register const char *ptr;
{
+ dTHR; /* just for taint */
register STRLEN len;
sv_check_thinkfirst(sv);
register char *ptr;
register STRLEN len;
{
+ dTHR; /* just for taint */
sv_check_thinkfirst(sv);
if (!SvUPGRADE(sv, SVt_PV))
return;
register char *ptr;
register STRLEN len;
{
+ dTHR; /* just for taint */
STRLEN tlen;
char *junk;
register SV *sv;
register char *ptr;
{
+ dTHR; /* just for taint */
register STRLEN len;
STRLEN tlen;
char *junk;
register PerlIO *fp;
I32 append;
{
+ dTHR;
char *rsptr;
STRLEN rslen;
register STDCHAR rslast;
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 CRIPPLED_CC
-#define SvREFCNT_inc(sv) sv_newref((SV*)sv)
-#define SvREFCNT_dec(sv) sv_free((SV*)sv)
+
+#ifdef __GNUC__
+# define SvREFCNT_inc(sv) ({SV *nsv = (SV*)(sv); ++SvREFCNT(nsv); nsv;})
#else
-#define SvREFCNT_inc(sv) ((Sv = (SV*)(sv)), \
- (Sv && ++SvREFCNT(Sv)), (SV*)Sv)
-#define SvREFCNT_dec(sv) sv_free((SV*)sv)
+# if defined(CRIPPLED_CC) || defined(USE_THREADS)
+# define SvREFCNT_inc(sv) sv_newref((SV*)sv)
+# else
+# define SvREFCNT_inc(sv) ((Sv = (SV*)(sv)), ++SvREFCNT(Sv), (SV*)Sv)
+# endif
#endif
+#define SvREFCNT_dec(sv) sv_free((SV*)sv)
+
#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)
-#ifdef CRIPPLED_CC
-SV *newRV_noinc _((SV *));
+#ifdef __GNUC__
+# define newRV_noinc(sv) ({SV *nsv=newRV((sv)); --SvREFCNT(SvRV(nsv)); nsv;})
#else
-#define newRV_noinc(sv) ((Sv = newRV(sv)), --SvREFCNT(SvRV(Sv)), Sv)
-#endif
+# if defined(CRIPPLED_CC) || defined(USE_THREADS)
+SV *newRV_noinc _((SV *));
+# else
+# 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 */
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;
HV * Tcvcache;
perl_thread self; /* Underlying thread object */
U32 flags;
+ AV * specific; /* Thread specific data (& magicals) */
perl_mutex mutex; /* For the fields others can change */
U32 tid;
struct thread *next, *prev; /* Circular linked list of threads */
#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 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)
return PRIVATEREF;
}
- if (!strchr(tokenbuf,':')
- && (tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
- if (last_lop_op == OP_SORT &&
- tokenbuf[0] == '$' &&
- (tokenbuf[1] == 'a' || tokenbuf[1] == 'b')
- && !tokenbuf[2])
- {
- for (d = in_eval ? oldoldbufptr : linestart;
- d < bufend && *d != '\n';
- d++)
+ if (!strchr(tokenbuf,':')) {
+#ifdef USE_THREADS
+ /* Check for single character per-thread magicals */
+ if (tokenbuf[0] == '$' && tokenbuf[2] == '\0'
+ && (tmp = find_thread_magical(&tokenbuf[1])) != NOT_IN_PAD) {
+ yylval.opval = newOP(OP_SPECIFIC, 0);
+ yylval.opval->op_targ = tmp;
+ return PRIVATEREF;
+ }
+#endif /* USE_THREADS */
+ if ((tmp = pad_findmy(tokenbuf)) != NOT_IN_PAD) {
+ if (last_lop_op == OP_SORT &&
+ tokenbuf[0] == '$' &&
+ (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 */
}
return mg;
}
+
+/*
+ * Make a new perl thread structure using t as a prototype. If t is NULL
+ * then this is the initial main thread and we have to bootstrap carefully.
+ * Some of the fields for the new thread are copied from the prototype
+ * thread, t, so t should not be running in perl at the time this function
+ * is called. The usual case, where t is the thread calling new_struct_thread,
+ * clearly satisfies this constraint.
+ */
+struct thread *
+new_struct_thread(t)
+struct thread *t;
+{
+ struct thread *thr;
+ XPV *xpv;
+ SV *sv;
+
+ Newz(53, thr, 1, struct thread);
+ cvcache = newHV();
+ curcop = &compiling;
+ thr->specific = newAV();
+ thr->flags = THRf_R_JOINABLE;
+ MUTEX_INIT(&thr->mutex);
+ if (t) {
+ oursv = newSVpv("", 0);
+ SvGROW(oursv, sizeof(struct thread) + 1);
+ SvCUR_set(oursv, sizeof(struct thread));
+ thr = (struct thread *) SvPVX(sv);
+ } else {
+ /* Handcraft thrsv similarly to mess_sv */
+ New(53, thrsv, 1, SV);
+ Newz(53, xpv, 1, XPV);
+ SvFLAGS(thrsv) = SVt_PV;
+ SvANY(thrsv) = (void*)xpv;
+ SvREFCNT(thrsv) = 1 << 30; /* practically infinite */
+ SvPVX(thrsv) = (char*)thr;
+ SvCUR_set(thrsv, sizeof(thr));
+ SvLEN_set(thrsv, sizeof(thr));
+ *SvEND(thrsv) = '\0'; /* in the trailing_nul field */
+ oursv = thrsv;
+ }
+ if (t) {
+ curcop = t->Tcurcop; /* XXX As good a guess as any? */
+ defstash = t->Tdefstash; /* XXX maybe these should */
+ curstash = t->Tcurstash; /* always be set to main? */
+ /* top_env? */
+ /* runlevel */
+ tainted = t->Ttainted;
+ curpm = t->Tcurpm; /* XXX No PMOP ref count */
+ nrs = newSVsv(t->Tnrs);
+ rs = newSVsv(t->Trs);
+ last_in_gv = (GV*)SvREFCNT_inc(t->Tlast_in_gv);
+ ofslen = t->Tofslen;
+ ofs = savepvn(t->Tofs, ofslen);
+ defoutgv = (GV*)SvREFCNT_inc(t->Tdefoutgv);
+ chopset = t->Tchopset;
+ formtarget = newSVsv(t->Tformtarget);
+ bodytarget = newSVsv(t->Tbodytarget);
+ toptarget = newSVsv(t->Ttoptarget);
+ keys = newSVpv("", 0);
+ } else {
+ curcop = &compiling;
+ chopset = " \n-";
+ }
+ MUTEX_LOCK(&threads_mutex);
+ nthreads++;
+ thr->tid = threadnum++;
+ if (t) {
+ thr->next = t->next;
+ thr->prev = t;
+ t->next = thr;
+ thr->next->prev = thr;
+ } else {
+ thr->next = thr;
+ thr->prev = thr;
+ }
+ MUTEX_UNLOCK(&threads_mutex);
+
+#ifdef HAVE_THREAD_INTERN
+ init_thread_intern(thr);
+#else
+ thr->self = pthread_self();
+#endif /* HAVE_THREAD_INTERN */
+ SET_THR(thr);
+ if (!t) {
+ /*
+ * These must come after the SET_THR because sv_setpvn does
+ * SvTAINT and the taint fields require dTHR.
+ */
+ toptarget = NEWSV(0,0);
+ sv_upgrade(toptarget, SVt_PVFM);
+ sv_setpvn(toptarget, "", 0);
+ bodytarget = NEWSV(0,0);
+ sv_upgrade(bodytarget, SVt_PVFM);
+ sv_setpvn(bodytarget, "", 0);
+ formtarget = bodytarget;
+ }
+ return thr;
+}
+
+PADOFFSET
+key_create()
+{
+ char *s;
+ STRLEN len;
+ PADOFFSET i;
+ MUTEX_LOCK(&keys_mutex);
+ s = SvPV(keys, len);
+ for (i = 0; i < len; i++) {
+ if (!s[i]) {
+ s[i] = 1;
+ break;
+ }
+ }
+ if (i == len)
+ sv_catpvn(keys, "\1", 1);
+ MUTEX_UNLOCK(&keys_mutex);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "key_create: %d\n", (int)i));
+ return i;
+}
+
+void
+key_destroy(key)
+PADOFFSET key;
+{
+ char *s;
+ MUTEX_LOCK(&keys_mutex);
+ s = SvPVX(keys);
+ s[key] = 0;
+ MUTEX_UNLOCK(&keys_mutex);
+ DEBUG_L(PerlIO_printf(PerlIO_stderr(), "key_destroy: %d\n", (int)key));
+}
#endif /* USE_THREADS */
#ifdef HUGE_VAL
projects / p5sagit/p5-mst-13.2.git / commitdiff