X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=f7131d0682b9d73b4c3750f31d9727cb0d874192;hb=484fdf61e8653b10160ba1e8011888f52ab6825a;hp=7b6eb62b33188f4363b4c23f09f04662590781fc;hpb=011f1a1a00b94fe919083a224d5df636f05ae32a;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perl.c b/perl.c
index 7b6eb62..f7131d0 100644
--- a/perl.c
+++ b/perl.c
@@ -431,18 +431,19 @@ perl_destruct(pTHXx)
     FREETMPS;
 
     /* Need to flush since END blocks can produce output */
-    PerlIO_flush((PerlIO*)NULL); 
+    my_fflush_all();
 
     if (CALL_FPTR(PL_threadhook)(aTHX)) {
         /* Threads hook has vetoed further cleanup */
-        return STATUS_NATIVE_EXPORT;;
+        return STATUS_NATIVE_EXPORT;
     }
 
     /* We must account for everything.  */
 
     /* Destroy the main CV and syntax tree */
     if (PL_main_root) {
-	PL_curpad = AvARRAY(PL_comppad);
+        /* If running under -d may not have PL_comppad. */
+        PL_curpad = PL_comppad ? AvARRAY(PL_comppad) : NULL;
 	op_free(PL_main_root);
 	PL_main_root = Nullop;
     }
@@ -490,7 +491,7 @@ perl_destruct(pTHXx)
 #endif
 
 	/* The exit() function will do everything that needs doing. */
-        return STATUS_NATIVE_EXPORT;;
+        return STATUS_NATIVE_EXPORT;
     }
 
     /* jettison our possibly duplicated environment */
@@ -498,7 +499,13 @@ perl_destruct(pTHXx)
      * so we certainly shouldn't free it here
      */
 #if defined(USE_ENVIRON_ARRAY) && !defined(PERL_USE_SAFE_PUTENV)
-    if (environ != PL_origenviron) {
+    if (environ != PL_origenviron
+#ifdef USE_ITHREADS
+	/* only main thread can free environ[0] contents */
+	&& PL_curinterp == aTHX
+#endif
+	)
+    {
 	I32 i;
 
 	for (i = 0; environ[i]; i++)
@@ -825,9 +832,6 @@ perl_destruct(pTHXx)
     SvANY(&PL_sv_no) = NULL;
     SvFLAGS(&PL_sv_no) = 0;
 
-    SvREFCNT(&PL_sv_undef) = 0;
-    SvREADONLY_off(&PL_sv_undef);
-
     {
         int i;
         for (i=0; i<=2; i++) {
@@ -846,6 +850,13 @@ perl_destruct(pTHXx)
     PerlIO_cleanup(aTHX);
 #endif
 
+    /* sv_undef needs to stay immortal until after PerlIO_cleanup
+       as currently layers use it rather than Nullsv as a marker
+       for no arg - and will try and SvREFCNT_dec it.
+     */
+    SvREFCNT(&PL_sv_undef) = 0;
+    SvREADONLY_off(&PL_sv_undef);
+
     Safefree(PL_origfilename);
     Safefree(PL_reg_start_tmp);
     if (PL_reg_curpm)
@@ -1468,10 +1479,15 @@ print \"  \\@INC:\\n    @INC\\n\";");
     if (!PL_do_undump)
 	init_postdump_symbols(argc,argv,env);
 
+    /* PL_wantutf8 is conditionally turned on by
+     * locale.c:Perl_init_i18nl10n() if the environment
+     * look like the user wants to use UTF-8. */
     if (PL_wantutf8) { /* Requires init_predump_symbols(). */
 	 IO* io;
 	 PerlIO* fp;
 	 SV* sv;
+	 /* Turn on UTF-8-ness on STDIN, STDOUT, STDERR
+	  *  _and_ the default open discipline. */
 	 if (PL_stdingv  && (io = GvIO(PL_stdingv))  && (fp = IoIFP(io)))
 	      PerlIO_binmode(aTHX_ fp, IoTYPE(io), 0, ":utf8");
 	 if (PL_defoutgv && (io = GvIO(PL_defoutgv)) && (fp = IoOFP(io)))
@@ -1638,7 +1654,9 @@ S_run_body(pTHX_ I32 oldscope)
 
 	if (PL_minus_c) {
 #ifdef MACOS_TRADITIONAL
-	    PerlIO_printf(Perl_error_log, "# %s syntax OK\n", MacPerl_MPWFileName(PL_origfilename));
+	    PerlIO_printf(Perl_error_log, "%s%s syntax OK\n",
+		(gMacPerl_ErrorFormat ? "# " : ""),
+		MacPerl_MPWFileName(PL_origfilename));
 #else
 	    PerlIO_printf(Perl_error_log, "%s syntax OK\n", PL_origfilename);
 #endif
@@ -2347,10 +2365,16 @@ Perl_moreswitches(pTHX_ char *s)
     }	
     case 'h':
 	usage(PL_origargv[0]);
-	PerlProc_exit(0);
+	my_exit(0);
     case 'i':
 	if (PL_inplace)
 	    Safefree(PL_inplace);
+#if defined(__CYGWIN__) /* do backup extension automagically */
+	if (*(s+1) == '\0') {
+	PL_inplace = savepv(".bak");
+	return s+1;
+	}
+#endif /* __CYGWIN__ */
 	PL_inplace = savepv(s+1);
 	/*SUPPRESS 530*/
 	for (s = PL_inplace; *s && !isSPACE(*s); s++) ;
@@ -2579,7 +2603,7 @@ 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");
-	PerlProc_exit(0);
+	my_exit(0);
     case 'w':
 	if (! (PL_dowarn & G_WARN_ALL_MASK))
 	    PL_dowarn |= G_WARN_ON;
@@ -3505,6 +3529,17 @@ S_procself_val(pTHX_ SV *sv, char *arg0)
 {
     char buf[MAXPATHLEN];
     int len = readlink(PROCSELFEXE_PATH, buf, sizeof(buf) - 1);
+
+    /* On Playstation2 Linux V1.0 (kernel 2.2.1) readlink(/proc/self/exe)
+       includes a spurious NUL which will cause $^X to fail in system
+       or backticks (this will prevent extensions from being built and
+       many tests from working). readlink is not meant to add a NUL.
+       Normal readlink works fine.
+     */
+    if (len > 0 && buf[len-1] == '\0') {
+      len--;
+    }
+
     /* FreeBSD's implementation is acknowledged to be imperfect, sometimes
        returning the text "unknown" from the readlink rather than the path
        to the executable (or returning an error from the readlink).  Any valid
@@ -3572,8 +3607,14 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
 	*/
 	if (!env)
 	    env = environ;
-	if (env != environ)
+	if (env != environ
+#  ifdef USE_ITHREADS
+	    && PL_curinterp == aTHX
+#  endif
+	   )
+	{
 	    environ[0] = Nullch;
+	}
 	if (env)
 	  for (; *env; env++) {
 	    if (!(s = strchr(*env,'=')))
@@ -3771,8 +3812,11 @@ S_incpush(pTHX_ char *p, int addsubdirs, int addoldvers)
 	    p = Nullch;	/* break out */
 	}
 #ifdef MACOS_TRADITIONAL
-	if (!strchr(SvPVX(libdir), ':'))
-	    sv_insert(libdir, 0, 0, ":", 1);
+	if (!strchr(SvPVX(libdir), ':')) {
+	    char buf[256];
+
+	    sv_setpv(libdir, MacPerl_CanonDir(SvPVX(libdir), buf, 0));
+	}
 	if (SvPVX(libdir)[SvCUR(libdir)-1] != ':')
 	    sv_catpv(libdir, ":");
 #endif