#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;
- init_stacks(ARGS);
- curcop = savethread->Tcurcop; /* XXX As good a guess as any? */
+ 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));
croak("panic: sigprocmask");
#endif
sv = newSViv(thr->tid);
- sv_magic(sv, oursv, '~', 0, 0);
+ sv_magic(sv, thr->oursv, '~', 0, 0);
SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
- return sv_bless(newRV_noinc(sv), gv_stashpv(class, TRUE));
+ return sv_bless(newRV_noinc(sv), gv_stashpv(Class, TRUE));
+#else
+ croak("No threads in this perl");
+ return &sv_undef;
+#endif
}
+static Signal_t handle_thread_signal _((int sig));
+
static Signal_t
-handle_thread_signal(sig)
-int sig;
+handle_thread_signal(int sig)
{
char c = (char) sig;
write(sig_pipe[0], &c, 1);
flags(t)
Thread t
PPCODE:
+#ifdef USE_THREADS
PUSHs(sv_2mortal(newSViv(t->flags)));
+#endif
void
-self(class)
- char * class
+self(Class)
+ char * Class
PREINIT:
SV *sv;
- PPCODE:
+ PPCODE:
+#ifdef USE_THREADS
sv = newSViv(thr->tid);
- sv_magic(sv, oursv, '~', 0, 0);
+ sv_magic(sv, thr->oursv, '~', 0, 0);
SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
- PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv), gv_stashpv(class, TRUE))));
+ PUSHs(sv_2mortal(sv_bless(newRV_noinc(sv), gv_stashpv(Class, TRUE))));
+#endif
U32
tid(t)
pad_reset_pending = FALSE;
}
+ #ifdef USE_THREADS
+ /* find_thread_magical is not reentrant */
+ PADOFFSET
-find_thread_magical(name)
-char *name;
++find_thread_magical(char *name)
+ {
+ dTHR;
+ char *p;
+ PADOFFSET key;
+ SV **svp;
+ /* We currently only handle single character magicals */
+ p = strchr(per_thread_magicals, *name);
+ if (!p)
+ return NOT_IN_PAD;
+ key = p - per_thread_magicals;
+ svp = av_fetch(thr->magicals, key, FALSE);
+ if (!svp) {
+ SV *sv = NEWSV(0, 0);
+ av_store(thr->magicals, key, sv);
+ /*
+ * Some magic variables used to be automagically initialised
+ * in gv_fetchpv. Those which are now per-thread magicals get
+ * initialised here instead.
+ */
+ switch (*name) {
+ case ';':
+ sv_setpv(sv, "\034");
+ break;
+ }
+ 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) ? "^" : "",
+ (*name < 32) ? toCTRL(*name) : *name));
+ }
+ return key;
+ }
+ #endif /* USE_THREADS */
+
/* Destructor */
void
}
OP *
-jmaybe(o)
-OP *o;
+jmaybe(OP *o)
{
if (o->op_type == OP_LIST) {
- o = convert(OP_JOIN, 0,
- prepend_elem(OP_LIST,
- newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
- o));
+ OP *o2;
+ #ifdef USE_THREADS
+ o2 = newOP(OP_SPECIFIC, 0);
+ o2->op_targ = find_thread_magical(";");
+ #else
+ o2 = newSVREF(newGVOP(OP_GV, 0, gv_fetchpv(";", TRUE, SVt_PV))),
+ #endif /* USE_THREADS */
+ o = convert(OP_JOIN, 0, prepend_elem(OP_LIST, o2, o));
}
return o;
}
return cv;
}
- #ifdef DEPRECATED
- CV *
- newXSUB(name, ix, subaddr, filename)
- char *name;
- I32 ix;
- I32 (*subaddr)();
- char *filename;
- {
- CV* cv = newXS(name, (void(*)())subaddr, filename);
- CvOLDSTYLE_on(cv);
- CvXSUBANY(cv).any_i32 = ix;
- return cv;
- }
- #endif
-
-V *
-newXS(name, subaddr, filename)
-char *name;
-void (*subaddr) _((CV*));
-char *filename;
+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);
/* 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->magicals, find_thread_magical("/"), FALSE), rs);
+ #else
sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
-#endif /* USE_THREADS */
+
if (do_undump)
my_unexec();
GV *tmpgv;
GV *othergv;
+ #ifdef USE_THREADS
+ 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);
SvREFCNT_dec(subdir);
}
+ #ifdef USE_THREADS
+ static struct thread *
+ init_main_thread()
+ {
+ struct thread *thr;
+ XPV *xpv;
+
+ Newz(53, thr, 1, struct thread);
+ curcop = &compiling;
+ thr->cvcache = newHV();
+ thr->magicals = newAV();
+ thr->specific = newAV();
+ thr->flags = THRf_R_JOINABLE;
+ MUTEX_INIT(&thr->mutex);
+ /* 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 */
+ thr->oursv = thrsv;
+ curcop = &compiling;
+ chopset = " \n-";
+
+ MUTEX_LOCK(&threads_mutex);
+ nthreads++;
+ thr->tid = 0;
+ 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);
+
+ /*
+ * 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;
+ }
+ #endif /* USE_THREADS */
+
void
-call_list(oldscope, list)
-I32 oldscope;
-AV* list;
+call_list(I32 oldscope, AV *list)
{
dTHR;
line_t oldline = curcop->cop_line;
RETURN;
}
-
+ PP(pp_specific)
+ {
+ #ifdef USE_THREADS
- dSP;
++ djSP;
+ SV **svp = av_fetch(thr->magicals, op->op_targ, FALSE);
+ if (!svp)
+ croak("panic: pp_specific");
+ EXTEND(sp, 1);
+ if (op->op_private & OPpLVAL_INTRO)
+ PUSHs(save_svref(svp));
+ else
+ PUSHs(*svp);
+ #else
+ DIE("tried to access thread-specific data in non-threaded perl");
+ #endif /* USE_THREADS */
+ RETURN;
+ }
RETURNOP(cLOGOP->op_other);
}
- #ifdef DEPRECATED
- PP(pp_entersubr)
- {
- djSP;
- SV** mark = (stack_base + *markstack_ptr + 1);
- SV* cv = *mark;
- while (mark < sp) { /* emulate old interface */
- *mark = mark[1];
- mark++;
- }
- *sp = cv;
- return pp_entersub(ARGS);
- }
- #endif
-
PP(pp_caller)
{
- dSP;
+ djSP;
register I32 cxix = dopoptosub(cxstack_ix);
register CONTEXT *cx;
I32 dbcxix;
#define SvANY(sv) (sv)->sv_any
#define SvFLAGS(sv) (sv)->sv_flags
-#define SvREFCNT(sv) (sv)->sv_refcnt
- #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); if(nsv) ++SvREFCNT(nsv); nsv;})
#else
- #define SvREFCNT_inc(sv) ((Sv = (SV*)(sv)), \
- (Sv && ++SvREFCNT(Sv)), (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)), (Sv && ++SvREFCNT(Sv)), (SV*)Sv)
+ # endif
+ #endif
+
#define SvREFCNT_dec(sv) sv_free((SV*)sv)
+#endif
#define SVTYPEMASK 0xff
#define SvTYPE(sv) ((sv)->sv_flags & SVTYPEMASK)
$| = 1;
--if ($#ARGV >= 0 && $ARGV[0] eq '-v') {
++if ($ARGV[0] eq '-v') {
$verbose = 1;
shift;
}
chdir 't' if -f 't/TEST';
--die "You need to run \"make test\" first to set things up.\n"
++die "You need to run \"make test\" first to set things up.\n"
unless -e 'perl' or -e 'perl.exe';
$ENV{EMXSHELL} = 'sh'; # For OS/2
--if ($#ARGV == -1) {
-- @ARGV = split(/[ \n]/,
-- `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`);
++if ($ARGV[0] eq '') {
++ push( @ARGV, `dir/s/b base` );
++ push( @ARGV, `dir/s/b comp` );
++ push( @ARGV, `dir/s/b cmd` );
++ push( @ARGV, `dir/s/b io` );
++ push( @ARGV, `dir/s/b op` );
++ push( @ARGV, `dir/s/b pragma` );
++ push( @ARGV, `dir/s/b lib` );
++
++ grep( chomp, @ARGV );
++ @ARGV = grep( /\.t$/, @ARGV );
++ grep( s/.*t\\//, @ARGV );
++# @ARGV = split(/[ \n]/,
++# `echo base/*.t comp/*.t cmd/*.t io/*.t; echo op/*.t pragma/*.t lib/*.t`);
++} else {
++
++@ARGV = map(glob($_),@ARGV);
++
}
--if ($^O eq 'os2' || $^O eq 'qnx') {
++if ($^O eq 'os2' || $^O eq 'MSWin32' || $^O eq 'qnx' || 1) {
$sharpbang = 0;
}
else {
$bad = 0;
$good = 0;
$total = @ARGV;
--$files = 0;
--$totmax = 0;
while ($test = shift) {
if ($test =~ /^$/) {
next;
chop($te);
print "$te" . '.' x (18 - length($te));
if ($sharpbang) {
-- -x $test || (print "isn't executable.\n");
-- open(RESULTS,"./$test |") || (print "can't run.\n");
++ open(results,"./$test |") || (print "can't run.\n");
} else {
-- open(SCRIPT,"$test") || die "Can't run $test.\n";
-- $_ = <SCRIPT>;
-- close(SCRIPT);
++ open(script,"$test") || die "Can't run $test.\n";
++ $_ = <script>;
++ close(script);
if (/#!..perl(.*)/) {
$switch = $1;
if ($^O eq 'VMS') {
} else {
$switch = '';
}
-- open(RESULTS,"./perl$switch $test |") || (print "can't run.\n");
++ open(results,"perl$switch $test |") || (print "can't run.\n");
}
$ok = 0;
$next = 0;
-- while (<RESULTS>) {
++ while (<results>) {
++ if (/^$/) { next;};
if ($verbose) {
print $_;
}
}
} else {
$next += 1;
-- print "FAILED at test $next\n";
++ print "FAILED on test $next\n";
$bad = $bad + 1;
$_ = $test;
if (/^base/) {
if ($bad == 0) {
if ($ok) {
print "All tests successful.\n";
-- # XXX add mention of 'perlbug -ok' ?
} else {
die "FAILED--no tests were run for some reason.\n";
}
### of them individually and examine any diagnostic messages they
### produce. See the INSTALL document's section on "make test".
SHRDLU
-- warn <<'SHRDLU' if $good / $total > 0.8;
-- ###
-- ### Since most tests were successful, you have a good chance to
-- ### get information with better granularity by running
-- ### ./perl harness
-- ### in directory ./t.
--SHRDLU
}
($user,$sys,$cuser,$csys) = times;
print sprintf("u=%g s=%g cu=%g cs=%g scripts=%d tests=%d\n",
$user,$sys,$cuser,$csys,$files,$totmax);
--exit ($bad != 0);
++exit $bad != 0;
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])
+ if (!strchr(tokenbuf,':')) {
+ #ifdef USE_THREADS
+ /* Check for single character per-thread magicals */
+ if (tokenbuf[0] == '$' && tokenbuf[2] == '\0'
+ && !isALPHA(tokenbuf[1]) /* Rule out obvious non-magicals */
+ && (tmp = find_thread_magical(&tokenbuf[1])) != NOT_IN_PAD)
{
- for (d = in_eval ? oldoldbufptr : linestart;
- d < bufend && *d != '\n';
- d++)
+ 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])
{
- 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);
- }
+ 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". */
projects / p5sagit/p5-mst-13.2.git / commitdiff