X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/10cc9d2a36974e2e1175dbda57d8d05e2b0ce49e..48a26b3aff3d4a22b7cc3f3ba0bb5977d168a801:/perl.c

diff --git a/perl.c b/perl.c
index 7e9f07a..715f4da 100644
--- a/perl.c
+++ b/perl.c
@@ -47,6 +47,41 @@ static I32 read_e_script(pTHXo_ int idx, SV *buf_sv, int maxlen);
 #define perl_free	Perl_free
 #endif
 
+#if defined(USE_THREADS)
+#  define INIT_TLS_AND_INTERP \
+    STMT_START {				\
+	if (!PL_curinterp) {			\
+	    PERL_SET_INTERP(my_perl);		\
+	    INIT_THREADS;			\
+	    ALLOC_THREAD_KEY;			\
+	}					\
+    } STMT_END
+#else
+#  if defined(USE_ITHREADS)
+#  define INIT_TLS_AND_INTERP \
+    STMT_START {				\
+	if (!PL_curinterp) {			\
+	    PERL_SET_INTERP(my_perl);		\
+	    INIT_THREADS;			\
+	    ALLOC_THREAD_KEY;			\
+	    PERL_SET_THX(my_perl);		\
+	    OP_REFCNT_INIT;			\
+	}					\
+	else {					\
+	    PERL_SET_THX(my_perl);		\
+	}					\
+    } STMT_END
+#  else
+#  define INIT_TLS_AND_INTERP \
+    STMT_START {				\
+	if (!PL_curinterp) {			\
+	    PERL_SET_INTERP(my_perl);		\
+	}					\
+	PERL_SET_THX(my_perl);			\
+    } STMT_END
+#  endif
+#endif
+
 #ifdef PERL_IMPLICIT_SYS
 PerlInterpreter *
 perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
@@ -59,11 +94,11 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS,
 #ifdef PERL_OBJECT
     my_perl = (PerlInterpreter*)new(ipM) CPerlObj(ipM, ipMS, ipMP, ipE, ipStd,
 						  ipLIO, ipD, ipS, ipP);
-    PERL_SET_INTERP(my_perl);
+    INIT_TLS_AND_INTERP;
 #else
     /* New() needs interpreter, so call malloc() instead */
     my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter));
-    PERL_SET_INTERP(my_perl);
+    INIT_TLS_AND_INTERP;
     Zero(my_perl, 1, PerlInterpreter);
     PL_Mem = ipM;
     PL_MemShared = ipMS;
@@ -95,7 +130,8 @@ perl_alloc(void)
 
     /* New() needs interpreter, so call malloc() instead */
     my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
-    PERL_SET_INTERP(my_perl);
+
+    INIT_TLS_AND_INTERP;
     Zero(my_perl, 1, PerlInterpreter);
     return my_perl;
 }
@@ -118,7 +154,7 @@ perl_construct(pTHXx)
     struct perl_thread *thr = NULL;
 #endif /* FAKE_THREADS */
 #endif /* USE_THREADS */
-    
+
 #ifdef MULTIPLICITY
     init_interp();
     PL_perl_destruct_level = 1; 
@@ -129,14 +165,7 @@ perl_construct(pTHXx)
 
    /* Init the real globals (and main thread)? */
     if (!PL_linestr) {
-    	INIT_THREADS;
 #ifdef USE_THREADS
-#ifdef ALLOC_THREAD_KEY
-        ALLOC_THREAD_KEY;
-#else
-	if (pthread_key_create(&PL_thr_key, 0))
-	    Perl_croak(aTHX_ "panic: pthread_key_create");
-#endif
 	MUTEX_INIT(&PL_sv_mutex);
 	/*
 	 * Safe to use basic SV functions from now on (though
@@ -146,9 +175,9 @@ perl_construct(pTHXx)
 	COND_INIT(&PL_eval_cond);
 	MUTEX_INIT(&PL_threads_mutex);
 	COND_INIT(&PL_nthreads_cond);
-#ifdef EMULATE_ATOMIC_REFCOUNTS
+#  ifdef EMULATE_ATOMIC_REFCOUNTS
 	MUTEX_INIT(&PL_svref_mutex);
-#endif /* EMULATE_ATOMIC_REFCOUNTS */
+#  endif /* EMULATE_ATOMIC_REFCOUNTS */
 	
 	MUTEX_INIT(&PL_cred_mutex);
 
@@ -218,7 +247,7 @@ perl_construct(pTHXx)
     {
 	U8 *s;
 	PL_patchlevel = NEWSV(0,4);
-	SvUPGRADE(PL_patchlevel, SVt_PVNV);
+	(void)SvUPGRADE(PL_patchlevel, SVt_PVNV);
 	if (PERL_REVISION > 127 || PERL_VERSION > 127 || PERL_SUBVERSION > 127)
 	    SvGROW(PL_patchlevel, UTF8_MAXLEN*3+1);
 	s = (U8*)SvPVX(PL_patchlevel);
@@ -348,7 +377,7 @@ perl_destruct(pTHXx)
 #ifdef DEBUGGING
     {
 	char *s;
-	if (s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL")) {
+	if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) {
 	    int i = atoi(s);
 	    if (destruct_level < i)
 		destruct_level = i;
@@ -566,6 +595,10 @@ perl_destruct(pTHXx)
     if (!specialWARN(PL_compiling.cop_warnings))
 	SvREFCNT_dec(PL_compiling.cop_warnings);
     PL_compiling.cop_warnings = Nullsv;
+#ifndef USE_ITHREADS
+    SvREFCNT_dec(CopFILEGV(&PL_compiling));
+    CopFILEGV_set(&PL_compiling, Nullgv);
+#endif
 
     /* Prepare to destruct main symbol table.  */
 
@@ -650,10 +683,15 @@ perl_destruct(pTHXx)
     SvREFCNT(&PL_sv_yes) = 0;
     sv_clear(&PL_sv_yes);
     SvANY(&PL_sv_yes) = NULL;
+    SvREADONLY_off(&PL_sv_yes);
 
     SvREFCNT(&PL_sv_no) = 0;
     sv_clear(&PL_sv_no);
     SvANY(&PL_sv_no) = NULL;
+    SvREADONLY_off(&PL_sv_no);
+
+    SvREFCNT(&PL_sv_undef) = 0;
+    SvREADONLY_off(&PL_sv_undef);
 
     if (PL_sv_count != 0 && ckWARN_d(WARN_INTERNAL))
 	Perl_warner(aTHX_ WARN_INTERNAL,"Scalars leaked: %ld\n", (long)PL_sv_count);
@@ -704,7 +742,7 @@ perl_destruct(pTHXx)
 	    }
 	}
 	/* we know that type >= SVt_PV */
-	SvOOK_off(PL_mess_sv);
+	(void)SvOOK_off(PL_mess_sv);
 	Safefree(SvPVX(PL_mess_sv));
 	Safefree(SvANY(PL_mess_sv));
 	Safefree(PL_mess_sv);
@@ -881,12 +919,16 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	s = argv[0]+1;
       reswitch:
 	switch (*s) {
+	case 'C':
+#ifdef	WIN32
+	    win32_argv2utf8(argc-1, argv+1);
+	    /* FALL THROUGH */
+#endif
 #ifndef PERL_STRICT_CR
 	case '\r':
 #endif
 	case ' ':
 	case '0':
-	case 'C':
 	case 'F':
 	case 'a':
 	case 'c':
@@ -906,7 +948,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	case 'W':
 	case 'X':
 	case 'w':
-	    if (s = moreswitches(s))
+	    if ((s = moreswitches(s)))
 		goto reswitch;
 	    break;
 
@@ -942,7 +984,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 		char *p;
 		STRLEN len = strlen(s);
 		p = savepvn(s, len);
-		incpush(p, TRUE);
+		incpush(p, TRUE, TRUE);
 		sv_catpvn(sv, "-I", 2);
 		sv_catpvn(sv, p, len);
 		sv_catpvn(sv, " ", 1);
@@ -1876,7 +1918,7 @@ Perl_magicname(pTHX_ char *sym, char *name, I32 namlen)
 {
     register GV *gv;
 
-    if (gv = gv_fetchpv(sym,TRUE, SVt_PV))
+    if ((gv = gv_fetchpv(sym,TRUE, SVt_PV)))
 	sv_magic(GvSV(gv), (SV*)gv, 0, name, namlen);
 }
 
@@ -2033,7 +2075,7 @@ Perl_moreswitches(pTHX_ char *s)
 		    p++;
 	    } while (*p && *p != '-');
 	    e = savepvn(s, e-s);
-	    incpush(e, TRUE);
+	    incpush(e, TRUE, TRUE);
 	    Safefree(e);
 	    s = p;
 	    if (*s == '-')
@@ -2385,7 +2427,6 @@ STATIC void
 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
 {
     dTHR;
-    register char *s;
 
     *fdscript = -1;
 
@@ -2637,7 +2678,9 @@ S_fd_on_nosuid_fs(pTHX_ int fd)
 STATIC void
 S_validate_suid(pTHX_ char *validarg, char *scriptname, int fdscript)
 {
+#ifdef IAMSUID
     int which;
+#endif
 
     /* do we need to emulate setuid on scripts? */
 
@@ -2904,7 +2947,8 @@ S_find_beginning(pTHX)
 		while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
 		if (strnEQ(s2-4,"perl",4))
 		    /*SUPPRESS 530*/
-		    while (s = moreswitches(s)) ;
+		    while ((s = moreswitches(s)))
+			;
 	    }
 	}
     }
@@ -3044,7 +3088,6 @@ S_init_predump_symbols(pTHX)
 {
     dTHR;
     GV *tmpgv;
-    GV *othergv;
     IO *io;
 
     sv_setpvn(get_sv("\"", TRUE), " ", 1);
@@ -3096,7 +3139,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
 		argc--,argv++;
 		break;
 	    }
-	    if (s = strchr(argv[0], '=')) {
+	    if ((s = strchr(argv[0], '='))) {
 		*s++ = '\0';
 		sv_setpv(GvSV(gv_fetchpv(argv[0]+1,TRUE, SVt_PV)),s);
 	    }
@@ -3113,25 +3156,28 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
     PL_formtarget = PL_bodytarget;
 
     TAINT;
-    if (tmpgv = gv_fetchpv("0",TRUE, SVt_PV)) {
+    if ((tmpgv = gv_fetchpv("0",TRUE, SVt_PV))) {
 	sv_setpv(GvSV(tmpgv),PL_origfilename);
 	magicname("0", "0", 1);
     }
-    if (tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))
+    if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV)))
 #ifdef OS2
 	sv_setpv(GvSV(tmpgv), os2_execname());
 #else
 	sv_setpv(GvSV(tmpgv),PL_origargv[0]);
 #endif
-    if (PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV)) {
+    if ((PL_argvgv = gv_fetchpv("ARGV",TRUE, SVt_PVAV))) {
 	GvMULTI_on(PL_argvgv);
 	(void)gv_AVadd(PL_argvgv);
 	av_clear(GvAVn(PL_argvgv));
 	for (; argc > 0; argc--,argv++) {
-	    av_push(GvAVn(PL_argvgv),newSVpv(argv[0],0));
+	    SV *sv = newSVpv(argv[0],0);
+	    av_push(GvAVn(PL_argvgv),sv);
+	    if (PL_widesyscalls)
+		sv_utf8_upgrade(sv);
 	}
     }
-    if (PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV)) {
+    if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
 	HV *hv;
 	GvMULTI_on(PL_envgv);
 	hv = GvHVn(PL_envgv);
@@ -3167,7 +3213,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
 #endif
     }
     TAINT_NOT;
-    if (tmpgv = gv_fetchpv("$",TRUE, SVt_PV))
+    if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
 	sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
 }
 
@@ -3179,9 +3225,9 @@ S_init_perllib(pTHX)
 #ifndef VMS
 	s = PerlEnv_getenv("PERL5LIB");
 	if (s)
-	    incpush(s, TRUE);
+	    incpush(s, TRUE, TRUE);
 	else
-	    incpush(PerlEnv_getenv("PERLLIB"), FALSE);
+	    incpush(PerlEnv_getenv("PERLLIB"), FALSE, 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
@@ -3190,57 +3236,73 @@ S_init_perllib(pTHX)
 	char buf[256];
 	int idx = 0;
 	if (my_trnlnm("PERL5LIB",buf,0))
-	    do { incpush(buf,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
+	    do { incpush(buf,TRUE,TRUE); } while (my_trnlnm("PERL5LIB",buf,++idx));
 	else
-	    while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE);
+	    while (my_trnlnm("PERLLIB",buf,idx++)) incpush(buf,FALSE,FALSE);
 #endif /* VMS */
     }
 
 /* Use the ~-expanded versions of APPLLIB (undocumented),
-    ARCHLIB PRIVLIB SITEARCH and SITELIB 
+    ARCHLIB PRIVLIB SITEARCH SITELIB VENDORARCH and VENDORLIB
 */
 #ifdef APPLLIB_EXP
-    incpush(APPLLIB_EXP, TRUE);
+    incpush(APPLLIB_EXP, TRUE, TRUE);
 #endif
 
 #ifdef ARCHLIB_EXP
-    incpush(ARCHLIB_EXP, FALSE);
+    incpush(ARCHLIB_EXP, FALSE, FALSE);
 #endif
 #ifndef PRIVLIB_EXP
-#define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
+#  define PRIVLIB_EXP "/usr/local/lib/perl5:/usr/local/lib/perl"
 #endif
 #if defined(WIN32) 
-    incpush(PRIVLIB_EXP, TRUE);
+    incpush(PRIVLIB_EXP, TRUE, FALSE);
 #else
-    incpush(PRIVLIB_EXP, FALSE);
+    incpush(PRIVLIB_EXP, FALSE, FALSE);
+#endif
+
+#ifdef SITEARCH_EXP
+    /* sitearch is always relative to sitelib on Windows for
+     * DLL-based path intuition to work correctly */
+#  if !defined(WIN32)
+    incpush(SITEARCH_EXP, FALSE, FALSE);
+#  endif
 #endif
 
-#if defined(WIN32)
-    incpush(SITELIB_EXP, TRUE);	/* XXX Win32 needs inc_version_list support */
-#else
 #ifdef SITELIB_EXP
-    {
-	char *path = SITELIB_EXP;
-
-	if (path) {
-	    char buf[1024];
-	    strcpy(buf,path);
-	    if (strrchr(buf,'/'))	/* XXX Hack, Configure var needed */
-		*strrchr(buf,'/') = '\0';
-	    incpush(buf, TRUE);
-	}
-    }
+#  if defined(WIN32)
+    incpush(SITELIB_EXP, TRUE, FALSE);	/* this picks up sitearch as well */
+#  else
+    incpush(SITELIB_EXP, FALSE, FALSE);
+#  endif
 #endif
+
+#ifdef SITELIB_STEM /* Search for version-specific dirs below here */
+    incpush(SITELIB_STEM, FALSE, TRUE);
 #endif
-#if defined(PERL_VENDORLIB_EXP)
-#if defined(WIN32) 
-    incpush(PERL_VENDORLIB_EXP, TRUE);
-#else
-    incpush(PERL_VENDORLIB_EXP, FALSE);
+
+#ifdef PERL_VENDORARCH_EXP
+    /* vendorarch is always relative to vendorlib on Windows for
+     * DLL-based path intuition to work correctly */
+#  if !defined(WIN32)
+    incpush(PERL_VENDORARCH_EXP, FALSE, FALSE);
+#  endif
+#endif
+
+#ifdef PERL_VENDORLIB_EXP
+#  if defined(WIN32)
+    incpush(PERL_VENDORLIB_EXP, TRUE, FALSE);	/* this picks up vendorarch as well */
+#  else
+    incpush(PERL_VENDORLIB_EXP, FALSE, FALSE);
+#  endif
 #endif
+
+#ifdef PERL_VENDORLIB_STEM /* Search for version-specific dirs below here */
+    incpush(PERL_VENDORLIB_STEM, FALSE, TRUE);
 #endif
+
     if (!PL_tainting)
-	incpush(".", FALSE);
+	incpush(".", FALSE, FALSE);
 }
 
 #if defined(DOSISH)
@@ -3257,14 +3319,14 @@ S_init_perllib(pTHX)
 #endif 
 
 STATIC void
-S_incpush(pTHX_ char *p, int addsubdirs)
+S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
 {
     SV *subdir = Nullsv;
 
-    if (!p)
+    if (!p || !*p)
 	return;
 
-    if (addsubdirs) {
+    if (addsubdirs || addoldvers) {
 	subdir = sv_newmortal();
     }
 
@@ -3294,7 +3356,7 @@ S_incpush(pTHX_ char *p, int addsubdirs)
 	 * BEFORE pushing libdir onto @INC we may first push version- and
 	 * archname-specific sub-directories.
 	 */
-	if (addsubdirs) {
+	if (addsubdirs || addoldvers) {
 #ifdef PERL_INC_VERSION_LIST
 	    /* Configure terminates PERL_INC_VERSION_LIST with a NULL */
 	    const char *incverlist[] = { PERL_INC_VERSION_LIST };
@@ -3315,35 +3377,40 @@ S_incpush(pTHX_ char *p, int addsubdirs)
 		              "Failed to unixify @INC element \"%s\"\n",
 			      SvPV(libdir,len));
 #endif
-	    /* .../version/archname if -d .../version/archname */
-	    Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", libdir,
-			   (int)PERL_REVISION, (int)PERL_VERSION,
-			   (int)PERL_SUBVERSION, ARCHNAME);
-	    if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
-		  S_ISDIR(tmpstatbuf.st_mode))
-		av_push(GvAVn(PL_incgv), newSVsv(subdir));
-
-	    /* .../version if -d .../version */
-	    Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
-			   (int)PERL_REVISION, (int)PERL_VERSION,
-			   (int)PERL_SUBVERSION);
-	    if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
-		  S_ISDIR(tmpstatbuf.st_mode))
-		av_push(GvAVn(PL_incgv), newSVsv(subdir));
-
-	    /* .../archname if -d .../archname */
-	    Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
-	    if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
-		  S_ISDIR(tmpstatbuf.st_mode))
-		av_push(GvAVn(PL_incgv), newSVsv(subdir));
+	    if (addsubdirs) {
+		/* .../version/archname if -d .../version/archname */
+		Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT"/%s", 
+				libdir,
+			       (int)PERL_REVISION, (int)PERL_VERSION,
+			       (int)PERL_SUBVERSION, ARCHNAME);
+		if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+		      S_ISDIR(tmpstatbuf.st_mode))
+		    av_push(GvAVn(PL_incgv), newSVsv(subdir));
 
-#ifdef PERL_INC_VERSION_LIST
-	    for (incver = incverlist; *incver; incver++) {
-		/* .../xxx if -d .../xxx */
-		Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
+		/* .../version if -d .../version */
+		Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/"PERL_FS_VER_FMT, libdir,
+			       (int)PERL_REVISION, (int)PERL_VERSION,
+			       (int)PERL_SUBVERSION);
 		if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
 		      S_ISDIR(tmpstatbuf.st_mode))
 		    av_push(GvAVn(PL_incgv), newSVsv(subdir));
+
+		/* .../archname if -d .../archname */
+		Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, ARCHNAME);
+		if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+		      S_ISDIR(tmpstatbuf.st_mode))
+		    av_push(GvAVn(PL_incgv), newSVsv(subdir));
+	    }
+
+	    if (addoldvers) {
+#ifdef PERL_INC_VERSION_LIST
+		for (incver = incverlist; *incver; incver++) {
+		    /* .../xxx if -d .../xxx */
+		    Perl_sv_setpvf(aTHX_ subdir, "%"SVf"/%s", libdir, *incver);
+		    if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
+			  S_ISDIR(tmpstatbuf.st_mode))
+			av_push(GvAVn(PL_incgv), newSVsv(subdir));
+		}
 	    }
 #endif
 	}
@@ -3401,7 +3468,7 @@ S_init_main_thread(pTHX)
 #else
     thr->self = pthread_self();
 #endif /* SET_THREAD_SELF */
-    SET_THR(thr);
+    PERL_SET_THX(thr);
 
     /*
      * These must come after the SET_THR because sv_setpvn does