X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=302faf108897324c15ff773776e83f0fd5784a51;hb=02c473a9139e94d6158d1e3dd9a912f3525b3b21;hp=1040163fedc6383def1a817172827af7bba64a6d;hpb=dedbcade96321798da47de9721e77227a1c11eb5;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perl.c b/perl.c
index 1040163..302faf1 100644
--- a/perl.c
+++ b/perl.c
@@ -237,11 +237,15 @@ perl_construct(pTHXx)
 	    SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
 
 	    sv_setpv(&PL_sv_no,PL_No);
+	    /* value lookup in void context - happens to have the side effect
+	       of caching the numeric forms.  */
+	    SvIV(&PL_sv_no);
 	    SvNV(&PL_sv_no);
 	    SvREADONLY_on(&PL_sv_no);
 	    SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
 
 	    sv_setpv(&PL_sv_yes,PL_Yes);
+	    SvIV(&PL_sv_yes);
 	    SvNV(&PL_sv_yes);
 	    SvREADONLY_on(&PL_sv_yes);
 	    SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
@@ -312,8 +316,9 @@ perl_construct(pTHXx)
 #endif
 
     /* Use sysconf(_SC_CLK_TCK) if available, if not
-     * available or if the sysconf() fails, use the HZ. */
-#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK)
+     * available or if the sysconf() fails, use the HZ.
+     * BeOS has those, but returns the wrong value. */
+#if defined(HAS_SYSCONF) && defined(_SC_CLK_TCK) && !defined(__BEOS__)
     PL_clocktick = sysconf(_SC_CLK_TCK);
     if (PL_clocktick <= 0)
 #endif
@@ -467,7 +472,7 @@ perl_destruct(pTHXx)
      */
 #ifndef PERL_MICRO
 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
-    if (environ != PL_origenviron
+    if (environ != PL_origenviron && !PL_use_safe_putenv
 #ifdef USE_ITHREADS
 	/* only main thread can free environ[0] contents */
 	&& PL_curinterp == aTHX
@@ -487,6 +492,9 @@ perl_destruct(pTHXx)
 #endif
 #endif /* !PERL_MICRO */
 
+    /* reset so print() ends up where we expect */
+    setdefout(Nullgv);
+
 #ifdef USE_ITHREADS
     /* the syntax tree is shared between clones
      * so op_free(PL_main_root) only ReREFCNT_dec's
@@ -628,9 +636,6 @@ perl_destruct(pTHXx)
     PL_dbargs = Nullav;
     PL_debstash = Nullhv;
 
-    /* reset so print() ends up where we expect */
-    setdefout(Nullgv);
-
     SvREFCNT_dec(PL_argvout_stack);
     PL_argvout_stack = Nullav;
 
@@ -837,9 +842,10 @@ perl_destruct(pTHXx)
 	    svend = &sva[SvREFCNT(sva)];
 	    for (sv = sva + 1; sv < svend; ++sv) {
 		if (SvTYPE(sv) != SVTYPEMASK) {
-		    PerlIO_printf(Perl_debug_log, "leaked: 0x%p"
-                                  pTHX__FORMAT "\n",
-                                  sv pTHX__VALUE);
+		    PerlIO_printf(Perl_debug_log, "leaked: sv=0x%p"
+			" flags=0x08%"UVxf
+			" refcnt=%"UVuf pTHX__FORMAT "\n",
+			sv, sv->sv_flags, sv->sv_refcnt pTHX__VALUE);
 		}
 	    }
 	}
@@ -911,7 +917,7 @@ perl_destruct(pTHXx)
 	    }
 	}
 	/* we know that type >= SVt_PV */
-	(void)SvOOK_off(PL_mess_sv);
+	SvOOK_off(PL_mess_sv);
 	Safefree(SvPVX(PL_mess_sv));
 	Safefree(SvANY(PL_mess_sv));
 	Safefree(PL_mess_sv);
@@ -2373,12 +2379,12 @@ NULL
 
 #ifdef DEBUGGING
 int
-Perl_get_debug_opts(pTHX_ char **s)
+Perl_get_debug_opts(pTHX_ char **s, bool givehelp)
 {
     static char *usage_msgd[] = {
       " Debugging flag values: (see also -d)",
       "  p  Tokenizing and parsing (with v, displays parse stack)",
-      "  s  Stack snapshots. with v, displays all stacks",
+      "  s  Stack snapshots (with v, displays all stacks)",
       "  l  Context (loop) stack processing",
       "  t  Trace execution",
       "  o  Method and overloading resolution",
@@ -2388,7 +2394,7 @@ Perl_get_debug_opts(pTHX_ char **s)
       "  f  Format processing",
       "  r  Regular expression parsing and execution",
       "  x  Syntax tree dump",
-      "  u  Tainting checks (Obsolete, previously used for LEAKTEST)",
+      "  u  Tainting checks",
       "  H  Hash dump -- usurps values()",
       "  X  Scratchpad allocation",
       "  D  Cleaning up",
@@ -2399,7 +2405,7 @@ Perl_get_debug_opts(pTHX_ char **s)
       "  v  Verbose: use in conjunction with other flags",
       "  C  Copy On Write",
       "  A  Consistency checks on internal structures",
-      "  q  quiet - currently only suppressed the 'EXECUTING' message",
+      "  q  quiet - currently only suppresses the 'EXECUTING' message",
       NULL
     };
     int i = 0;
@@ -2420,7 +2426,7 @@ Perl_get_debug_opts(pTHX_ char **s)
 	i = atoi(*s);
 	for (; isALNUM(**s); (*s)++) ;
     }
-    else {
+    else if (givehelp) {
       char **p = usage_msgd;
       while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
     }
@@ -2504,6 +2510,13 @@ Perl_moreswitches(pTHX_ char *s)
     case 'd':
 	forbid_setid("-d");
 	s++;
+
+        /* -dt indicates to the debugger that threads will be used */
+	if (*s == 't' && !isALNUM(s[1])) {
+	    ++s;
+	    my_setenv("PERL5DB_THREADED", "1");
+	}
+
 	/* The following permits -d:Mod to accepts arguments following an =
 	   in the fashion that -MSome::Mod does. */
 	if (*s == ':' || *s == '=') {
@@ -2534,7 +2547,7 @@ Perl_moreswitches(pTHX_ char *s)
 #ifdef DEBUGGING
 	forbid_setid("-D");
 	s++;
-	PL_debug = get_debug_opts(&s) | DEBUG_TOP_FLAG;
+	PL_debug = get_debug_opts(&s, 1) | DEBUG_TOP_FLAG;
 #else /* !DEBUGGING */
 	if (ckWARN_d(WARN_DEBUGGING))
 	    Perl_warner(aTHX_ packWARN(WARN_DEBUGGING),
@@ -2666,7 +2679,7 @@ Perl_moreswitches(pTHX_ char *s)
 	    av_push(PL_preambleav, sv);
 	}
 	else
-	    Perl_croak(aTHX_ "No space allowed after -%c", *(s-1));
+	    Perl_croak(aTHX_ "Missing argument to -%c", *(s-1));
 	return s;
     case 'n':
 	PL_minus_n = TRUE;
@@ -2803,7 +2816,7 @@ 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 source kit.\n\n\
 Complete documentation for Perl, including FAQ lists, should be found on\n\
 this system using `man perl' or `perldoc perl'.  If you have access to the\n\
-Internet, point your browser at http://www.perl.com/, the Perl Home Page.\n\n");
+Internet, point your browser at http://www.perl.org/, the Perl Home Page.\n\n");
 	my_exit(0);
     case 'w':
 	if (! (PL_dowarn & G_WARN_ALL_MASK))
@@ -3415,7 +3428,8 @@ S_validate_suid(pTHX_ char *validarg, char *scriptname)
 	/* Sanity check on buffer end */
 	while ((*s) && !isSPACE(*s)) s++;
 	for (s2 = s;  (s2 > SvPV(PL_linestr,n_a)+2 &&
-		       (isDIGIT(s2[-1]) || strchr("._-", s2[-1])));  s2--) ;
+		       (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
+			|| s2[-1] == '-'));  s2--) ;
 	/* Sanity check on buffer start */
 	if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
 	      (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
@@ -3702,7 +3716,8 @@ S_find_beginning(pTHX)
 	    s2 = s;
 	    while (*s == ' ' || *s == '\t') s++;
 	    if (*s++ == '-') {
-		while (isDIGIT(s2[-1]) || strchr("-._", s2[-1])) s2--;
+		while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
+		       || s2[-1] == '_') s2--;
 		if (strnEQ(s2-4,"perl",4))
 		    /*SUPPRESS 530*/
 		    while ((s = moreswitches(s)))
@@ -4037,6 +4052,22 @@ S_procself_val(pTHX_ SV *sv, char *arg0)
 #endif /* HAS_PROCSELFEXE */
 
 STATIC void
+S_set_caret_X(pTHX) {
+    GV* tmpgv = gv_fetchpv("\030",TRUE, SVt_PV); /* $^X */
+    if (tmpgv) {
+#ifdef HAS_PROCSELFEXE
+	S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
+#else
+#ifdef OS2
+	sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
+#else
+	sv_setpv(GvSV(tmpgv),PL_origargv[0]);
+#endif
+#endif
+    }
+}
+
+STATIC void
 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
 {
     char *s;
@@ -4064,17 +4095,7 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
 	magicname("0", "0", 1);
 #endif
     }
-    if ((tmpgv = gv_fetchpv("\030",TRUE, SVt_PV))) {/* $^X */
-#ifdef HAS_PROCSELFEXE
-	S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
-#else
-#ifdef OS2
-	sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
-#else
-	sv_setpv(GvSV(tmpgv),PL_origargv[0]);
-#endif
-#endif
-    }
+    S_set_caret_X(aTHX);
     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
 	HV *hv;
 	GvMULTI_on(PL_envgv);
@@ -4097,9 +4118,10 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
 	{
 	    environ[0] = Nullch;
 	}
-	if (env)
+	if (env) {
+          char** origenv = environ;
 	  for (; *env; env++) {
-	    if (!(s = strchr(*env,'=')))
+	    if (!(s = strchr(*env,'=')) || s == *env)
 		continue;
 #if defined(MSDOS) && !defined(DJGPP)
 	    *s = '\0';
@@ -4110,7 +4132,13 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
 	    (void)hv_store(hv, *env, s - *env, sv, 0);
 	    if (env != environ)
 	        mg_set(sv);
+	    if (origenv != environ) {
+	      /* realloc has shifted us */
+	      env = (env - origenv) + environ;
+	      origenv = environ;
+	    }
 	  }
+      }
 #endif /* USE_ENVIRON_ARRAY */
 #endif /* !PERL_MICRO */
     }
@@ -4265,6 +4293,21 @@ S_init_perllib(pTHX)
 #  define PERLLIB_MANGLE(s,n) (s)
 #endif
 
+/* Push a directory onto @INC if it exists.
+   Generate a new SV if we do this, to save needing to copy the SV we push
+   onto @INC  */
+STATIC SV *
+S_incpush_if_exists(pTHX_ SV *dir)
+{
+    Stat_t tmpstatbuf;
+    if (PerlLIO_stat(SvPVX(dir), &tmpstatbuf) >= 0 &&
+	S_ISDIR(tmpstatbuf.st_mode)) {
+	av_push(GvAVn(PL_incgv), dir);
+	dir = NEWSV(0,0);
+    }
+    return dir;
+}
+
 STATIC void
 S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
 {
@@ -4274,7 +4317,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
 	return;
 
     if (addsubdirs || addoldvers) {
-	subdir = sv_newmortal();
+	subdir = NEWSV(0,0);
     }
 
     /* Break at all separators */
@@ -4320,7 +4363,6 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
 	    const char *incverlist[] = { PERL_INC_VERSION_LIST };
 	    const char **incver;
 #endif
-	    Stat_t tmpstatbuf;
 #ifdef VMS
 	    char *unix;
 	    STRLEN len;
@@ -4350,23 +4392,18 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
 				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));
+		subdir = S_incpush_if_exists(aTHX_ subdir);
 
 		/* .../version if -d .../version */
 		Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT_PATH, 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));
+		subdir = S_incpush_if_exists(aTHX_ subdir);
 
 		/* .../archname if -d .../archname */
 		Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, ARCHNAME);
-		if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
-		      S_ISDIR(tmpstatbuf.st_mode))
-		    av_push(GvAVn(PL_incgv), newSVsv(subdir));
+		subdir = S_incpush_if_exists(aTHX_ subdir);
+
 	    }
 
 #ifdef PERL_INC_VERSION_LIST
@@ -4374,9 +4411,7 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
 		for (incver = incverlist; *incver; incver++) {
 		    /* .../xxx if -d .../xxx */
 		    Perl_sv_setpvf(aTHX_ subdir, "%"SVf PERL_ARCH_FMT, libdir, *incver);
-		    if (PerlLIO_stat(SvPVX(subdir), &tmpstatbuf) >= 0 &&
-			  S_ISDIR(tmpstatbuf.st_mode))
-			av_push(GvAVn(PL_incgv), newSVsv(subdir));
+		    subdir = S_incpush_if_exists(aTHX_ subdir);
 		}
 	    }
 #endif
@@ -4385,6 +4420,10 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers, int usesep)
 	/* finally push this lib directory on the end of @INC */
 	av_push(GvAVn(PL_incgv), libdir);
     }
+    if (subdir) {
+	assert (SvREFCNT(subdir) == 1);
+	SvREFCNT_dec(subdir);
+    }
 }
 
 #ifdef USE_5005THREADS