Add test preambles

[perl5.git] / perl.c

diff --git a/perl.c b/perl.c
index d4abea8..3542162 100644 (file)
--- 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);
@@ -2261,15 +2256,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 +2275,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 +2906,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 +3203,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 +3484,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 +3494,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 +3709,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 */
@@ -4503,8 +4516,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;
 }