X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=50e7aa1bcb76a884e5f9b1decd50fbf8d265469a;hb=d54344fc28d39ef8e90173262ec572bec67f5e6c;hp=13c7d31581982991f49f1284287cc8a36d3da6dc;hpb=b51d9c98646cc7c622f6896e9d6e994eeebd7ba5;p=p5sagit%2Fp5-mst-13.2.git

diff --git a/perl.c b/perl.c
index 13c7d31..50e7aa1 100644
--- a/perl.c
+++ b/perl.c
@@ -273,12 +273,6 @@ perl_construct(pTHXx)
     New(31337, PL_reentrant_buffer->tmbuff,1, struct tm);
 #endif
 
-#ifdef DEBUGGING
-    sv_setpvn(PERL_DEBUG_PAD(0), "", 0);
-    sv_setpvn(PERL_DEBUG_PAD(1), "", 0);
-    sv_setpvn(PERL_DEBUG_PAD(2), "", 0);
-#endif
-
     /* Note that strtab is a rather special HV.  Assumptions are made
        about not iterating on it, and not adding tie magic to it.
        It is properly deallocated in perl_destruct() */
@@ -1105,6 +1099,10 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 		goto reswitch;
 	    break;
 
+	case 't':
+	    PL_taint_warn = TRUE;
+	    if (! (PL_dowarn & G_WARN_ALL_MASK))
+	        PL_dowarn |= G_WARN_ON;
 	case 'T':
 	    PL_tainting = TRUE;
 	    s++;
@@ -1301,7 +1299,7 @@ print \"  \\@INC:\\n    @INC\\n\";");
 		d = s;
 		if (!*s)
 		    break;
-		if (!strchr("DIMUdmw", *s))
+		if (!strchr("DIMUdmtw", *s))
 		    Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
 		while (++s && *s) {
 		    if (isSPACE(*s)) {
@@ -1314,7 +1312,12 @@ print \"  \\@INC:\\n    @INC\\n\";");
 			break;
 		    }
 		}
-		moreswitches(d);
+		if (*d == 't') {
+		    PL_tainting = TRUE;
+		    PL_taint_warn = TRUE;
+		} else {
+		    moreswitches(d);
+		}
 	    }
 	}
     }
@@ -2379,6 +2382,11 @@ Perl_moreswitches(pTHX_ char *s)
 	PL_doswitches = TRUE;
 	s++;
 	return s;
+    case 't':
+        if (!PL_tainting)
+            Perl_croak(aTHX_ "Too late for \"-t\" option");
+        s++;
+        return s;
     case 'T':
 	if (!PL_tainting)
 	    Perl_croak(aTHX_ "Too late for \"-T\" option");
@@ -2651,6 +2659,11 @@ S_init_main_stash(pTHX)
 STATIC void
 S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
 {
+    char *quote;
+    char *code;
+    char *cpp_discard_flag;
+    char *perl;
+
     *fdscript = -1;
 
     if (PL_e_script) {
@@ -2673,20 +2686,21 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
 	}
     }
 
-#ifdef USE_ITHREADS
-    Safefree(CopFILE(PL_curcop));
-#else
-    SvREFCNT_dec(CopFILEGV(PL_curcop));
-#endif
+#   ifdef USE_ITHREADS
+        Safefree(CopFILE(PL_curcop));
+#   else
+        SvREFCNT_dec(CopFILEGV(PL_curcop));
+#   endif
     CopFILE_set(PL_curcop, PL_origfilename);
     if (strEQ(PL_origfilename,"-"))
 	scriptname = "";
     if (*fdscript >= 0) {
 	PL_rsfp = PerlIO_fdopen(*fdscript,PERL_SCRIPT_MODE);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
-	if (PL_rsfp)
-	    fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
-#endif
+#       if defined(HAS_FCNTL) && defined(F_SETFD)
+	    if (PL_rsfp)
+                /* ensure close-on-exec */
+	        fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
+#       endif
     }
     else if (PL_preprocess) {
 	char *cpp_cfg = CPPSTDIN;
@@ -2697,88 +2711,73 @@ S_open_script(pTHX_ char *scriptname, bool dosearch, SV *sv, int *fdscript)
 	    Perl_sv_catpvf(aTHX_ cpp, "%s/", BIN_EXP);
 	sv_catpv(cpp, cpp_cfg);
 
-	sv_catpvn(sv, "-I", 2);
-	sv_catpv(sv,PRIVLIB_EXP);
+#       ifndef VMS
+	    sv_catpvn(sv, "-I", 2);
+	    sv_catpv(sv,PRIVLIB_EXP);
+#       endif
 
 	DEBUG_P(PerlIO_printf(Perl_debug_log,
 			      "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
 			      scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
-#if defined(MSDOS) || defined(WIN32)
-	Perl_sv_setpvf(aTHX_ cmd, "\
-sed %s -e \"/^[^#]/b\" \
- -e \"/^#[ 	]*include[ 	]/b\" \
- -e \"/^#[ 	]*define[ 	]/b\" \
- -e \"/^#[ 	]*if[ 	]/b\" \
- -e \"/^#[ 	]*ifdef[ 	]/b\" \
- -e \"/^#[ 	]*ifndef[ 	]/b\" \
- -e \"/^#[ 	]*else/b\" \
- -e \"/^#[ 	]*elif[ 	]/b\" \
- -e \"/^#[ 	]*undef[ 	]/b\" \
- -e \"/^#[ 	]*endif/b\" \
- -e \"s/^#.*//\" \
- %s | %"SVf" -C %"SVf" %s",
-	  (PL_doextract ? "-e \"1,/^#/d\n\"" : ""),
-#else
-#  ifdef __OPEN_VM
-	Perl_sv_setpvf(aTHX_ cmd, "\
-%s %s -e '/^[^#]/b' \
- -e '/^#[ 	]*include[ 	]/b' \
- -e '/^#[ 	]*define[ 	]/b' \
- -e '/^#[ 	]*if[ 	]/b' \
- -e '/^#[ 	]*ifdef[ 	]/b' \
- -e '/^#[ 	]*ifndef[ 	]/b' \
- -e '/^#[ 	]*else/b' \
- -e '/^#[ 	]*elif[ 	]/b' \
- -e '/^#[ 	]*undef[ 	]/b' \
- -e '/^#[ 	]*endif/b' \
- -e 's/^[ 	]*#.*//' \
- %s | %"SVf" %"SVf" %s",
-#  else
-	Perl_sv_setpvf(aTHX_ cmd, "\
-%s %s -e '/^[^#]/b' \
- -e '/^#[ 	]*include[ 	]/b' \
- -e '/^#[ 	]*define[ 	]/b' \
- -e '/^#[ 	]*if[ 	]/b' \
- -e '/^#[ 	]*ifdef[ 	]/b' \
- -e '/^#[ 	]*ifndef[ 	]/b' \
- -e '/^#[ 	]*else/b' \
- -e '/^#[ 	]*elif[ 	]/b' \
- -e '/^#[ 	]*undef[ 	]/b' \
- -e '/^#[ 	]*endif/b' \
- -e 's/^[ 	]*#.*//' \
- %s | %"SVf" -C %"SVf" %s",
-#  endif
-#ifdef LOC_SED
-	  LOC_SED,
-#else
-	  "sed",
-#endif
-	  (PL_doextract ? "-e '1,/^#/d\n'" : ""),
-#endif
-	  scriptname, cpp, sv, CPPMINUS);
+
+#       if defined(MSDOS) || defined(WIN32) || defined(VMS)
+            quote = "\"";
+#       else
+            quote = "'";
+#       endif
+
+#       ifdef VMS
+            cpp_discard_flag = "";
+#       else
+            cpp_discard_flag = "-C";
+#       endif
+
+#       ifdef OS2
+            perl = os2_execname(aTHX);
+#       else
+            perl = PL_origargv[0];
+#       endif
+
+
+        /* This strips off Perl comments which might interfere with
+           the C pre-processor, including #!.  #line directives are 
+           deliberately stripped to avoid confusion with Perl's version 
+           of #line.  FWP played some golf with it so it will fit
+           into VMS's 255 character buffer.
+        */
+        if( PL_doextract )
+            code = "(1../^#!.*perl/i)|/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
+        else
+            code = "/^\\s*#(?!\\s*((ifn?|un)def|(el|end)?if|define|include|else|error|pragma)\\b)/||!($|=1)||print";
+
+        Perl_sv_setpvf(aTHX_ cmd, "\
+%s -ne%s%s%s %s | %"SVf" %s %"SVf" %s",
+                       perl, quote, code, quote, scriptname, cpp, 
+                       cpp_discard_flag, sv, CPPMINUS);
+
 	PL_doextract = FALSE;
-#ifdef IAMSUID				/* actually, this is caught earlier */
-	if (PL_euid != PL_uid && !PL_euid) {	/* if running suidperl */
-#ifdef HAS_SETEUID
-	    (void)seteuid(PL_uid);		/* musn't stay setuid root */
-#else
-#ifdef HAS_SETREUID
-	    (void)setreuid((Uid_t)-1, PL_uid);
-#else
-#ifdef HAS_SETRESUID
-	    (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
-#else
-	    PerlProc_setuid(PL_uid);
-#endif
-#endif
-#endif
+#       ifdef IAMSUID			/* actually, this is caught earlier */
+	    if (PL_euid != PL_uid && !PL_euid) {  /* if running suidperl */
+#               ifdef HAS_SETEUID
+	            (void)seteuid(PL_uid);	  /* musn't stay setuid root */
+#               else
+#               ifdef HAS_SETREUID
+	            (void)setreuid((Uid_t)-1, PL_uid);
+#               else
+#               ifdef HAS_SETRESUID
+	            (void)setresuid((Uid_t)-1, PL_uid, (Uid_t)-1);
+#               else
+	            PerlProc_setuid(PL_uid);
+#               endif
+#               endif
+#               endif
 	    if (PerlProc_geteuid() != PL_uid)
 		Perl_croak(aTHX_ "Can't do seteuid!\n");
 	}
-#endif /* IAMSUID */
+#       endif /* IAMSUID */
 
-        DEBUG_P(PerlIO_printf(Perl_debug_log,
-                              "PL_preprocess: cmd=\"%s\"\n",
+        DEBUG_P(PerlIO_printf(Perl_debug_log, 
+                              "PL_preprocess: cmd=\"%s\"\n", 
                               SvPVX(cmd)));
 
 	PL_rsfp = PerlProc_popen(SvPVX(cmd), "r");
@@ -2791,34 +2790,36 @@ sed %s -e \"/^[^#]/b\" \
     }
     else {
 	PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
-#if defined(HAS_FCNTL) && defined(F_SETFD)
-	if (PL_rsfp)
-	    fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);  /* ensure close-on-exec */
-#endif
+#       if defined(HAS_FCNTL) && defined(F_SETFD)
+	    if (PL_rsfp)
+                /* ensure close-on-exec */
+	        fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
+#       endif
     }
     if (!PL_rsfp) {
-#ifdef DOSUID
-#ifndef IAMSUID		/* in case script is not readable before setuid */
-	if (PL_euid &&
-	    PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
-	    PL_statbuf.st_mode & (S_ISUID|S_ISGID))
-	{
-	    /* try again */
-	    PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
-				     (int)PERL_REVISION, (int)PERL_VERSION,
-				     (int)PERL_SUBVERSION), PL_origargv);
-	    Perl_croak(aTHX_ "Can't do setuid\n");
-	}
-#endif
-#endif
-#ifdef IAMSUID
-	errno = EPERM;
-	Perl_croak(aTHX_ "Can't open perl script: %s\n",
-		   Strerror(errno));
-#else
-	Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
-		   CopFILE(PL_curcop), Strerror(errno));
-#endif
+#       ifdef DOSUID
+#       ifndef IAMSUID	/* in case script is not readable before setuid */
+	    if (PL_euid &&
+                PerlLIO_stat(CopFILE(PL_curcop),&PL_statbuf) >= 0 &&
+                PL_statbuf.st_mode & (S_ISUID|S_ISGID))
+            {
+                /* try again */
+                PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, 
+                                         BIN_EXP, (int)PERL_REVISION, 
+                                         (int)PERL_VERSION,
+                                         (int)PERL_SUBVERSION), PL_origargv);
+                Perl_croak(aTHX_ "Can't do setuid\n");
+            }
+#       endif
+#       endif
+#       ifdef IAMSUID
+            errno = EPERM;
+            Perl_croak(aTHX_ "Can't open perl script: %s\n",
+                       Strerror(errno));
+#       else
+            Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+                       CopFILE(PL_curcop), Strerror(errno));
+#       endif
     }
 }
 
@@ -3421,7 +3422,7 @@ Perl_init_argv_symbols(pTHX_ register int argc, register char **argv)
 
 #ifdef HAS_PROCSELFEXE
 /* This is a function so that we don't hold on to MAXPATHLEN
-   bytes of stack longer than necessary.
+   bytes of stack longer than necessary
  */
 STATIC void
 S_procself_val(pTHX_ SV *sv, char *arg0)
@@ -3437,45 +3438,12 @@ S_procself_val(pTHX_ SV *sv, char *arg0)
 }
 #endif /* HAS_PROCSELFEXE */
 
-#if defined(sun) && defined(__svr4__) /* solaris */
-#include <sys/auxv.h>
-STATIC void
-S_procselfauxv(pTHX_ SV *sv, char *arg0) {
-    auxv_t auxv;
-    int fh;
-    int n;
-
-    fh = open("/proc/self/auxv", O_RDONLY);
-    if (fh < 0) {
-        sv_setpv(sv, arg0);
-        return;
-    }
-
-    while (1) {
-        n = read(fh, &auxv, sizeof(auxv));
-        if (n != sizeof(auxv))
-            break;
-        if (auxv.a_type == AT_SUN_EXECNAME) {
-            close(fh);
-            sv_setpv(sv, auxv.a_un.a_ptr);
-	    return;
-        }
-    }
-    close(fh);
-    sv_setpv(sv, arg0);
-}
-#endif /* solaris */
-
 STATIC void
 S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register char **env)
 {
     char *s;
     SV *sv;
     GV* tmpgv;
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
-    char **dup_env_base = 0;
-    int dup_env_count = 0;
-#endif
 
     PL_toptarget = NEWSV(0,0);
     sv_upgrade(PL_toptarget, SVt_PVFM);
@@ -3502,15 +3470,11 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
 #ifdef HAS_PROCSELFEXE
 	S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]);
 #else
-#   ifdef OS2
+#ifdef OS2
 	sv_setpv(GvSV(tmpgv), os2_execname(aTHX));
-#   else
-#       if defined(sun) && defined(__svr4__) /* solaris */
-	S_procselfauxv(aTHX_ GvSV(tmpgv), PL_origargv[0]);
-#       else
-	sv_setpv(GvSV(tmpgv), PL_origargv[0]);
-#       endif
-#   endif
+#else
+	sv_setpv(GvSV(tmpgv),PL_origargv[0]);
+#endif
 #endif
     }
     if ((PL_envgv = gv_fetchpv("ENV",TRUE, SVt_PVHV))) {
@@ -3528,51 +3492,28 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register
 	    env = environ;
 	if (env != environ)
 	    environ[0] = Nullch;
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
-	{
-	    char **env_base;
-	    for (env_base = env; *env; env++)
-		dup_env_count++;
-	    if ((dup_env_base = (char **)
-		 safesysmalloc( sizeof(char *) * (dup_env_count+1) ))) {
-		char **dup_env;
-		for (env = env_base, dup_env = dup_env_base;
-		     *env;
-		     env++, dup_env++) {
-		    /* With environ one needs to use safesysmalloc(). */
-		    *dup_env = safesysmalloc(strlen(*env) + 1);
-		    (void)strcpy(*dup_env, *env);
-		}
-		*dup_env = Nullch;
-		env = dup_env_base;
-	    } /* else what? */
-	}
-#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
 	if (env)
 	  for (; *env; env++) {
 	    if (!(s = strchr(*env,'=')))
 		continue;
-	    *s++ = '\0';
 #if defined(MSDOS)
+	    *s = '\0';
 	    (void)strupr(*env);
+	    *s = '=';
 #endif
-	    sv = newSVpv(s--,0);
+	    sv = newSVpv(s+1, 0);
 	    (void)hv_store(hv, *env, s - *env, sv, 0);
-	    *s = '=';
+	    if (env != environ)
+	        mg_set(sv);
 	  }
-#ifdef NEED_ENVIRON_DUP_FOR_MODIFY
-	if (dup_env_base) {
-	    char **dup_env;
-	    for (dup_env = dup_env_base; *dup_env; dup_env++)
-		safesysfree(*dup_env);
-	    safesysfree(dup_env_base);
-	}
-#endif /* NEED_ENVIRON_DUP_FOR_MODIFY */
 #endif /* USE_ENVIRON_ARRAY */
     }
     TAINT_NOT;
-    if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV)))
+    if ((tmpgv = gv_fetchpv("$",TRUE, SVt_PV))) {
+        SvREADONLY_off(GvSV(tmpgv));
 	sv_setiv(GvSV(tmpgv), (IV)PerlProc_getpid());
+        SvREADONLY_on(GvSV(tmpgv));
+    }
 }
 
 STATIC void