X-Git-Url: https://perl5.git.perl.org/perl5.git/blobdiff_plain/2f9285f84584cb56950bf07de6ded6ebcdc3d302..6178c52a84a9039a61bf8320e1fa1e6c8f0e5ffc:/perl.c

diff --git a/perl.c b/perl.c
index d4abea8..508fb56 100644
--- a/perl.c
+++ b/perl.c
@@ -874,10 +874,6 @@ perl_destruct(pTHXx)
 	PL_parser->rsfp = NULL;
     }
 
-    /* Filters for program text */
-    SvREFCNT_dec(PL_rsfp_filters);
-    PL_rsfp_filters = NULL;
-
     if (PL_minus_F) {
 	Safefree(PL_splitstr);
 	PL_splitstr = NULL;
@@ -975,7 +971,6 @@ perl_destruct(pTHXx)
     PL_DBsingle = NULL;
     PL_DBtrace = NULL;
     PL_DBsignal = NULL;
-    PL_DBassertion = NULL;
     PL_DBcv = NULL;
     PL_dbargs = NULL;
     PL_debstash = NULL;
@@ -1668,6 +1663,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     bool minus_f = FALSE;
 #endif
     SV *linestr_sv = newSV_type(SVt_PVIV);
+    bool add_read_e_script = FALSE;
 
     SvGROW(linestr_sv, 80);
     sv_setpvn(linestr_sv,"",0);
@@ -1719,7 +1715,6 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	case 'W':
 	case 'X':
 	case 'w':
-	case 'A':
 	    if ((s = moreswitches(s)))
 		goto reswitch;
 	    break;
@@ -1751,7 +1746,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	    forbid_setid('e', -1);
 	    if (!PL_e_script) {
 		PL_e_script = newSVpvs("");
-		filter_add(read_e_script, NULL);
+		add_read_e_script = TRUE;
 	    }
 	    if (*++s)
 		sv_catpv(PL_e_script, s);
@@ -1792,6 +1787,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	    forbid_setid('P', -1);
 	    PL_preprocess = TRUE;
 	    s++;
+	    deprecate("-P");
 	    goto reswitch;
 	case 'S':
 	    forbid_setid('S', -1);
@@ -2261,15 +2257,17 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     }
 #endif
 
-    lex_start(linestr_sv, rsfp);
+    lex_start(linestr_sv, rsfp, TRUE);
     PL_subname = newSVpvs("main");
 
+    if (add_read_e_script)
+	filter_add(read_e_script, NULL);
+
     /* now parse the script */
 
     SETERRNO(0,SS_NORMAL);
-    PL_error_count = 0;
 #ifdef MACOS_TRADITIONAL
-    if (gMacPerl_SyntaxError = (yyparse() || PL_error_count)) {
+    if (gMacPerl_SyntaxError = (yyparse() || PL_parser->error_count)) {
 	if (PL_minus_c)
 	    Perl_croak(aTHX_ "%s had compilation errors.\n", MacPerl_MPWFileName(PL_origfilename));
 	else {
@@ -2278,7 +2276,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 	}
     }
 #else
-    if (yyparse() || PL_error_count) {
+    if (yyparse() || PL_parser->error_count) {
 	if (PL_minus_c)
 	    Perl_croak(aTHX_ "%s had compilation errors.\n", PL_origfilename);
 	else {
@@ -2909,7 +2907,6 @@ S_usage(pTHX_ const char *name)		/* XXX move this out into a module ? */
 
     static const char * const usage_msg[] = {
 "-0[octal]         specify record separator (\\0, if no argument)",
-"-A[mod][=pattern] activate all/given assertions",
 "-a                autosplit mode with -n or -p (splits $_ into @F)",
 "-C[number/list]   enables the listed Unicode features",
 "-c                check syntax only (runs BEGIN and CHECK blocks)",
@@ -3207,27 +3204,6 @@ Perl_moreswitches(pTHX_ char *s)
 	    }
 	}
 	return s;
-    case 'A':
-	forbid_setid('A', -1);
-	s++;
-	{
-	    char * const start = s;
-	    SV * const sv = newSVpvs("use assertions::activate");
-	    while(isALNUM(*s) || *s == ':') ++s;
-	    if (s != start) {
-		sv_catpvs(sv, "::");
-		sv_catpvn(sv, start, s-start);
-	    }
-	    if (*s == '=') {
-		Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
-		s+=strlen(s);
-	    }
-	    else if (*s != '\0') {
-		Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, (int)(s-start), start);
-	    }
-	    Perl_av_create_and_push(aTHX_ &PL_preambleav, sv);
-	    return s;
-	}
     case 'M':
 	forbid_setid('M', -1);	/* XXX ? */
 	/* FALL THROUGH */
@@ -3509,7 +3485,6 @@ S_init_interp(pTHX)
 #    define PERLVARIC(var,type,init)	PERL_GET_INTERP->var = init;
 #  endif
 #  include "intrpvar.h"
-#  include "thrdvar.h"
 #  undef PERLVAR
 #  undef PERLVARA
 #  undef PERLVARI
@@ -3520,7 +3495,6 @@ S_init_interp(pTHX)
 #  define PERLVARI(var,type,init)	PL_##var = init;
 #  define PERLVARIC(var,type,init)	PL_##var = init;
 #  include "intrpvar.h"
-#  include "thrdvar.h"
 #  undef PERLVAR
 #  undef PERLVARA
 #  undef PERLVARI
@@ -3736,7 +3710,47 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
 	*rsfpp = PerlIO_stdin();
     }
     else {
+#ifdef FAKE_BIT_BUCKET
+	/* This hack allows one not to have /dev/null (or BIT_BUCKET as it
+	 * is called) and still have the "-e" work.  (Believe it or not,
+	 * a /dev/null is required for the "-e" to work because source
+	 * filter magic is used to implement it. ) This is *not* a general
+	 * replacement for a /dev/null.  What we do here is create a temp
+	 * file (an empty file), open up that as the script, and then
+	 * immediately close and unlink it.  Close enough for jazz. */ 
+#define FAKE_BIT_BUCKET_PREFIX "/tmp/perlnull-"
+#define FAKE_BIT_BUCKET_SUFFIX "XXXXXXXX"
+#define FAKE_BIT_BUCKET_TEMPLATE FAKE_BIT_BUCKET_PREFIX FAKE_BIT_BUCKET_SUFFIX
+	char tmpname[sizeof(FAKE_BIT_BUCKET_TEMPLATE)] = {
+	    FAKE_BIT_BUCKET_TEMPLATE
+	};
+	const char * const err = "Failed to create a fake bit bucket";
+	if (strEQ(scriptname, BIT_BUCKET)) {
+#ifdef HAS_MKSTEMP /* Hopefully mkstemp() is safe here. */
+	    int tmpfd = mkstemp(tmpname);
+	    if (tmpfd > -1) {
+		scriptname = tmpname;
+		close(tmpfd);
+	    } else
+		Perl_croak(aTHX_ err);
+#else
+#  ifdef HAS_MKTEMP
+	    scriptname = mktemp(tmpname);
+	    if (!scriptname)
+		Perl_croak(aTHX_ err);
+#  endif
+#endif
+	}
+#endif
 	*rsfpp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
+#ifdef FAKE_BIT_BUCKET
+	if (memEQ(scriptname, FAKE_BIT_BUCKET_PREFIX,
+		  sizeof(FAKE_BIT_BUCKET_PREFIX) - 1)
+	    && strlen(scriptname) == sizeof(tmpname) - 1) {
+	    unlink(scriptname);
+	}
+	scriptname = BIT_BUCKET;
+#endif
 #       if defined(HAS_FCNTL) && defined(F_SETFD)
 	    if (*rsfpp)
                 /* ensure close-on-exec */
@@ -3935,7 +3949,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
 	const char *linestr;
 	const char *s_end;
 
-#ifdef IAMSUID
+#  ifdef IAMSUID
 	if (fdscript < 0 || suidscript != 1)
 	    Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n");	/* We already checked this */
 	/* PSz 11 Nov 03
@@ -3946,16 +3960,16 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
 	/* PSz 27 Feb 04
 	 * Do checks even for systems with no HAS_SETREUID.
 	 * We used to swap, then re-swap UIDs with
-#ifdef HAS_SETREUID
+#    ifdef HAS_SETREUID
 	    if (setreuid(PL_euid,PL_uid) < 0
 		|| PerlProc_getuid() != PL_euid || PerlProc_geteuid() != PL_uid)
 		Perl_croak(aTHX_ "Can't swap uid and euid");
-#endif
-#ifdef HAS_SETREUID
+#    endif
+#    ifdef HAS_SETREUID
 	    if (setreuid(PL_uid,PL_euid) < 0
 		|| PerlProc_getuid() != PL_uid || PerlProc_geteuid() != PL_euid)
 		Perl_croak(aTHX_ "Can't reswap uid and euid");
-#endif
+#    endif
 	 */
 
 	/* On this access check to make sure the directories are readable,
@@ -4016,12 +4030,12 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
 	 * operating systems do not have such mount options anyway...)
 	 * Seems safe enough to do as root.
 	 */
-#if !defined(NO_NOSUID_CHECK)
+#    if !defined(NO_NOSUID_CHECK)
 	if (fd_on_nosuid_fs(PerlIO_fileno(rsfp))) {
 	    Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
 	}
-#endif
-#endif /* IAMSUID */
+#    endif
+#  endif /* IAMSUID */
 
 	if (!S_ISREG(PL_statbuf.st_mode)) {
 	    Perl_croak(aTHX_ "Setuid script not plain file\n");
@@ -4085,14 +4099,14 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
 	      || ((s_end - s) == len+2 && isSPACE(s[len+1]))))
 	    Perl_croak(aTHX_ "Args must match #! line");
 
-#ifndef IAMSUID
+#  ifndef IAMSUID
 	if (fdscript < 0 &&
 	    PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
 	    PL_euid == PL_statbuf.st_uid)
 	    if (!PL_do_undump)
 		Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
 FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
-#endif /* IAMSUID */
+#  endif /* IAMSUID */
 
 	if (fdscript < 0 &&
 	    PL_euid) {	/* oops, we're not the setuid root perl */
@@ -4110,7 +4124,7 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
 	     * fdscript to avoid loops), and do the execs
 	     * even for root.
 	     */
-#ifndef IAMSUID
+#  ifndef IAMSUID
 	    int which;
 	    /* PSz 11 Nov 03
 	     * Pass fd script to suidperl.
@@ -4138,15 +4152,15 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
 	    }
 	    PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
 					  PerlIO_fileno(rsfp), PL_origargv[which]));
-#if defined(HAS_FCNTL) && defined(F_SETFD)
+#    if defined(HAS_FCNTL) && defined(F_SETFD)
 	    fcntl(PerlIO_fileno(rsfp),F_SETFD,0);	/* ensure no close-on-exec */
-#endif
+#    endif
 	    PERL_FPU_PRE_EXEC
 	    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_FPU_POST_EXEC
-#endif /* IAMSUID */
+#  endif /* IAMSUID */
 	    Perl_croak(aTHX_ "Can't do setuid (cannot exec sperl)\n");
 	}
 
@@ -4157,54 +4171,54 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
  * in the sense that we only want to set EGID; but are there any machines
  * with either of the latter, but not the former? Same with UID, later.
  */
-#ifdef HAS_SETEGID
+#  ifdef HAS_SETEGID
 	    (void)setegid(PL_statbuf.st_gid);
-#else
-#ifdef HAS_SETREGID
+#  else
+#    ifdef HAS_SETREGID
            (void)setregid((Gid_t)-1,PL_statbuf.st_gid);
-#else
-#ifdef HAS_SETRESGID
+#    else
+#      ifdef HAS_SETRESGID
            (void)setresgid((Gid_t)-1,PL_statbuf.st_gid,(Gid_t)-1);
-#else
+#      else
 	    PerlProc_setgid(PL_statbuf.st_gid);
-#endif
-#endif
-#endif
+#      endif
+#    endif
+#  endif
 	    if (PerlProc_getegid() != PL_statbuf.st_gid)
 		Perl_croak(aTHX_ "Can't do setegid!\n");
 	}
 	if (PL_statbuf.st_mode & S_ISUID) {
 	    if (PL_statbuf.st_uid != PL_euid)
-#ifdef HAS_SETEUID
+#  ifdef HAS_SETEUID
 		(void)seteuid(PL_statbuf.st_uid);	/* all that for this */
-#else
-#ifdef HAS_SETREUID
+#  else
+#    ifdef HAS_SETREUID
                 (void)setreuid((Uid_t)-1,PL_statbuf.st_uid);
-#else
-#ifdef HAS_SETRESUID
+#    else
+#      ifdef HAS_SETRESUID
                 (void)setresuid((Uid_t)-1,PL_statbuf.st_uid,(Uid_t)-1);
-#else
+#      else
 		PerlProc_setuid(PL_statbuf.st_uid);
-#endif
-#endif
-#endif
+#      endif
+#    endif
+#  endif
 	    if (PerlProc_geteuid() != PL_statbuf.st_uid)
 		Perl_croak(aTHX_ "Can't do seteuid!\n");
 	}
 	else if (PL_uid) {			/* oops, mustn't run as root */
-#ifdef HAS_SETEUID
+#  ifdef HAS_SETEUID
           (void)seteuid((Uid_t)PL_uid);
-#else
-#ifdef HAS_SETREUID
+#  else
+#    ifdef HAS_SETREUID
           (void)setreuid((Uid_t)-1,(Uid_t)PL_uid);
-#else
-#ifdef HAS_SETRESUID
+#    else
+#      ifdef HAS_SETRESUID
           (void)setresuid((Uid_t)-1,(Uid_t)PL_uid,(Uid_t)-1);
-#else
+#      else
           PerlProc_setuid((Uid_t)PL_uid);
-#endif
-#endif
-#endif
+#      endif
+#    endif
+#  endif
 	    if (PerlProc_geteuid() != PL_uid)
 		Perl_croak(aTHX_ "Can't do seteuid!\n");
 	}
@@ -4212,7 +4226,7 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
 	if (!cando(S_IXUSR,TRUE,&PL_statbuf))
 	    Perl_croak(aTHX_ "Effective UID cannot exec script\n");	/* they can't do this */
     }
-#ifdef IAMSUID
+#  ifdef IAMSUID
     else if (PL_preprocess)	/* PSz 13 Nov 03  Caught elsewhere, useless(?!) here */
 	Perl_croak(aTHX_ "-P not allowed for setuid/setgid script\n");
     else if (fdscript < 0 || suidscript != 1)
@@ -4268,21 +4282,23 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
 /*  }									*/
 /*  PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",	*/
 /*				  PerlIO_fileno(rsfp), PL_origargv[which]));	*/
-#if defined(HAS_FCNTL) && defined(F_SETFD)
+#  if defined(HAS_FCNTL) && defined(F_SETFD)
     fcntl(PerlIO_fileno(rsfp),F_SETFD,0);	/* ensure no close-on-exec */
-#endif
+#  endif
     PERL_FPU_PRE_EXEC
     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
 			     (int)PERL_REVISION, (int)PERL_VERSION,
 			     (int)PERL_SUBVERSION), PL_origargv);/* try again */
     PERL_FPU_POST_EXEC
     Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n");
-#endif /* IAMSUID */
+#  endif /* IAMSUID */
 #else /* !DOSUID */
     PERL_UNUSED_ARG(fdscript);
     PERL_UNUSED_ARG(suidscript);
     if (PL_euid != PL_uid || PL_egid != PL_gid) {	/* (suidperl doesn't exist, in fact) */
-#ifndef SETUID_SCRIPTS_ARE_SECURE_NOW
+#  ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
+    PERL_UNUSED_ARG(rsfp);
+#  else
 	PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf);	/* may be either wrapped or real suid */
 	if ((PL_euid != PL_uid && PL_euid == PL_statbuf.st_uid && PL_statbuf.st_mode & S_ISUID)
 	    ||
@@ -4291,7 +4307,7 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
 	    if (!PL_do_undump)
 		Perl_croak(aTHX_ "YOU HAVEN'T DISABLED SET-ID SCRIPTS IN THE KERNEL YET!\n\
 FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
-#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
+#  endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
 	/* not set-id, must be wrapped */
     }
 #endif /* DOSUID */
@@ -4503,8 +4519,6 @@ Perl_init_debugger(pTHX)
     sv_setiv(PL_DBtrace, 0);
     PL_DBsignal = GvSV((gv_fetchpvs("DB::signal", GV_ADDMULTI, SVt_PV)));
     sv_setiv(PL_DBsignal, 0);
-    PL_DBassertion = GvSV((gv_fetchpvs("DB::assertion", GV_ADDMULTI, SVt_PV)));
-    sv_setiv(PL_DBassertion, 0);
     PL_curstash = ostash;
 }