Raw integrate of latest perl

p4raw-id: //depot/ansiperl@208

19 files changed, 408 insertions, 175 deletions

diff --git a/README.threads b/README.threads
index 014eed833a..69bddca5a8 100644
--- a/README.threads
+++ b/README.threads
@@ -47,17 +47,44 @@ Now you can do a
     make
 
 
+O/S specific bugs
+
+Solaris qsort uses a hidden mutex for synchronisation. If you die()
+while doing a sort() then the resulting longjmp() leaves the mutex
+locked so you get a deadlock the next time you try to sort().
+
+LinuxThreads 0.5 has a bug which can cause file descriptor 0 to be
+closed after a fork() leading to many strange symptoms. The
+development version of LinuxThreads has this fixed but the following
+patch can be applied to 0.5 for now:
+
+----------------------------- cut here -----------------------------
+--- linuxthreads-0.5/pthread.c.ORI	Mon Oct  6 13:55:50 1997
++++ linuxthreads-0.5/pthread.c	Mon Oct  6 13:57:24 1997
+@@ -312,8 +312,10 @@
+   free(pthread_manager_thread_bos);
+   pthread_manager_thread_bos = pthread_manager_thread_tos = NULL;
+   /* Close the two ends of the pipe */
+-  close(pthread_manager_request);
+-  close(pthread_manager_reader);
++  if (pthread_manager_request >= 0) {
++    close(pthread_manager_request);
++    close(pthread_manager_reader);
++  }
+   pthread_manager_request = pthread_manager_reader = -1;
+   /* Update the pid of the main thread */
+   self->p_pid = getpid();
+----------------------------- cut here -----------------------------
+
+
 Building the Thread extension
 
-Build it away from the perl tree in the usual way. Set your PATH
-environment variable to have your perl build directory first and
-set PERL5LIB to be /your/perl/build/directory/lib (without those,
-I had problems where the config information from the ordinary perl
-on the system would end up in the Makefile). Then
-    perl Makefile.PL PERL_SRC=/your/perl/build/directory
-    make
+The Thread extension is now part of the main perl distribution tree.
+If you did Configure -Dusethreads then it will have been added to
+the list of extensions automatically.
 
-Then you can try some of the tests with
+You can try some of the tests with
+    cd ext/Thread
     perl -Mblib create.t
     perl -Mblib join.t
     perl -Mblib lock.t
@@ -70,11 +97,10 @@ The io one leaves a thread reading from the keyboard on stdin so
 as the ping messages appear you can type lines and see them echoed.
 
 Try running the main perl test suite too. There are known
-failures for po/misc test 45 (tries to do local(@_) but @_ is
-now lexical) and some tests involving backticks/system/fork
-may or may not work. Under Linux, many tests may appear to fail
-when run under the test harness but work fine when invoked
-manually.
+failures for op/misc test 45 (tries to do local(@_) but @_ is
+now lexical) and for some of the DBM/DB extensions (if there
+underlying libraries were not compiled to be thread-aware).
+may or may not work.
 
 
 Bugs
@@ -88,7 +114,7 @@ extension won't build with it yet.
 of each thread because it causes refcount problems that I
 haven't tracked down yet) and there are very probably others too.
 
-* There are still races where bugs show up under contention.
+* There may still be races where bugs show up under contention.
 
 * Need to document "lock", Thread.pm, Queue.pm, ...
 
@@ -111,8 +137,8 @@ Background
 
 Some old globals (e.g. stack_sp, op) and some old per-interpreter
 variables (e.g. tmps_stack, cxstack) move into struct thread.
-All fields of struct thread (apart from a few only applicable to
-FAKE_THREADS) are of the form Tfoo. For example, stack_sp becomes
+All fields of struct thread which derived from original perl
+variables have names of the form Tfoo. For example, stack_sp becomes
 the field Tstack_sp of struct thread. For those fields which moved
 from original perl, thread.h does
     #define foo (thr->Tfoo)
@@ -140,10 +166,16 @@ variables are implemented as a list of waiting threads.
 Mutexes and condition variables
 
 The API is via macros MUTEX_{INIT,LOCK,UNLOCK,DESTROY} and
-COND_{INIT,WAIT,SIGNAL,BROADCAST,DESTROY}. For POSIX threads,
-perl mutexes and condition variables correspond to POSIX ones.
-For FAKE_THREADS, mutexes are stubs and condition variables are
-implmented as lists of waiting threads. For FAKE_THREADS, a thread
+COND_{INIT,WAIT,SIGNAL,BROADCAST,DESTROY}.
+
+A mutex is only required to be a simple, fast mutex (e.g. it does not
+have to be recursive). It is only ever held across very short pieces
+of code. Condition variables are only ever signalled/broadcast while
+their associated mutex is held. (This constraint simplifies the
+implementation of condition variables in certain porting situations.)
+For POSIX threads, perl mutexes and condition variables correspond to
+POSIX ones.  For FAKE_THREADS, mutexes are stubs and condition variables
+are implmented as lists of waiting threads. For FAKE_THREADS, a thread
 waits on a condition variable by removing itself from the runnable
 list, calling SCHEDULE to change thr to the next appropriate
 runnable thread and returning op (i.e. the new threads next op).
@@ -202,4 +234,4 @@ ZOMBIE ----------------------------> DEAD
 
 Malcolm Beattie
 mbeattie@sable.ox.ac.uk
-2 October 1997
+6 November 1997
diff --git a/Todo.5.005 b/Todo.5.005
index e4140b899a..743e597873 100644
--- a/Todo.5.005
+++ b/Todo.5.005
@@ -6,10 +6,6 @@ Multi-threading
     without USE_THREADS, change extern variable for dTHR
     consistent semantics for exit/die in threads
     SvREFCNT_dec(curstack) in threadstart() in Thread.xs
-    $@ and other magic globals:
-	global pseudo-lexical pad with auto-binding for magicals
-	move magicals that should be per-thread into thread.h
-	sv_magic for the necessary global pad entries
     Thread::Pool
     more Configure support
 
diff --git a/embed.h b/embed.h
index c458b50ad2..c5cb02c231 100644
--- a/embed.h
+++ b/embed.h
@@ -820,6 +820,7 @@
 #define pp_socket		Perl_pp_socket
 #define pp_sockpair		Perl_pp_sockpair
 #define pp_sort			Perl_pp_sort
+#define pp_specific		Perl_pp_specific
 #define pp_splice		Perl_pp_splice
 #define pp_split		Perl_pp_split
 #define pp_sprintf		Perl_pp_sprintf
diff --git a/ext/Opcode/Opcode.pm b/ext/Opcode/Opcode.pm
index 1878417ceb..d2db5ecba4 100644
--- a/ext/Opcode/Opcode.pm
+++ b/ext/Opcode/Opcode.pm
@@ -429,9 +429,9 @@ beyond the scope of the compartment.
 
 =item :base_thread
 
-This op is related to multi-threading.
+These ops are related to multi-threading.
 
-    lock
+    lock specific
 
 =item :default
 
diff --git a/ext/Thread/Thread.xs b/ext/Thread/Thread.xs
index 6e7f4b7638..d132394689 100644
--- a/ext/Thread/Thread.xs
+++ b/ext/Thread/Thread.xs
@@ -129,6 +129,8 @@ threadstart(void *arg)
 	goto finishoff;
     }
 
+    CATCH_SET(TRUE);
+
     /* Now duplicate most of perl_call_sv but with a few twists */
     op = (OP*)&myop;
     Zero(op, 1, LOGOP);
@@ -156,13 +158,16 @@ threadstart(void *arg)
     /* removed for debug */
     SvREFCNT_dec(curstack);
 #endif
-    SvREFCNT_dec(cvcache);
+    SvREFCNT_dec(thr->cvcache);
+    SvREFCNT_dec(thr->magicals);
+    SvREFCNT_dec(thr->specific);
     Safefree(markstack);
     Safefree(scopestack);
     Safefree(savestack);
     Safefree(retstack);
     Safefree(cxstack);
     Safefree(tmps_stack);
+    Safefree(ofs);
 
     MUTEX_LOCK(&thr->mutex);
     DEBUG_L(PerlIO_printf(PerlIO_stderr(),
@@ -218,20 +223,7 @@ newthread (SV *startsv, AV *initargs, char *Class)
 #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? */
@@ -277,7 +269,7 @@ newthread (SV *startsv, AV *initargs, char *Class)
 #endif
     if (err) {
 	/* Thread creation failed--clean up */
-	SvREFCNT_dec(cvcache);
+	SvREFCNT_dec(thr->cvcache);
 	remove_thread(thr);
 	MUTEX_DESTROY(&thr->mutex);
 	for (i = 0; i <= AvFILL(initargs); i++)
@@ -292,7 +284,7 @@ newthread (SV *startsv, AV *initargs, char *Class)
 	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));
 #else
@@ -405,7 +397,7 @@ self(Class)
     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))));
 #endif
@@ -548,7 +540,7 @@ list(Class)
 	do {
 	    SV *sv = (SV*)SvRV(*svp);
 	    sv_setiv(sv, t->tid);
-	    SvMAGIC(sv)->mg_obj = SvREFCNT_inc(t->Toursv);
+	    SvMAGIC(sv)->mg_obj = SvREFCNT_inc(t->oursv);
 	    SvMAGIC(sv)->mg_flags |= MGf_REFCOUNTED;
 	    SvMAGIC(sv)->mg_private = Thread_MAGIC_SIGNATURE;
 	    t = t->next;
diff --git a/op.c b/op.c
index a0309dec3e..513a6507a5 100644
--- a/op.c
+++ b/op.c
@@ -495,6 +495,44 @@ pad_reset(void)
     pad_reset_pending = FALSE;
 }
 
+#ifdef USE_THREADS
+/* find_thread_magical is not reentrant */
+PADOFFSET
+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
@@ -519,6 +557,11 @@ op_free(OP *o)
     case OP_ENTEREVAL:
 	o->op_targ = 0;	/* Was holding hints. */
 	break;
+#ifdef USE_THREADS
+    case OP_SPECIFIC:
+	o->op_targ = 0;	/* Was holding index into thr->magicals AV. */
+	break;
+#endif /* USE_THREADS */
     default:
 	if (!(o->op_flags & OPf_REF) || (check[o->op_type] != ck_ftst))
 	    break;
@@ -1128,6 +1171,16 @@ mod(OP *o, I32 type)
 		SvPV(*av_fetch(comppad_name, o->op_targ, 4), na));
 	break;
 
+#ifdef USE_THREADS
+    case OP_SPECIFIC:
+	modcount++;	/* XXX ??? */
+#if 0
+	if (!type) 
+	    croak("Can't localize thread-specific variable");
+#endif
+	break;
+#endif /* USE_THREADS */
+
     case OP_PUSHMARK:
 	break;
 	
@@ -1531,10 +1584,14 @@ OP *
 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;
 }
@@ -2041,17 +2098,32 @@ pmruntime(OP *o, OP *expr, OP *repl)
 	OP *curop;
 	if (pm->op_pmflags & PMf_EVAL)
 	    curop = 0;
+#ifdef USE_THREADS
+	else if (repl->op_type == OP_SPECIFIC
+		 && strchr("&`'123456789+",
+			   per_thread_magicals[repl->op_targ]))
+	{
+	    curop = 0;
+	}
+#endif /* USE_THREADS */
 	else if (repl->op_type == OP_CONST)
 	    curop = repl;
 	else {
 	    OP *lastop = 0;
 	    for (curop = LINKLIST(repl); curop!=repl; curop = LINKLIST(curop)) {
 		if (opargs[curop->op_type] & OA_DANGEROUS) {
+#ifdef USE_THREADS
+		    if (curop->op_type == OP_SPECIFIC
+			&& strchr("&`'123456789+", curop->op_private)) {
+			break;
+		    }
+#else
 		    if (curop->op_type == OP_GV) {
 			GV *gv = ((GVOP*)curop)->op_gv;
 			if (strchr("&`'123456789+", *GvENAME(gv)))
 			    break;
 		    }
+#endif /* USE_THREADS */
 		    else if (curop->op_type == OP_RV2CV)
 			break;
 		    else if (curop->op_type == OP_RV2SV ||
@@ -3390,23 +3462,8 @@ newSUB(I32 floor, OP *o, OP *proto, OP *block)
     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
-
 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);
diff --git a/op.h b/op.h
index c582134ad2..7e853c5643 100644
--- a/op.h
+++ b/op.h
@@ -130,6 +130,9 @@ typedef U32 PADOFFSET;
 /* Private for OP_SORT, OP_PRTF, OP_SPRINTF, string cmp'n, and case changers */
 #define OPpLOCALE		64	/* Use locale */
 
+/* Private for OP_SPECIFIC */
+#define OPpPM_NOT_CONST		64	/* Not constant enough for pmruntime */
+
 struct op {
     BASEOP
 };
diff --git a/perl.c b/perl.c
index aff14f447d..cca10d3614 100644
--- a/perl.c
+++ b/perl.c
@@ -69,6 +69,9 @@ static void init_ids _((void));
 static void init_debugger _((void));
 static void init_lexer _((void));
 static void init_main_stash _((void));
+#ifdef USE_THREADS
+static struct thread * init_main_thread _((void));
+#endif /* USE_THREADS */
 static void init_perllib _((void));
 static void init_postdump_symbols _((int, char **, char **));
 static void init_predump_symbols _((void));
@@ -131,34 +134,8 @@ perl_construct(register PerlInterpreter *sv_interp)
 	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);
+	
+	thr = init_main_thread();
 #endif /* USE_THREADS */
 
 	linestr = NEWSV(65,80);
@@ -979,6 +956,9 @@ print \"  \\@INC:\\n    @INC\\n\";");
     /* 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);
 
     if (do_undump)
@@ -2522,6 +2502,9 @@ init_predump_symbols(void)
     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);
 
     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
@@ -2796,6 +2779,63 @@ incpush(char *p, int addsubdirs)
     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(I32 oldscope, AV *list)
 {
@@ -2813,21 +2853,20 @@ call_list(I32 oldscope, AV *list)
 	JMPENV_PUSH(ret);
 	switch (ret) {
 	case 0: {
-		SV* atsv = GvSV(errgv);
 		PUSHMARK(stack_sp);
 		perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
-		(void)SvPV(atsv, len);
+		(void)SvPV(errsv, len);
 		if (len) {
 		    JMPENV_POP;
 		    curcop = &compiling;
 		    curcop->cop_line = oldline;
 		    if (list == beginav)
-			sv_catpv(atsv, "BEGIN failed--compilation aborted");
+			sv_catpv(errsv, "BEGIN failed--compilation aborted");
 		    else
-			sv_catpv(atsv, "END failed--cleanup aborted");
+			sv_catpv(errsv, "END failed--cleanup aborted");
 		    while (scopestack_ix > oldscope)
 			LEAVE;
-		    croak("%s", SvPVX(atsv));
+		    croak("%s", SvPVX(errsv));
 		}
 	    }
 	    break;
diff --git a/perl.h b/perl.h
index d039deee69..fb1775570e 100644
--- a/perl.h
+++ b/perl.h
@@ -1349,6 +1349,8 @@ int runops_standard _((void));
 int runops_debug _((void));
 #endif
 
+#define PER_THREAD_MAGICALS "123456789&`'+/.,\\\";^-%=|~:\001\005!@"
+
 /****************/
 /* Truly global */
 /****************/
diff --git a/pp.c b/pp.c
index 3234be31b0..86dd10f379 100644
--- a/pp.c
+++ b/pp.c
@@ -4296,4 +4296,20 @@ PP(pp_lock)
     RETURN;
 }
 
-
+PP(pp_specific)
+{
+#ifdef USE_THREADS
+    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;
+}
diff --git a/pp_ctl.c b/pp_ctl.c
index 3dfc22e254..ee60c41937 100644
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -1106,21 +1106,6 @@ PP(pp_orassign)
 	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)
 {
     djSP;
diff --git a/pp_hot.c b/pp_hot.c
index b71299e7cd..141aa36fc5 100644
--- a/pp_hot.c
+++ b/pp_hot.c
@@ -1901,7 +1901,7 @@ PP(pp_entersub)
      	 * (3) instead of (2) so we'd have to clone. Would the fact
      	 * that we released the mutex more quickly make up for this?
      	 */
-	svp = hv_fetch(cvcache, (char *)cv, sizeof(cv), FALSE);
+	svp = hv_fetch(thr->cvcache, (char *)cv, sizeof(cv), FALSE);
      	if (svp) {
 	    /* We already have a clone to use */
 	    MUTEX_UNLOCK(CvMUTEXP(cv));
@@ -1941,7 +1941,7 @@ PP(pp_entersub)
 		 */
 	     	clonecv = cv_clone(cv);
     		SvREFCNT_dec(cv); /* finished with this */
-		hv_store(cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
+		hv_store(thr->cvcache, (char*)cv, sizeof(cv), (SV*)clonecv,0);
 		CvOWNER(clonecv) = thr;
 		cv = clonecv;
 		SvREFCNT_inc(cv);
diff --git a/proto.h b/proto.h
index 03c86d49df..9926977569 100644
--- a/proto.h
+++ b/proto.h
@@ -305,9 +305,6 @@ OP*	newSLICEOP _((I32 flags, OP* subscript, OP* list));
 OP*	newSTATEOP _((I32 flags, char* label, OP* o));
 CV*	newSUB _((I32 floor, OP* o, OP* proto, OP* block));
 CV*	newXS _((char* name, void (*subaddr)(CV* cv), char* filename));
-#ifdef DEPRECATED
-CV*	newXSUB _((char* name, I32 ix, I32 (*subaddr)(int,int,int), char* filename));
-#endif
 AV*	newAV _((void));
 OP*	newAVREF _((OP* o));
 OP*	newBINOP _((I32 type, I32 flags, OP* first, OP* last));
diff --git a/scope.h b/scope.h
index d9fe15a0a3..a65cb628a9 100644
--- a/scope.h
+++ b/scope.h
@@ -38,9 +38,6 @@
 
 #define SAVETMPS save_int((int*)&tmps_floor), tmps_floor = tmps_ix
 #define FREETMPS if (tmps_ix > tmps_floor) free_tmps()
-#ifdef DEPRECATED
-#define FREE_TMPS() FREETMPS
-#endif
 
 #define ENTER push_scope()
 #define LEAVE pop_scope()
diff --git a/sv.h b/sv.h
index 7a283a6334..c888d8fcac 100644
--- a/sv.h
+++ b/sv.h
@@ -71,13 +71,16 @@ struct io {
 #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); 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
 
diff --git a/t/TEST b/t/TEST
index cae81031c2..1bda4ef793 100755
--- a/t/TEST
+++ b/t/TEST
@@ -7,24 +7,39 @@
 
 $| = 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 {
@@ -41,8 +56,6 @@ else {
 $bad = 0;
 $good = 0;
 $total = @ARGV;
-$files  = 0;
-$totmax = 0;
 while ($test = shift) {
     if ($test =~ /^$/) {
 	next;
@@ -51,12 +64,11 @@ while ($test = shift) {
     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') {
@@ -66,11 +78,12 @@ while ($test = shift) {
 	} 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 $_;
 	}
@@ -102,7 +115,7 @@ while ($test = shift) {
 	}
     } else {
 	$next += 1;
-	print "FAILED at test $next\n";
+	print "FAILED on test $next\n";
 	$bad = $bad + 1;
 	$_ = $test;
 	if (/^base/) {
@@ -114,7 +127,6 @@ while ($test = shift) {
 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";
     }
@@ -130,15 +142,8 @@ if ($bad == 0) {
    ### 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;
diff --git a/thread.h b/thread.h
index 5cb4b284ca..76cd7d9623 100644
--- a/thread.h
+++ b/thread.h
@@ -199,10 +199,12 @@ struct thread {
 
     /* XXX Sort stuff, firstgv, secongv and so on? */
 
-    SV *	Toursv;
-    HV *	Tcvcache;
+    SV *	oursv;
+    HV *	cvcache;
     perl_thread	self;			/* Underlying thread object */
     U32		flags;
+    AV *	magicals;		/* Per-thread magicals */
+    AV *	specific;		/* Thread-specific user data */
     perl_mutex	mutex;			/* For the fields others can change */
     U32		tid;
     struct thread *next, *prev;		/* Circular linked list of threads */
@@ -210,7 +212,7 @@ struct thread {
 #ifdef ADD_THREAD_INTERN
     struct thread_intern i;		/* Platform-dependent internals */
 #endif
-    char	trailing_nul;		/* For the sake of thrsv, t->Toursv */
+    char	trailing_nul;		/* For the sake of thrsv and oursv */
 };
 
 typedef struct thread *Thread;
@@ -286,7 +288,6 @@ typedef struct condpair {
 #undef	dirty
 #undef	localizing
 
-#define oursv		(thr->Toursv)
 #define stack_base	(thr->Tstack_base)
 #define stack_sp	(thr->Tstack_sp)
 #define stack_max	(thr->Tstack_max)
@@ -341,7 +342,6 @@ typedef struct condpair {
 #define	top_env		(thr->Ttop_env)
 #define	runlevel	(thr->Trunlevel)
 
-#define	cvcache		(thr->Tcvcache)
 #else
 /* USE_THREADS is not defined */
 #define MUTEX_LOCK(m)
diff --git a/toke.c b/toke.c
index 7cb0fc6836..f1b59003c7 100644
--- a/toke.c
+++ b/toke.c
@@ -1225,16 +1225,23 @@ yylex(void)
 	    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])
 		{
 		    if (strnEQ(d,"<=>",3) || strnEQ(d,"cmp",3)) {
 			croak("Can't use \"my %s\" in sort comparison",
@@ -1360,7 +1367,13 @@ yylex(void)
 	if (lex_dojoin) {
 	    nextval[nexttoke].ival = 0;
 	    force_next(',');
+#ifdef USE_THREADS
+	    nextval[nexttoke].opval = newOP(OP_SPECIFIC, 0);
+	    nextval[nexttoke].opval->op_targ = find_thread_magical("\"");
+	    force_next(PRIVATEREF);
+#else
 	    force_ident("\"", '$');
+#endif /* USE_THREADS */
 	    nextval[nexttoke].ival = 0;
 	    force_next('$');
 	    nextval[nexttoke].ival = 0;
@@ -5269,7 +5282,7 @@ start_subparse(I32 is_format, U32 flags)
     av_store(comppadlist, 1, (SV*)comppad);
 
     CvPADLIST(compcv) = comppadlist;
-    CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc((SV*)outsidecv);
+    CvOUTSIDE(compcv) = (CV*)SvREFCNT_inc(outsidecv);
 #ifdef USE_THREADS
     CvOWNER(compcv) = 0;
     New(666, CvMUTEXP(compcv), 1, perl_mutex);
diff --git a/util.c b/util.c
index 6eccc55acd..93f5620e2e 100644
--- a/util.c
+++ b/util.c
@@ -1122,8 +1122,9 @@ die(pat, va_alist)
     GV *gv;
     CV *cv;
 
-    DEBUG_L(PerlIO_printf(PerlIO_stderr(), "die: curstack = %p, mainstack= %p\n",
-    		    curstack, mainstack));/*debug*/
+    DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+			  "%p: die: curstack = %p, mainstack = %p\n",
+			  thr, curstack, mainstack));
     /* We have to switch back to mainstack or die_where may try to pop
      * the eval block from the wrong stack if die is being called from a
      * signal handler.  - dkindred@cs.cmu.edu */
@@ -1140,8 +1141,9 @@ die(pat, va_alist)
     message = mess(pat, &args);
     va_end(args);
 
-    DEBUG_L(PerlIO_printf(PerlIO_stderr(), "die: message = %s\ndiehook = %p\n",
-		   message, diehook));/*debug*/
+    DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+			  "%p: die: message = %s\ndiehook = %p\n",
+			  thr, message, diehook));
     if (diehook) {
 	/* sv_2cv might call croak() */
 	SV *olddiehook = diehook;
@@ -1170,8 +1172,8 @@ die(pat, va_alist)
 
     restartop = die_where(message);
     DEBUG_L(PerlIO_printf(PerlIO_stderr(),
-    		    "die: restartop = %p, was_in_eval = %d, oldrunlevel = %d\n",
-		    restartop, was_in_eval, oldrunlevel));/*debug*/
+	  "%p: die: restartop = %p, was_in_eval = %d, oldrunlevel = %d\n",
+	  thr, restartop, was_in_eval, oldrunlevel));
     if ((!restartop && was_in_eval) || oldrunlevel > 1)
 	JMPENV_JUMP(3);
     return restartop;
@@ -2386,6 +2388,99 @@ condpair_magic(SV *sv)
     }
     return mg;
 }
+
+/*
+ * Make a new perl thread structure using t as a prototype. 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 use by ext/Thread/Thread.xs in core perl (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;
+    SV *sv;
+    SV **svp;
+    I32 i;
+
+    sv = newSVpv("", 0);
+    SvGROW(sv, sizeof(struct thread) + 1);
+    SvCUR_set(sv, sizeof(struct thread));
+    thr = (Thread) SvPVX(sv);
+    /* Zero(thr, 1, struct thread); */
+
+    /* debug */
+    memset(thr, 0xab, sizeof(struct thread));
+    markstack = 0;
+    scopestack = 0;
+    savestack = 0;
+    retstack = 0;
+    dirty = 0;
+    localizing = 0;
+    /* end debug */
+
+    thr->oursv = sv;
+    init_stacks(thr);
+
+    curcop = &compiling;
+    thr->cvcache = newHV();
+    thr->magicals = newAV();
+    thr->specific = newAV();
+    thr->flags = THRf_R_JOINABLE;
+    MUTEX_INIT(&thr->mutex);
+
+    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 needs to be non-zero. The particular value doesn't matter */
+    top_env = t->Ttop_env;
+    runlevel = 1;		/* XXX should be safe ? */
+    in_eval = FALSE;
+    restartop = 0;
+
+    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);
+    
+    /* Initialise all per-thread magicals that the template thread used */
+    svp = AvARRAY(t->magicals);
+    for (i = 0; i <= AvFILL(t->magicals); i++, svp++) {
+	if (*svp && *svp != &sv_undef) {
+	    SV *sv = newSVsv(*svp);
+	    av_store(thr->magicals, i, sv);
+	    sv_magic(sv, 0, 0, &per_thread_magicals[i], 1);
+	    DEBUG_L(PerlIO_printf(PerlIO_stderr(),
+				  "new_struct_thread: copied magical %d\n",i));
+	}
+    } 
+
+    MUTEX_LOCK(&threads_mutex);
+    nthreads++;
+    thr->tid = ++threadnum;
+    thr->next = t->next;
+    thr->prev = t;
+    t->next = thr;
+    thr->next->prev = thr;
+    MUTEX_UNLOCK(&threads_mutex);
+
+#ifdef HAVE_THREAD_INTERN
+    init_thread_intern(thr);
+#else
+    thr->self = pthread_self();
+#endif /* HAVE_THREAD_INTERN */
+    return thr;
+}
 #endif /* USE_THREADS */
 
 #ifdef HUGE_VAL