X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=41d2e04025a4cb7341972396c5be055b8c133ac5;hb=eefabb09a1a549c1747d7c554d375ecb16cafff1;hp=279e217fff85bba77179f14d3f76d0f61cce63c1;hpb=a98bd6f47916086cf27b0923091768d4e675e0b1;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perl.c b/perl.c
index 279e217..41d2e04 100644
--- a/perl.c
+++ b/perl.c
@@ -1,6 +1,6 @@
 /*    perl.c
  *
- *    Copyright (c) 1987-1997 Larry Wall
+ *    Copyright (c) 1987-1998 Larry Wall
  *
  *    You may distribute under the terms of either the GNU General Public
  *    License or the Artistic License, as specified in the README file.
@@ -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 perl_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));
@@ -80,21 +83,8 @@ static void validate_suid _((char *, char*));
 
 static int fdscript = -1;
 
-#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
-#include <asm/sigcontext.h>
-static void
-catch_sigsegv(int signo, struct sigcontext_struct sc)
-{
-    signal(SIGSEGV, SIG_DFL);
-    fprintf(stderr, "Segmentation fault dereferencing 0x%lx\n"
-		    "return_address = 0x%lx, eip = 0x%lx\n",
-	    	    sc.cr2, __builtin_return_address(0), sc.eip);
-    fprintf(stderr, "thread = 0x%lx\n", (unsigned long)THR); 
-}
-#endif
-
 PerlInterpreter *
-perl_alloc()
+perl_alloc(void)
 {
     PerlInterpreter *sv_interp;
 
@@ -104,12 +94,14 @@ perl_alloc()
 }
 
 void
-perl_construct( sv_interp )
-register PerlInterpreter *sv_interp;
+perl_construct(register PerlInterpreter *sv_interp)
 {
-#if defined(USE_THREADS) && !defined(FAKE_THREADS)
-    struct thread *thr;
-#endif
+#ifdef USE_THREADS
+    int i;
+#ifndef FAKE_THREADS
+    struct perl_thread *thr;
+#endif /* FAKE_THREADS */
+#endif /* USE_THREADS */
     
     if (!(curinterp = sv_interp))
 	return;
@@ -121,60 +113,25 @@ register PerlInterpreter *sv_interp;
    /* Init the real globals (and main thread)? */
     if (!linestr) {
 #ifdef USE_THREADS
-	XPV *xpv;
 
     	INIT_THREADS;
-	Newz(53, thr, 1, struct thread);
-	MUTEX_INIT(&malloc_mutex);
+#ifdef ALLOC_THREAD_KEY
+        ALLOC_THREAD_KEY;
+#else
+	if (pthread_key_create(&thr_key, 0))
+	    croak("panic: pthread_key_create");
+#endif
 	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
-#ifdef WIN32
-    DuplicateHandle(GetCurrentProcess(),
-		    GetCurrentThread(),
-		    GetCurrentProcess(),
-		    &self,
-		    0,
-		    FALSE,
-		    DUPLICATE_SAME_ACCESS);
-    if ((thr_key = TlsAlloc()) == TLS_OUT_OF_INDEXES)
-	croak("panic: pthread_key_create");
-    if (TlsSetValue(thr_key, (LPVOID) thr) != TRUE)
-	croak("panic: pthread_setspecific");
-#else
-	self = pthread_self();
-	if (pthread_key_create(&thr_key, 0))
-	    croak("panic: pthread_key_create");
-	if (pthread_setspecific(thr_key, (void *) thr))
-	    croak("panic: pthread_setspecific");
-#endif /* WIN32 */
-#endif /* FAKE_THREADS */
+	
+	thr = init_main_thread();
 #endif /* USE_THREADS */
 
 	linestr = NEWSV(65,80);
@@ -254,8 +211,7 @@ register PerlInterpreter *sv_interp;
 }
 
 void
-perl_destruct(sv_interp)
-register PerlInterpreter *sv_interp;
+perl_destruct(register PerlInterpreter *sv_interp)
 {
     dTHR;
     int destruct_level;  /* 0=none, 1=full, 2=full with checks */
@@ -293,13 +249,7 @@ register PerlInterpreter *sv_interp;
 	     * all over again.
 	     */
 	    MUTEX_UNLOCK(&threads_mutex);
-#ifdef WIN32
-	    if ((WaitForSingleObject(t->Tself,INFINITE) == WAIT_FAILED)
-		|| (GetExitCodeThread(t->Tself,(LPDWORD)&av) == 0))
-#else
-	    if (pthread_join(t->Tself, (void**)&av))
-#endif
-		croak("panic: pthread_join failed during global destruction");
+	    JOIN(t, &av);
 	    SvREFCNT_dec((SV*)av);
 	    DEBUG_L(PerlIO_printf(PerlIO_stderr(),
 				  "perl_destruct: joined zombie %p OK\n", t));
@@ -348,7 +298,7 @@ register PerlInterpreter *sv_interp;
 #ifdef DEBUGGING
     {
 	char *s;
-	if (s = getenv("PERL_DESTRUCT_LEVEL")) {
+	if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
 	    int i = atoi(s);
 	    if (destruct_level < i)
 		destruct_level = i;
@@ -454,36 +404,6 @@ register PerlInterpreter *sv_interp;
 
     /* defgv, aka *_ should be taken care of elsewhere */
 
-#if 0  /* just about all regexp stuff, seems to be ok */
-
-    /* shortcuts to regexp stuff */
-    leftgv = Nullgv;
-    ampergv = Nullgv;
-
-    SAVEFREEOP(curpm);
-    SAVEFREEOP(oldlastpm); /* for saving regexp context during debugger */
-
-    regprecomp = NULL;	/* uncompiled string. */
-    regparse = NULL;	/* Input-scan pointer. */
-    regxend = NULL;	/* End of input for compile */
-    regnpar = 0;	/* () count. */
-    regcode = NULL;	/* Code-emit pointer; &regdummy = don't. */
-    regsize = 0;	/* Code size. */
-    regnaughty = 0;	/* How bad is this pattern? */
-    regsawback = 0;	/* Did we see \1, ...? */
-
-    reginput = NULL;		/* String-input pointer. */
-    regbol = NULL;		/* Beginning of input, for ^ check. */
-    regeol = NULL;		/* End of input, for $ check. */
-    regstartp = (char **)NULL;	/* Pointer to startp array. */
-    regendp = (char **)NULL;	/* Ditto for endp. */
-    reglastparen = 0;		/* Similarly for lastparen. */
-    regtill = NULL;		/* How far we are required to go. */
-    regflags = 0;		/* are we folding, multilining? */
-    regprev = (char)NULL;	/* char before regbol, \n if none */
-
-#endif /* if 0 */
-
     /* clean up after study() */
     SvREFCNT_dec(lastscream);
     lastscream = Nullsv;
@@ -595,7 +515,6 @@ register PerlInterpreter *sv_interp;
     DEBUG_P(debprofdump());
 #ifdef USE_THREADS
     MUTEX_DESTROY(&sv_mutex);
-    MUTEX_DESTROY(&malloc_mutex);
     MUTEX_DESTROY(&eval_mutex);
     COND_DESTROY(&eval_cond);
 
@@ -619,8 +538,7 @@ register PerlInterpreter *sv_interp;
 }
 
 void
-perl_free(sv_interp)
-PerlInterpreter *sv_interp;
+perl_free(PerlInterpreter *sv_interp)
 {
     if (!(curinterp = sv_interp))
 	return;
@@ -628,12 +546,7 @@ PerlInterpreter *sv_interp;
 }
 
 int
-perl_parse(sv_interp, xsinit, argc, argv, env)
-PerlInterpreter *sv_interp;
-void (*xsinit)_((void));
-int argc;
-char **argv;
-char **env;
+perl_parse(PerlInterpreter *sv_interp, void (*xsinit) (void), int argc, char **argv, char **env)
 {
     dTHR;
     register SV *sv;
@@ -763,7 +676,7 @@ setuid perl scripts securely.\n");
 		croak("No -e allowed in setuid scripts");
 	    if (!e_fp) {
 	        e_tmpname = savepv(TMPPATH);
-		(void)mktemp(e_tmpname);
+		(void)PerlLIO_mktemp(e_tmpname);
 		if (!*e_tmpname)
 		    croak("Can't mktemp()");
 		e_fp = PerlIO_open(e_tmpname,"w");
@@ -895,7 +808,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
     }
   switch_end:
 
-    if (!tainting && (s = getenv("PERL5OPT"))) {
+    if (!tainting && (s = PerlEnv_getenv("PERL5OPT"))) {
 	while (s && *s) {
 	    while (isSPACE(*s))
 		s++;
@@ -927,7 +840,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
     }
     else if (scriptname == Nullch) {
 #ifdef MSDOS
-	if ( isatty(PerlIO_fileno(PerlIO_stdin())) )
+	if ( PerlLIO_isatty(PerlIO_fileno(PerlIO_stdin())) )
 	    moreswitches("h");
 #endif
 	scriptname = "-";
@@ -971,14 +884,10 @@ print \"  \\@INC:\\n    @INC\\n\";");
     boot_core_UNIVERSAL();
     if (xsinit)
 	(*xsinit)();	/* in case linked C routines want magical variables */
-#if defined(VMS) || defined(WIN32)
+#if defined(VMS) || defined(WIN32) || defined(DJGPP)
     init_os_extras();
 #endif
 
-#if defined(DEBUGGING) && defined(USE_THREADS) && defined(__linux__)
-    DEBUG_L(signal(SIGSEGV, (void(*)(int))catch_sigsegv););
-#endif
-
     init_predump_symbols();
     if (!do_undump)
 	init_postdump_symbols(argc,argv,env);
@@ -987,6 +896,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
 
     /* now parse the script */
 
+    SETERRNO(0,SS$_NORMAL);
     error_count = 0;
     if (yyparse() || error_count) {
 	if (minus_c)
@@ -1008,8 +918,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
     /* now that script is parsed, we can modify record separator */
     SvREFCNT_dec(rs);
     rs = SvREFCNT_inc(nrs);
-    sv_setsv(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), rs);
-
+    sv_setsv(perl_get_sv("/", TRUE), rs);
     if (do_undump)
 	my_unexec();
 
@@ -1020,7 +929,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
     FREETMPS;
 
 #ifdef MYMALLOC
-    if ((s=getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
+    if ((s=PerlEnv_getenv("PERL_DEBUG_MSTATS")) && atoi(s) >= 2)
 	dump_mstats("after compilation:");
 #endif
 
@@ -1031,8 +940,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
 }
 
 int
-perl_run(sv_interp)
-PerlInterpreter *sv_interp;
+perl_run(PerlInterpreter *sv_interp)
 {
     dTHR;
     I32 oldscope;
@@ -1058,7 +966,7 @@ PerlInterpreter *sv_interp;
 	if (endav)
 	    call_list(oldscope, endav);
 #ifdef MYMALLOC
-	if (getenv("PERL_DEBUG_MSTATS"))
+	if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
 	    dump_mstats("after execution:  ");
 #endif
 	JMPENV_POP;
@@ -1117,20 +1025,26 @@ PerlInterpreter *sv_interp;
 }
 
 SV*
-perl_get_sv(name, create)
-char* name;
-I32 create;
+perl_get_sv(char *name, I32 create)
 {
-    GV* gv = gv_fetchpv(name, create, SVt_PV);
+    GV *gv;
+#ifdef USE_THREADS
+    if (name[1] == '\0' && !isALPHA(name[0])) {
+	PADOFFSET tmp = find_threadsv(name);
+    	if (tmp != NOT_IN_PAD) {
+	    dTHR;
+	    return THREADSV(tmp);
+	}
+    }
+#endif /* USE_THREADS */
+    gv = gv_fetchpv(name, create, SVt_PV);
     if (gv)
 	return GvSV(gv);
     return Nullsv;
 }
 
 AV*
-perl_get_av(name, create)
-char* name;
-I32 create;
+perl_get_av(char *name, I32 create)
 {
     GV* gv = gv_fetchpv(name, create, SVt_PVAV);
     if (create)
@@ -1141,9 +1055,7 @@ I32 create;
 }
 
 HV*
-perl_get_hv(name, create)
-char* name;
-I32 create;
+perl_get_hv(char *name, I32 create)
 {
     GV* gv = gv_fetchpv(name, create, SVt_PVHV);
     if (create)
@@ -1154,9 +1066,7 @@ I32 create;
 }
 
 CV*
-perl_get_cv(name, create)
-char* name;
-I32 create;
+perl_get_cv(char *name, I32 create)
 {
     GV* gv = gv_fetchpv(name, create, SVt_PVCV);
     if (create && !GvCVu(gv))
@@ -1172,12 +1082,11 @@ I32 create;
 /* Be sure to refetch the stack pointer after calling these routines. */
 
 I32
-perl_call_argv(subname, flags, argv)
-char *subname;
-I32 flags;		/* See G_* flags in cop.h */
-register char **argv;	/* null terminated arg list */
+perl_call_argv(char *sub_name, I32 flags, register char **argv)
+              
+          		/* See G_* flags in cop.h */
+                     	/* null terminated arg list */
 {
-    dTHR;
     dSP;
 
     PUSHMARK(sp);
@@ -1188,23 +1097,22 @@ register char **argv;	/* null terminated arg list */
 	}
 	PUTBACK;
     }
-    return perl_call_pv(subname, flags);
+    return perl_call_pv(sub_name, flags);
 }
 
 I32
-perl_call_pv(subname, flags)
-char *subname;		/* name of the subroutine */
-I32 flags;		/* See G_* flags in cop.h */
+perl_call_pv(char *sub_name, I32 flags)
+              		/* name of the subroutine */
+          		/* See G_* flags in cop.h */
 {
-    return perl_call_sv((SV*)perl_get_cv(subname, TRUE), flags);
+    return perl_call_sv((SV*)perl_get_cv(sub_name, TRUE), flags);
 }
 
 I32
-perl_call_method(methname, flags)
-char *methname;		/* name of the subroutine */
-I32 flags;		/* See G_* flags in cop.h */
+perl_call_method(char *methname, I32 flags)
+               		/* name of the subroutine */
+          		/* See G_* flags in cop.h */
 {
-    dTHR;
     dSP;
     OP myop;
     if (!op)
@@ -1217,9 +1125,9 @@ I32 flags;		/* See G_* flags in cop.h */
 
 /* May be called with any of a CV, a GV, or an SV containing the name. */
 I32
-perl_call_sv(sv, flags)
-SV* sv;
-I32 flags;		/* See G_* flags in cop.h */
+perl_call_sv(SV *sv, I32 flags)
+       
+          		/* See G_* flags in cop.h */
 {
     dTHR;
     LOGOP myop;		/* fake syntax tree node */
@@ -1266,7 +1174,7 @@ I32 flags;		/* See G_* flags in cop.h */
 	markstack_ptr--;
 	/* we're trying to emulate pp_entertry() here */
 	{
-	    register CONTEXT *cx;
+	    register PERL_CONTEXT *cx;
 	    I32 gimme = GIMME_V;
 	    
 	    ENTER;
@@ -1281,7 +1189,7 @@ I32 flags;		/* See G_* flags in cop.h */
 	    if (flags & G_KEEPERR)
 		in_eval |= 4;
 	    else
-		sv_setpv(GvSV(errgv),"");
+		sv_setpv(ERRSV,"");
 	}
 	markstack_ptr++;
 
@@ -1326,7 +1234,7 @@ I32 flags;		/* See G_* flags in cop.h */
 	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) {
@@ -1334,7 +1242,7 @@ I32 flags;		/* See G_* flags in cop.h */
 	    SV **newsp;
 	    PMOP *newpm;
 	    I32 gimme;
-	    register CONTEXT *cx;
+	    register PERL_CONTEXT *cx;
 	    I32 optype;
 
 	    POPBLOCK(cx,newpm);
@@ -1361,9 +1269,9 @@ I32 flags;		/* See G_* flags in cop.h */
 /* Eval a string. The G_EVAL flag is always assumed. */
 
 I32
-perl_eval_sv(sv, flags)
-SV* sv;
-I32 flags;		/* See G_* flags in cop.h */
+perl_eval_sv(SV *sv, I32 flags)
+       
+          		/* See G_* flags in cop.h */
 {
     dTHR;
     UNOP myop;		/* fake syntax tree node */
@@ -1435,7 +1343,7 @@ I32 flags;		/* See G_* flags in cop.h */
 	runops();
     retval = stack_sp - (stack_base + oldmark);
     if (!(flags & G_KEEPERR))
-	sv_setpv(GvSV(errgv),"");
+	sv_setpv(ERRSV,"");
 
   cleanup:
     JMPENV_POP;
@@ -1450,11 +1358,8 @@ I32 flags;		/* See G_* flags in cop.h */
 }
 
 SV*
-perl_eval_pv(p, croak_on_error)
-char* p;
-I32 croak_on_error;
+perl_eval_pv(char *p, I32 croak_on_error)
 {
-    dTHR;
     dSP;
     SV* sv = newSVpv(p, 0);
 
@@ -1466,8 +1371,8 @@ I32 croak_on_error;
     sv = POPs;
     PUTBACK;
 
-    if (croak_on_error && SvTRUE(GvSV(errgv)))
-	croak(SvPVx(GvSV(errgv), na));
+    if (croak_on_error && SvTRUE(ERRSV))
+	croak(SvPVx(ERRSV, na));
 
     return sv;
 }
@@ -1475,8 +1380,7 @@ I32 croak_on_error;
 /* Require a module. */
 
 void
-perl_require_pv(pv)
-char* pv;
+perl_require_pv(char *pv)
 {
     SV* sv = sv_newmortal();
     sv_setpv(sv, "require '");
@@ -1486,10 +1390,7 @@ char* pv;
 }
 
 void
-magicname(sym,name,namlen)
-char *sym;
-char *name;
-I32 namlen;
+magicname(char *sym, char *name, I32 namlen)
 {
     register GV *gv;
 
@@ -1498,8 +1399,8 @@ I32 namlen;
 }
 
 static void
-usage(name)		/* XXX move this out into a module ? */
-char *name;
+usage(char *name)		/* XXX move this out into a module ? */
+           
 {
     /* This message really ought to be max 23 lines.
      * Removed -h because the user already knows that opton. Others? */
@@ -1541,14 +1442,15 @@ NULL
 /* This routine handles any switches that can be given during run */
 
 char *
-moreswitches(s)
-char *s;
+moreswitches(char *s)
 {
     I32 numlen;
     U32 rschar;
 
     switch (*s) {
     case '0':
+    {
+	dTHR;
 	rschar = scan_oct(s, 4, &numlen);
 	SvREFCNT_dec(nrs);
 	if (rschar & ~((U8)~0))
@@ -1560,6 +1462,7 @@ char *s;
 	    nrs = newSVpv(&ch, 1);
 	}
 	return s + numlen;
+    }
     case 'F':
 	minus_F = TRUE;
 	splitstr = savepv(s + 1);
@@ -1608,7 +1511,7 @@ char *s;
 	return s;
     case 'h':
 	usage(origargv[0]);    
-	exit(0);
+	PerlProc_exit(0);
     case 'i':
 	if (inplace)
 	    Safefree(inplace);
@@ -1646,6 +1549,7 @@ char *s;
 	    s += numlen;
 	}
 	else {
+	    dTHR;
 	    if (RsPARA(nrs)) {
 		ors = "\n\n";
 		orslen = 2;
@@ -1731,16 +1635,17 @@ char *s;
 		LOCAL_PATCH_COUNT, (LOCAL_PATCH_COUNT!=1) ? "es" : "");
 #endif
 
-	printf("\n\nCopyright 1987-1997, Larry Wall\n");
+	printf("\n\nCopyright 1987-1998, Larry Wall\n");
 #ifdef MSDOS
 	printf("\nMS-DOS port Copyright (c) 1989, 1990, Diomidis Spinellis\n");
 #endif
 #ifdef DJGPP
 	printf("djgpp v2 port (jpl5003c) by Hirofumi Watanabe, 1996\n");
+	printf("djgpp v2 port (perl5004) by Laszlo Molnar, 1997\n");
 #endif
 #ifdef OS2
 	printf("\n\nOS/2 port Copyright (c) 1990, 1991, Raymond Chen, Kai Uwe Rommel\n"
-	    "Version 5 port Copyright (c) 1994-1997, Andreas Kaiser, Ilya Zakharevich\n");
+	    "Version 5 port Copyright (c) 1994-1998, Andreas Kaiser, Ilya Zakharevich\n");
 #endif
 #ifdef atarist
 	printf("atariST series port, ++jrb  bammi@cadence.com\n");
@@ -1748,7 +1653,7 @@ char *s;
 	printf("\n\
 Perl may be copied only under the terms of either the Artistic License or the\n\
 GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n");
-	exit(0);
+	PerlProc_exit(0);
     case 'w':
 	dowarn = TRUE;
 	s++;
@@ -1760,6 +1665,9 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n")
 	break;
     case '-':
     case 0:
+#ifdef WIN32
+    case '\r':
+#endif
     case '\n':
     case '\t':
 	break;
@@ -1782,7 +1690,7 @@ GNU General Public License, which may be found in the Perl 5.0 source kit.\n\n")
 /* unexec() can be found in the Gnu emacs distribution */
 
 void
-my_unexec()
+my_unexec(void)
 {
 #ifdef UNEXEC
     SV*    prog;
@@ -1799,7 +1707,7 @@ my_unexec()
     if (status)
 	PerlIO_printf(PerlIO_stderr(), "unexec of %s into %s failed!\n",
 		      SvPVX(prog), SvPVX(file));
-    exit(status);
+    PerlProc_exit(status);
 #else
 #  ifdef VMS
 #    include <lib$routines.h>
@@ -1811,7 +1719,7 @@ my_unexec()
 }
 
 static void
-init_main_stash()
+init_main_stash(void)
 {
     dTHR;
     GV *gv;
@@ -1837,11 +1745,12 @@ init_main_stash()
     errgv = gv_HVadd(gv_fetchpv("@", TRUE, SVt_PV));
     GvMULTI_on(errgv);
     (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));
+    globalstash = GvHV(gv_fetchpv("CORE::GLOBAL::", GV_ADDMULTI, SVt_PVHV));
     /* We must init $/ before switches are processed. */
     sv_setpvn(GvSV(gv_fetchpv("/", TRUE, SVt_PV)), "\n", 1);
 }
@@ -1894,7 +1803,7 @@ SV *sv;
      *
      * Assuming SEARCH_EXTS is C<".foo",".bar",NULL>, PATH search
      * proceeds as follows:
-     *   If DOSISH:
+     *   If DOSISH or VMSISH:
      *     + look for ./scriptname{,.foo,.bar}
      *     + search the PATH for scriptname{,.foo,.bar}
      *
@@ -1904,11 +1813,20 @@ SV *sv;
      */
 
 #ifdef VMS
+#  ifdef ALWAYS_DEFTYPES
+    len = strlen(scriptname);
+    if (!(len == 1 && *scriptname == '-') && scriptname[len-1] != ':') {
+	int hasdir, idx = 0, deftypes = 1;
+	bool seen_dot = 1;
+
+	hasdir = !dosearch || (strpbrk(scriptname,":[</") != Nullch) ;
+#  else
     if (dosearch) {
 	int hasdir, idx = 0, deftypes = 1;
 	bool seen_dot = 1;
 
 	hasdir = (strpbrk(scriptname,":[</") != Nullch) ;
+#  endif
 	/* The first time through, just add SEARCH_EXTS to whatever we
 	 * already have, so we can check for default file types. */
 	while (deftypes ||
@@ -1964,7 +1882,7 @@ SV *sv;
 #ifdef DOSISH
 		 && !strchr(scriptname, '\\')
 #endif
-		 && (s = getenv("PATH"))) {
+		 && (s = PerlEnv_getenv("PATH"))) {
 	bool seen_dot = 0;
 	
 	bufend = s + strlen(s);
@@ -2060,7 +1978,7 @@ SV *sv;
     if (strEQ(origfilename,"-"))
 	scriptname = "";
     if (fdscript >= 0) {
-	rsfp = PerlIO_fdopen(fdscript,"r");
+	rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 	if (rsfp)
 	    fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
@@ -2135,7 +2053,7 @@ sed %s -e \"/^[^#]/b\" \
 		croak("Can't do seteuid!\n");
 	}
 #endif /* IAMSUID */
-	rsfp = my_popen(SvPVX(cmd), "r");
+	rsfp = PerlProc_popen(SvPVX(cmd), "r");
 	SvREFCNT_dec(cmd);
 	SvREFCNT_dec(cpp);
     }
@@ -2144,7 +2062,7 @@ sed %s -e \"/^[^#]/b\" \
 	rsfp = PerlIO_stdin();
     }
     else {
-	rsfp = PerlIO_open(scriptname,"r");
+	rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
 #if defined(HAS_FCNTL) && defined(F_SETFD)
 	if (rsfp)
 	    fcntl(PerlIO_fileno(rsfp),F_SETFD,1);  /* ensure close-on-exec */
@@ -2159,7 +2077,7 @@ sed %s -e \"/^[^#]/b\" \
 	if (euid && Stat(SvPVX(GvSV(curcop->cop_filegv)),&statbuf) >= 0 &&
 	  statbuf.st_mode & (S_ISUID|S_ISGID)) {
 	    /* try again */
-	    execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
+	    PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
 	    croak("Can't do setuid\n");
 	}
 #endif
@@ -2170,9 +2088,7 @@ sed %s -e \"/^[^#]/b\" \
 }
 
 static void
-validate_suid(validarg, scriptname)
-char *validarg;
-char *scriptname;
+validate_suid(char *validarg, char *scriptname)
 {
     int which;
 
@@ -2197,9 +2113,10 @@ char *scriptname;
      */
 
 #ifdef DOSUID
+    dTHR;
     char *s, *s2;
 
-    if (Fstat(PerlIO_fileno(rsfp),&statbuf) < 0)	/* normal stat is insecure */
+    if (PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf) < 0)	/* normal stat is insecure */
 	croak("Can't stat script \"%s\"",origfilename);
     if (fdscript < 0 && statbuf.st_mode & (S_ISUID|S_ISGID)) {
 	I32 len;
@@ -2214,7 +2131,7 @@ char *scriptname;
 	 * But I don't think it's too important.  The manual lies when
 	 * it says access() is useful in setuid programs.
 	 */
-	if (access(SvPVX(GvSV(curcop->cop_filegv)),1))	/*double check*/
+	if (PerlLIO_access(SvPVX(GvSV(curcop->cop_filegv)),1))	/*double check*/
 	    croak("Permission denied");
 #else
 	/* If we can swap euid and uid, then we can determine access rights
@@ -2240,7 +2157,7 @@ char *scriptname;
 	    if (tmpstatbuf.st_dev != statbuf.st_dev ||
 		tmpstatbuf.st_ino != statbuf.st_ino) {
 		(void)PerlIO_close(rsfp);
-		if (rsfp = my_popen("/bin/mail root","w")) {	/* heh, heh */
+		if (rsfp = PerlProc_popen("/bin/mail root","w")) {	/* heh, heh */
 		    PerlIO_printf(rsfp,
 "User %ld tried to run dev %ld ino %ld in place of dev %ld ino %ld!\n\
 (Filename of set-id script was %s, uid %ld gid %ld.)\n\nSincerely,\nperl\n",
@@ -2248,7 +2165,7 @@ char *scriptname;
 			(long)statbuf.st_dev, (long)statbuf.st_ino,
 			SvPVX(GvSV(curcop->cop_filegv)),
 			(long)statbuf.st_uid, (long)statbuf.st_gid);
-		    (void)my_pclose(rsfp);
+		    (void)PerlProc_pclose(rsfp);
 		}
 		croak("Permission denied\n");
 	    }
@@ -2307,7 +2224,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 	    (void)PerlIO_close(rsfp);
 #ifndef IAMSUID
 	    /* try again */
-	    execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
+	    PerlProc_execv(form("%s/sperl%s", BIN_EXP, patchlevel), origargv);
 #endif
 	    croak("Can't do setuid\n");
 	}
@@ -2380,7 +2297,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
     /* exec the real perl, substituting fd script for scriptname. */
     /* (We pass script name as "subdir" of fd, which perl will grok.) */
     PerlIO_rewind(rsfp);
-    lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
+    PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
     for (which = 1; origargv[which] && origargv[which] != scriptname; which++) ;
     if (!origargv[which])
 	croak("Permission denied");
@@ -2389,14 +2306,14 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 #if defined(HAS_FCNTL) && defined(F_SETFD)
     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);	/* ensure no close-on-exec */
 #endif
-    execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);	/* try again */
+    PerlProc_execv(form("%s/perl%s", BIN_EXP, patchlevel), origargv);	/* try again */
     croak("Can't do setuid\n");
 #endif /* IAMSUID */
 #else /* !DOSUID */
     if (euid != uid || egid != gid) {	/* (suidperl doesn't exist, in fact) */
 #ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
 	dTHR;
-	Fstat(PerlIO_fileno(rsfp),&statbuf);	/* may be either wrapped or real suid */
+	PerlLIO_fstat(PerlIO_fileno(rsfp),&statbuf);	/* may be either wrapped or real suid */
 	if ((euid != uid && euid == statbuf.st_uid && statbuf.st_mode & S_ISUID)
 	    ||
 	    (egid != gid && egid == statbuf.st_gid && statbuf.st_mode & S_ISGID)
@@ -2411,7 +2328,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 }
 
 static void
-find_beginning()
+find_beginning(void)
 {
     register char *s, *s2;
 
@@ -2433,14 +2350,14 @@ find_beginning()
 		    /*SUPPRESS 530*/
 		    while (s = moreswitches(s)) ;
 	    }
-	    if (cddir && chdir(cddir) < 0)
+	    if (cddir && PerlDir_chdir(cddir) < 0)
 		croak("Can't chdir to %s",cddir);
 	}
     }
 }
 
 static void
-init_ids()
+init_ids(void)
 {
     uid = (int)getuid();
     euid = (int)geteuid();
@@ -2454,8 +2371,7 @@ init_ids()
 }
 
 static void
-forbid_setid(s)
-char *s;
+forbid_setid(char *s)
 {
     if (euid != uid)
         croak("No %s allowed while running setuid", s);
@@ -2464,7 +2380,7 @@ char *s;
 }
 
 static void
-init_debugger()
+init_debugger(void)
 {
     dTHR;
     curstash = debstash;
@@ -2483,8 +2399,7 @@ init_debugger()
 }
 
 void
-init_stacks(ARGS)
-dARGS
+init_stacks(ARGSproto)
 {
     curstack = newAV();
     mainstack = curstack;		/* remember in case we switch stacks */
@@ -2495,8 +2410,8 @@ dARGS
     stack_sp = stack_base;
     stack_max = stack_base + 127;
 
-    cxstack_max = 8192 / sizeof(CONTEXT) - 2;	/* Use most of 8K. */
-    New(50,cxstack,cxstack_max + 1,CONTEXT);
+    cxstack_max = 8192 / sizeof(PERL_CONTEXT) - 2;	/* Use most of 8K. */
+    New(50,cxstack,cxstack_max + 1,PERL_CONTEXT);
     cxstack_ix	= -1;
 
     New(50,tmps_stack,128,SV*);
@@ -2543,7 +2458,7 @@ dARGS
 }
 
 static void
-nuke_stacks()
+nuke_stacks(void)
 {
     dTHR;
     Safefree(cxstack);
@@ -2557,7 +2472,7 @@ nuke_stacks()
 static PerlIO *tmpfp;  /* moved outside init_lexer() because of UNICOS bug */
 
 static void
-init_lexer()
+init_lexer(void)
 {
     tmpfp = rsfp;
     rsfp = Nullfp;
@@ -2567,14 +2482,13 @@ init_lexer()
 }
 
 static void
-init_predump_symbols()
+init_predump_symbols(void)
 {
     dTHR;
     GV *tmpgv;
     GV *othergv;
 
-    sv_setpvn(GvSV(gv_fetchpv("\"", TRUE, SVt_PV)), " ", 1);
-
+    sv_setpvn(perl_get_sv("\"", TRUE), " ", 1);
     stdingv = gv_fetchpv("STDIN",TRUE, SVt_PVIO);
     GvMULTI_on(stdingv);
     IoIFP(GvIOp(stdingv)) = PerlIO_stdin();
@@ -2604,11 +2518,9 @@ init_predump_symbols()
 }
 
 static void
-init_postdump_symbols(argc,argv,env)
-register int argc;
-register char **argv;
-register char **env;
+init_postdump_symbols(register int argc, register char **argv, register char **env)
 {
+    dTHR;
     char *s;
     SV *sv;
     GV* tmpgv;
@@ -2672,7 +2584,7 @@ register char **env;
 	    if (!(s = strchr(*env,'=')))
 		continue;
 	    *s++ = '\0';
-#ifdef WIN32
+#if defined(WIN32) || defined(MSDOS)
 	    (void)strupr(*env);
 #endif
 	    sv = newSVpv(s--,0);
@@ -2680,7 +2592,7 @@ register char **env;
 	    *s = '=';
 #if defined(__BORLANDC__) && defined(USE_WIN32_RTL_ENV)
 	    /* Sins of the RTL. See note in my_setenv(). */
-	    (void)putenv(savepv(*env));
+	    (void)PerlEnv_putenv(savepv(*env));
 #endif
 	}
 #endif
@@ -2694,16 +2606,16 @@ register char **env;
 }
 
 static void
-init_perllib()
+init_perllib(void)
 {
     char *s;
     if (!tainting) {
 #ifndef VMS
-	s = getenv("PERL5LIB");
+	s = PerlEnv_getenv("PERL5LIB");
 	if (s)
 	    incpush(s, TRUE);
 	else
-	    incpush(getenv("PERLLIB"), FALSE);
+	    incpush(PerlEnv_getenv("PERLLIB"), FALSE);
 #else /* VMS */
 	/* Treat PERL5?LIB as a possible search list logical name -- the
 	 * "natural" VMS idiom for a Unix path string.  We allow each
@@ -2761,9 +2673,7 @@ init_perllib()
 #endif 
 
 static void
-incpush(p, addsubdirs)
-char *p;
-int addsubdirs;
+incpush(char *p, int addsubdirs)
 {
     SV *subdir = Nullsv;
     static char *archpat_auto;
@@ -2772,7 +2682,7 @@ int addsubdirs;
 	return;
 
     if (addsubdirs) {
-	subdir = newSV(0);
+	subdir = NEWSV(55,0);
 	if (!archpat_auto) {
 	    STRLEN len = (sizeof(ARCHNAME) + strlen(patchlevel)
 			  + sizeof("//auto"));
@@ -2788,7 +2698,7 @@ int addsubdirs;
 
     /* Break at all separators */
     while (p && *p) {
-	SV *libdir = newSV(0);
+	SV *libdir = NEWSV(55,0);
 	char *s;
 
 	/* skip any consecutive separators */
@@ -2852,10 +2762,73 @@ int addsubdirs;
     SvREFCNT_dec(subdir);
 }
 
+#ifdef USE_THREADS
+static struct perl_thread *
+init_main_thread()
+{
+    struct perl_thread *thr;
+    XPV *xpv;
+
+    Newz(53, thr, 1, struct perl_thread);
+    curcop = &compiling;
+    thr->cvcache = newHV();
+    thr->threadsv = newAV();
+    /* thr->threadsvp is set when find_threadsv is called */
+    thr->specific = newAV();
+    thr->errhv = newHV();
+    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);
+#endif
+
+#ifdef SET_THREAD_SELF
+    SET_THREAD_SELF(thr);
+#else
+    thr->self = pthread_self();
+#endif /* SET_THREAD_SELF */
+    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;
+    thr->errsv = newSVpv("", 0);
+    (void) find_threadsv("@");	/* Ensure $@ is initialised early */
+    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;
@@ -2863,7 +2836,7 @@ AV* list;
     dJMPENV;
     int ret;
 
-    while (AvFILL(list) >= 0) {
+    while (AvFILL(list) >= 0) { 
 	CV *cv = (CV*)av_shift(list);
 
 	SAVEFREESV(cv);
@@ -2871,7 +2844,7 @@ AV* list;
 	JMPENV_PUSH(ret);
 	switch (ret) {
 	case 0: {
-		SV* atsv = GvSV(errgv);
+		SV* atsv = ERRSV;
 		PUSHMARK(stack_sp);
 		perl_call_sv((SV*)cv, G_EVAL|G_DISCARD);
 		(void)SvPV(atsv, len);
@@ -2927,14 +2900,13 @@ AV* list;
 }
 
 void
-my_exit(status)
-U32 status;
+my_exit(U32 status)
 {
     dTHR;
 
 #ifdef USE_THREADS
-    DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread 0x%lx, status %lu\n",
-			 (unsigned long) thr, (unsigned long) status));
+    DEBUG_L(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n",
+			  thr, (unsigned long) status));
 #endif /* USE_THREADS */
     switch (status) {
     case 0:
@@ -2951,7 +2923,7 @@ U32 status;
 }
 
 void
-my_failure_exit()
+my_failure_exit(void)
 {
 #ifdef VMS
     if (vaxc$errno & 1) {
@@ -2974,10 +2946,10 @@ my_failure_exit()
 }
 
 static void
-my_exit_jump()
+my_exit_jump(void)
 {
     dTHR;
-    register CONTEXT *cx;
+    register PERL_CONTEXT *cx;
     I32 gimme;
     SV **newsp;
 
@@ -3000,3 +2972,6 @@ my_exit_jump()
 
     JMPENV_JUMP(2);
 }
+
+
+