This is a live mirror of the Perl 5 development currently hosted at https://github.com/perl/perl5
move PL_rsfp into the PL_parser struct
authorDave Mitchell <davem@fdisolutions.com>
Fri, 11 May 2007 23:22:24 +0000 (23:22 +0000)
committerDave Mitchell <davem@fdisolutions.com>
Fri, 11 May 2007 23:22:24 +0000 (23:22 +0000)
and simplify its creation and destruction

p4raw-id: //depot/perl@31199

13 files changed:
embed.fnc
embed.h
embedvar.h
ext/Devel/PPPort/parts/inc/variables
intrpvar.h
op.c
parser.h
perl.c
perlapi.h
pp_ctl.c
proto.h
sv.c
toke.c

index fcb5b56..97e3422 100644 (file)
--- a/embed.fnc
+++ b/embed.fnc
@@ -403,7 +403,7 @@ p   |OP*    |jmaybe         |NN OP* arg
 pP     |I32    |keyword        |NN const char* d|I32 len|bool all_keywords
 Ap     |void   |leave_scope    |I32 base
 EXp    |void   |lex_end
-p      |void   |lex_start      |NULLOK SV* line
+p      |void   |lex_start      |NULLOK SV* line|NULLOK PerlIO *rsfp
 Ap     |void   |op_null        |NN OP* o
 EXp    |void   |op_clear       |NN OP* o
 Ap     |void   |op_refcnt_lock
@@ -1244,7 +1244,7 @@ s |void   |Slab_to_rw     |NN void *op
 #endif
 
 #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
-s      |void   |find_beginning |NN SV* linestr_sv
+s      |void   |find_beginning |NN SV* linestr_sv|NN PerlIO *rsfp
 s      |void   |forbid_setid   |const char flag|const int suidscript
 s      |void   |incpush        |NULLOK const char *dir|bool addsubdirs|bool addoldvers|bool usesep|bool canrelocate
 s      |void   |init_interp
@@ -1256,11 +1256,13 @@ s       |void   |init_predump_symbols
 rs     |void   |my_exit_jump
 s      |void   |nuke_stacks
 s      |int    |open_script    |NN const char *scriptname|bool dosearch \
-                               |NN SV *sv|NN int *suidscript
+                               |NN SV *sv|NN int *suidscript|NN PerlIO **rsfpp
 s      |void   |usage          |NN const char *name
 s      |void   |validate_suid  |NN const char *validarg \
                                |NN const char *scriptname|int fdscript \
-                               |int suidscript|NN SV* linestr_sv
+                               |int suidscript|NN SV* linestr_sv \
+                               |NN PerlIO *rsfp
+
 #  if defined(IAMSUID)
 s      |int    |fd_on_nosuid_fs|int fd
 #  endif
diff --git a/embed.h b/embed.h
index c076e84..1737ad3 100644 (file)
--- a/embed.h
+++ b/embed.h
 #define lex_end()              Perl_lex_end(aTHX)
 #endif
 #ifdef PERL_CORE
-#define lex_start(a)           Perl_lex_start(aTHX_ a)
+#define lex_start(a,b)         Perl_lex_start(aTHX_ a,b)
 #endif
 #define op_null(a)             Perl_op_null(aTHX_ a)
 #if defined(PERL_CORE) || defined(PERL_EXT)
 #endif
 #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
 #ifdef PERL_CORE
-#define find_beginning(a)      S_find_beginning(aTHX_ a)
+#define find_beginning(a,b)    S_find_beginning(aTHX_ a,b)
 #define forbid_setid(a,b)      S_forbid_setid(aTHX_ a,b)
 #define incpush(a,b,c,d,e)     S_incpush(aTHX_ a,b,c,d,e)
 #define init_interp()          S_init_interp(aTHX)
 #define init_predump_symbols() S_init_predump_symbols(aTHX)
 #define my_exit_jump()         S_my_exit_jump(aTHX)
 #define nuke_stacks()          S_nuke_stacks(aTHX)
-#define open_script(a,b,c,d)   S_open_script(aTHX_ a,b,c,d)
+#define open_script(a,b,c,d,e) S_open_script(aTHX_ a,b,c,d,e)
 #define usage(a)               S_usage(aTHX_ a)
-#define validate_suid(a,b,c,d,e)       S_validate_suid(aTHX_ a,b,c,d,e)
+#define validate_suid(a,b,c,d,e,f)     S_validate_suid(aTHX_ a,b,c,d,e,f)
 #endif
 #  if defined(IAMSUID)
 #ifdef PERL_CORE
index f5334b5..338db26 100644 (file)
 #define PL_rehash_seed         (vTHX->Irehash_seed)
 #define PL_rehash_seed_set     (vTHX->Irehash_seed_set)
 #define PL_replgv              (vTHX->Ireplgv)
-#define PL_rsfp                        (vTHX->Irsfp)
 #define PL_rsfp_filters                (vTHX->Irsfp_filters)
 #define PL_runops              (vTHX->Irunops)
 #define PL_runops_dbg          (vTHX->Irunops_dbg)
 #define PL_Irehash_seed                PL_rehash_seed
 #define PL_Irehash_seed_set    PL_rehash_seed_set
 #define PL_Ireplgv             PL_replgv
-#define PL_Irsfp               PL_rsfp
 #define PL_Irsfp_filters       PL_rsfp_filters
 #define PL_Irunops             PL_runops
 #define PL_Irunops_dbg         PL_runops_dbg
index 8901509..1011b1a 100644 (file)
@@ -97,6 +97,7 @@ __NEED_VAR__ U32 PL_signals = D_PPP_PERL_SIGNALS_INIT;
 #  define PL_PARSER_EXISTS
 #  define PL_expect   (PL_parser ? PL_parser->expect : 0)
 #  define PL_copline  (PL_parser ? PL_parser->copline : 0)
+#  define PL_rsfp     (PL_parser ? PL_parser->rsfp : 0)
 #endif
 
 =xsinit
@@ -227,7 +228,11 @@ other_variables()
                ppp_TESTVAR(PL_perl_destruct_level);
                ppp_TESTVAR(PL_perldb);
                ppp_TESTVAR(PL_rsfp_filters);
+#ifdef PL_PARSER_EXISTS
+               ppp_TESTVAR(PL_parser); /* just any var that isn't PL_expect */
+#else
                ppp_TESTVAR(PL_rsfp);
+#endif
                ppp_TESTVAR(PL_stack_base);
                ppp_TESTVAR(PL_stack_sp);
                ppp_TESTVAR(PL_statcache);
index e2c7b19..6f88ca7 100644 (file)
@@ -214,7 +214,6 @@ PERLVAR(Imodglobal, HV *)           /* per-interp module data */
 
 /* these used to be in global before 5.004_68 */
 PERLVARI(Iprofiledata, U32 *,  NULL)   /* table of ops, counts */
-PERLVARI(Irsfp,        PerlIO * VOL,   NULL)   /* current source file pointer */
 PERLVARI(Irsfp_filters,        AV *,   NULL)   /* keeps active source filters */
 
 PERLVAR(Icompiling,    COP)            /* compiling/done executing marker */
diff --git a/op.c b/op.c
index 40b415d..7015695 100644 (file)
--- a/op.c
+++ b/op.c
@@ -3866,7 +3866,7 @@ Perl_vload_module(pTHX_ U32 flags, SV *name, SV *ver, va_list *args)
 
     ENTER;
     SAVEVPTR(PL_curcop);
-    lex_start(NULL);
+    lex_start(NULL, NULL);
     utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
            veop, modname, imop);
     LEAVE;
index 1df14b4..082e493 100644 (file)
--- a/parser.h
+++ b/parser.h
@@ -70,6 +70,7 @@ typedef struct yy_parser {
     char       *last_uni;      /* position of last named-unary op */
     char       *last_lop;      /* position of last list operator */
     U8         lex_state;      /* next token is determined */
+    PerlIO     *rsfp;          /* current source file pointer */
 
 #ifdef PERL_MAD
     SV         *endwhite;
diff --git a/perl.c b/perl.c
index da52f85..d4abea8 100644 (file)
--- a/perl.c
+++ b/perl.c
@@ -868,9 +868,10 @@ perl_destruct(pTHXx)
 
     /* loosen bonds of global variables */
 
-    if(PL_rsfp) {
-       (void)PerlIO_close(PL_rsfp);
-       PL_rsfp = NULL;
+    /* XXX can PL_parser still be non-null here? */
+    if(PL_parser && PL_parser->rsfp) {
+       (void)PerlIO_close(PL_parser->rsfp);
+       PL_parser->rsfp = NULL;
     }
 
     /* Filters for program text */
@@ -1654,7 +1655,7 @@ STATIC void *
 S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
 {
     dVAR;
-    PerlIO *tmpfp;
+    PerlIO *rsfp;
     int argc = PL_origargc;
     char **argv = PL_origargv;
     const char *scriptname = NULL;
@@ -2112,9 +2113,10 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     {
        int suidscript;
        const int fdscript
-           = open_script(scriptname, dosearch, sv, &suidscript);
+           = open_script(scriptname, dosearch, sv, &suidscript, &rsfp);
 
-       validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv);
+       validate_suid(validarg, scriptname, fdscript, suidscript,
+               linestr_sv, rsfp);
 
 #ifndef PERL_MICRO
 #  if defined(SIGCHLD) || defined(SIGCLD)
@@ -2144,7 +2146,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
            forbid_setid('x', suidscript);
            /* Hence you can't get here if suidscript >= 0  */
 
-           find_beginning(linestr_sv);
+           find_beginning(linestr_sv, rsfp);
            if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
                Perl_croak(aTHX_ "Can't chdir to %s",cddir);
        }
@@ -2259,10 +2261,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
     }
 #endif
 
-    tmpfp = PL_rsfp;
-    PL_rsfp = NULL;
-    lex_start(linestr_sv);
-    PL_rsfp = tmpfp;
+    lex_start(linestr_sv, rsfp);
     PL_subname = newSVpvs("main");
 
     /* now parse the script */
@@ -3584,7 +3583,7 @@ S_init_main_stash(pTHX)
 
 STATIC int
 S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
-             int *suidscript)
+             int *suidscript, PerlIO **rsfpp)
 {
 #ifndef IAMSUID
     const char *quote;
@@ -3642,11 +3641,11 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
     if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
        scriptname = (char *)"";
     if (fdscript >= 0) {
-       PL_rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
+       *rsfpp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
 #       if defined(HAS_FCNTL) && defined(F_SETFD)
-           if (PL_rsfp)
+           if (*rsfpp)
                 /* ensure close-on-exec */
-               fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
+               fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
 #       endif
     }
 #ifdef IAMSUID
@@ -3728,24 +3727,24 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
                               "PL_preprocess: cmd=\"%s\"\n",
                               SvPVX_const(cmd)));
 
-       PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
+       *rsfpp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
        SvREFCNT_dec(cmd);
        SvREFCNT_dec(cpp);
     }
     else if (!*scriptname) {
        forbid_setid(0, *suidscript);
-       PL_rsfp = PerlIO_stdin();
+       *rsfpp = PerlIO_stdin();
     }
     else {
-       PL_rsfp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
+       *rsfpp = PerlIO_open(scriptname,PERL_SCRIPT_MODE);
 #       if defined(HAS_FCNTL) && defined(F_SETFD)
-           if (PL_rsfp)
+           if (*rsfpp)
                 /* ensure close-on-exec */
-               fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,1);
+               fcntl(PerlIO_fileno(*rsfpp),F_SETFD,1);
 #       endif
     }
 #endif /* IAMSUID */
-    if (!PL_rsfp) {
+    if (!*rsfpp) {
        /* PSz 16 Sep 03  Keep neat error message */
        if (PL_e_script)
            Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
@@ -3892,7 +3891,7 @@ S_fd_on_nosuid_fs(pTHX_ int fd)
 
 STATIC void
 S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
-               int fdscript, int suidscript, SV *linestr_sv)
+               int fdscript, int suidscript, SV *linestr_sv, PerlIO *rsfp)
 {
     dVAR;
 #ifdef IAMSUID
@@ -3929,7 +3928,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
 #ifdef DOSUID
     const char *s, *s2;
 
-    if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
+    if (PerlLIO_fstat(PerlIO_fileno(rsfp),&PL_statbuf) < 0)    /* normal stat is insecure */
        Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
     if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
        I32 len;
@@ -4018,7 +4017,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
         * Seems safe enough to do as root.
         */
 #if !defined(NO_NOSUID_CHECK)
-       if (fd_on_nosuid_fs(PerlIO_fileno(PL_rsfp))) {
+       if (fd_on_nosuid_fs(PerlIO_fileno(rsfp))) {
            Perl_croak(aTHX_ "Setuid script on nosuid or noexec filesystem\n");
        }
 #endif
@@ -4032,7 +4031,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
        PL_doswitches = FALSE;          /* -s is insecure in suid */
        /* PSz 13 Nov 03  But -s was caught elsewhere ... so unsetting it here is useless(?!) */
        CopLINE_inc(PL_curcop);
-       if (sv_gets(linestr_sv, PL_rsfp, 0) == NULL)
+       if (sv_gets(linestr_sv, rsfp, 0) == NULL)
            Perl_croak(aTHX_ "No #! line");
        linestr = SvPV_nolen_const(linestr_sv);
        /* required even on Sys V */
@@ -4120,8 +4119,8 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
             * in fact will use that to distinguish this from "normal"
             * usage, see comments above.
             */
-           PerlIO_rewind(PL_rsfp);
-           PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
+           PerlIO_rewind(rsfp);
+           PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
            /* PSz 27 Feb 04  Sanity checks on scriptname */
            if ((!scriptname) || (!*scriptname) ) {
                Perl_croak(aTHX_ "No setuid script name\n");
@@ -4138,9 +4137,9 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
                Perl_croak(aTHX_ "Can't change argv to have fd script\n");
            }
            PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",
-                                         PerlIO_fileno(PL_rsfp), PL_origargv[which]));
+                                         PerlIO_fileno(rsfp), PL_origargv[which]));
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-           fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);    /* ensure no close-on-exec */
+           fcntl(PerlIO_fileno(rsfp),F_SETFD,0);       /* ensure no close-on-exec */
 #endif
            PERL_FPU_PRE_EXEC
            PerlProc_execv(Perl_form(aTHX_ "%s/sperl"PERL_FS_VER_FMT, BIN_EXP,
@@ -4257,8 +4256,8 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
      * #endif
      * into the perly bits.
      */
-    PerlIO_rewind(PL_rsfp);
-    PerlLIO_lseek(PerlIO_fileno(PL_rsfp),(Off_t)0,0);  /* just in case rewind didn't */
+    PerlIO_rewind(rsfp);
+    PerlLIO_lseek(PerlIO_fileno(rsfp),(Off_t)0,0);  /* just in case rewind didn't */
     /* PSz 11 Nov 03
      * Keep original arguments: suidperl already has fd script.
      */
@@ -4268,9 +4267,9 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
 /*     Perl_croak(aTHX_ "Permission denied\n");                        */
 /*  }                                                                  */
 /*  PL_origargv[which] = savepv(Perl_form(aTHX_ "/dev/fd/%d/%s",       */
-/*                               PerlIO_fileno(PL_rsfp), PL_origargv[which])); */
+/*                               PerlIO_fileno(rsfp), PL_origargv[which]));    */
 #if defined(HAS_FCNTL) && defined(F_SETFD)
-    fcntl(PerlIO_fileno(PL_rsfp),F_SETFD,0);   /* ensure no close-on-exec */
+    fcntl(PerlIO_fileno(rsfp),F_SETFD,0);      /* ensure no close-on-exec */
 #endif
     PERL_FPU_PRE_EXEC
     PerlProc_execv(Perl_form(aTHX_ "%s/perl"PERL_FS_VER_FMT, BIN_EXP,
@@ -4284,7 +4283,7 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
     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
-       PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf);      /* may be either wrapped or real suid */
+       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)
            ||
            (PL_egid != PL_gid && PL_egid == PL_statbuf.st_gid && PL_statbuf.st_mode & S_ISGID)
@@ -4302,7 +4301,7 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n");
 }
 
 STATIC void
-S_find_beginning(pTHX_ SV* linestr_sv)
+S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
 {
     dVAR;
     register char *s;
@@ -4317,7 +4316,7 @@ S_find_beginning(pTHX_ SV* linestr_sv)
     /* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
 
     while (PL_doextract || gMacPerl_AlwaysExtract) {
-       if ((s = sv_gets(linestr_sv, PL_rsfp, 0)) == NULL) {
+       if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL) {
            if (!gMacPerl_AlwaysExtract)
                Perl_croak(aTHX_ "No Perl script found in input\n");
 
@@ -4328,18 +4327,18 @@ S_find_beginning(pTHX_ SV* linestr_sv)
                    PL_doextract = FALSE;
 
            /* Pater peccavi, file does not have #! */
-           PerlIO_rewind(PL_rsfp);
+           PerlIO_rewind(rsfp);
 
            break;
        }
 #else
     while (PL_doextract) {
-       if ((s = sv_gets(linestr_sv, PL_rsfp, 0)) == NULL)
+       if ((s = sv_gets(linestr_sv, rsfp, 0)) == NULL)
            Perl_croak(aTHX_ "No Perl script found in input\n");
 #endif
        s2 = s;
        if (*s == '#' && s[1] == '!' && ((s = instr(s,"perl")) || (s = instr(s2,"PERL")))) {
-           PerlIO_ungetc(PL_rsfp, '\n');               /* to keep line count right */
+           PerlIO_ungetc(rsfp, '\n');          /* to keep line count right */
            PL_doextract = FALSE;
            while (*s && !(isSPACE (*s) || *s == '#')) s++;
            s2 = s;
@@ -4357,7 +4356,7 @@ S_find_beginning(pTHX_ SV* linestr_sv)
             * by counting lines we already skipped over
             */
            for (; maclines > 0 ; maclines--)
-               PerlIO_ungetc(PL_rsfp, '\n');
+               PerlIO_ungetc(rsfp, '\n');
 
            break;
 
index 98dd3aa..a3e3721 100644 (file)
--- a/perlapi.h
+++ b/perlapi.h
@@ -472,8 +472,6 @@ END_EXTERN_C
 #define PL_rehash_seed_set     (*Perl_Irehash_seed_set_ptr(aTHX))
 #undef  PL_replgv
 #define PL_replgv              (*Perl_Ireplgv_ptr(aTHX))
-#undef  PL_rsfp
-#define PL_rsfp                        (*Perl_Irsfp_ptr(aTHX))
 #undef  PL_rsfp_filters
 #define PL_rsfp_filters                (*Perl_Irsfp_filters_ptr(aTHX))
 #undef  PL_runops
index 26e1cb8..60b6b0a 100644 (file)
--- a/pp_ctl.c
+++ b/pp_ctl.c
@@ -2745,7 +2745,7 @@ Perl_sv_compile_2op(pTHX_ SV *sv, OP** startop, const char *code, PAD** padp)
     STRLEN len;
 
     ENTER;
-    lex_start(sv);
+    lex_start(sv, NULL);
     SAVETMPS;
     /* switch to eval mode */
 
@@ -3377,11 +3377,10 @@ PP(pp_require)
 
     ENTER;
     SAVETMPS;
-    lex_start(NULL);
+    lex_start(NULL, tryrsfp);
     SAVEGENERICSV(PL_rsfp_filters);
     PL_rsfp_filters = NULL;
 
-    PL_rsfp = tryrsfp;
     SAVEHINTS();
     PL_hints = 0;
     SAVECOMPILEWARNINGS();
@@ -3449,7 +3448,7 @@ PP(pp_entereval)
     TAINT_PROPER("eval");
 
     ENTER;
-    lex_start(sv);
+    lex_start(sv, NULL);
     SAVETMPS;
 
     /* switch to eval mode */
diff --git a/proto.h b/proto.h
index a27ad79..cbd261c 100644 (file)
--- a/proto.h
+++ b/proto.h
@@ -1025,7 +1025,7 @@ PERL_CALLCONV I32 Perl_keyword(pTHX_ const char* d, I32 len, bool all_keywords)
 
 PERL_CALLCONV void     Perl_leave_scope(pTHX_ I32 base);
 PERL_CALLCONV void     Perl_lex_end(pTHX);
-PERL_CALLCONV void     Perl_lex_start(pTHX_ SV* line);
+PERL_CALLCONV void     Perl_lex_start(pTHX_ SV* line, PerlIO *rsfp);
 PERL_CALLCONV void     Perl_op_null(pTHX_ OP* o)
                        __attribute__nonnull__(pTHX_1);
 
@@ -3357,8 +3357,9 @@ STATIC void       S_Slab_to_rw(pTHX_ void *op)
 #endif
 
 #if defined(PERL_IN_PERL_C) || defined(PERL_DECL_PROT)
-STATIC void    S_find_beginning(pTHX_ SV* linestr_sv)
-                       __attribute__nonnull__(pTHX_1);
+STATIC void    S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
+                       __attribute__nonnull__(pTHX_1)
+                       __attribute__nonnull__(pTHX_2);
 
 STATIC void    S_forbid_setid(pTHX_ const char flag, const int suidscript);
 STATIC void    S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, bool canrelocate);
@@ -3374,18 +3375,21 @@ STATIC void     S_my_exit_jump(pTHX)
                        __attribute__noreturn__;
 
 STATIC void    S_nuke_stacks(pTHX);
-STATIC int     S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv, int *suidscript)
+STATIC int     S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv, int *suidscript, PerlIO **rsfpp)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_3)
-                       __attribute__nonnull__(pTHX_4);
+                       __attribute__nonnull__(pTHX_4)
+                       __attribute__nonnull__(pTHX_5);
 
 STATIC void    S_usage(pTHX_ const char *name)
                        __attribute__nonnull__(pTHX_1);
 
-STATIC void    S_validate_suid(pTHX_ const char *validarg, const char *scriptname, int fdscript, int suidscript, SV* linestr_sv)
+STATIC void    S_validate_suid(pTHX_ const char *validarg, const char *scriptname, int fdscript, int suidscript, SV* linestr_sv, PerlIO *rsfp)
                        __attribute__nonnull__(pTHX_1)
                        __attribute__nonnull__(pTHX_2)
-                       __attribute__nonnull__(pTHX_5);
+                       __attribute__nonnull__(pTHX_5)
+                       __attribute__nonnull__(pTHX_6);
+
 
 #  if defined(IAMSUID)
 STATIC int     S_fd_on_nosuid_fs(pTHX_ int fd);
diff --git a/sv.c b/sv.c
index 4b27b29..71fdd43 100644 (file)
--- a/sv.c
+++ b/sv.c
@@ -9576,6 +9576,7 @@ Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param)
     parser->copline    = proto->copline;
     parser->last_lop_op        = proto->last_lop_op;
     parser->lex_state  = proto->lex_state;
+    parser->rsfp       = fp_dup(proto->rsfp, '<', param);
 
 
     parser->linestr    = sv_dup_inc(proto->linestr, param);
@@ -9600,6 +9601,7 @@ Perl_parser_dup(pTHX_ const yy_parser *proto, CLONE_PARAMS* param)
        parser->bufend      = ls + SvCUR(parser->linestr);
     }
 
+
 #ifdef PERL_MAD
     parser->endwhite   = proto->endwhite;
     parser->faketokens = proto->faketokens;
@@ -11214,7 +11216,6 @@ perl_clone_using(PerlInterpreter *proto_perl, UV flags,
     PL_custom_op_descs  = hv_dup_inc(proto_perl->Icustom_op_descs,param);
 
     PL_profiledata     = NULL;
-    PL_rsfp            = fp_dup(proto_perl->Irsfp, '<', param);
     /* PL_rsfp_filters entries have fake IoDIRP() */
     PL_rsfp_filters    = av_dup_inc(proto_perl->Irsfp_filters, param);
 
diff --git a/toke.c b/toke.c
index 9726a31..40eeb2a 100644 (file)
--- a/toke.c
+++ b/toke.c
@@ -61,6 +61,7 @@
 #define PL_last_lop            (PL_parser->last_lop)
 #define PL_last_lop_op         (PL_parser->last_lop_op)
 #define PL_lex_state           (PL_parser->lex_state)
+#define PL_rsfp                        (PL_parser->rsfp)
 
 #ifdef PERL_MAD
 #  define PL_endwhite          (PL_parser->endwhite)
@@ -638,7 +639,7 @@ S_cr_textfilter(pTHX_ int idx, SV *sv, int maxlen)
  */
 
 void
-Perl_lex_start(pTHX_ SV *line)
+Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp)
 {
     dVAR;
     const char *s = NULL;
@@ -665,7 +666,6 @@ Perl_lex_start(pTHX_ SV *line)
     /* initialise lexer state */
 
     SAVECOPLINE(PL_curcop);
-    SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
 
 #ifdef PERL_MAD
     parser->curforce = -1;
@@ -675,6 +675,8 @@ Perl_lex_start(pTHX_ SV *line)
     parser->copline = NOLINE;
     PL_lex_state = LEX_NORMAL;
     parser->expect = XSTATE;
+    parser->rsfp = rsfp;
+
     Newx(parser->lex_brackstack, 120, char);
     Newx(parser->lex_casestack, 12, char);
     *parser->lex_casestack = '\0';
@@ -702,7 +704,6 @@ Perl_lex_start(pTHX_ SV *line)
        parser->linestart = SvPVX(parser->linestr);
     parser->bufend = parser->bufptr + SvCUR(parser->linestr);
     parser->last_lop = parser->last_uni = NULL;
-    PL_rsfp = 0;
 }
 
 
@@ -713,6 +714,12 @@ Perl_parser_free(pTHX_  const yy_parser *parser)
 {
     SvREFCNT_dec(parser->linestr);
 
+    if (parser->rsfp == PerlIO_stdin())
+       PerlIO_clearerr(parser->rsfp);
+    else if (parser->rsfp && parser->old_parser
+                         && parser->rsfp != parser->old_parser->rsfp)
+       PerlIO_close(parser->rsfp);
+
     Safefree(parser->stack);
     Safefree(parser->lex_brackstack);
     Safefree(parser->lex_casestack);
@@ -12659,23 +12666,6 @@ S_swallow_bom(pTHX_ U8 *s)
     return (char*)s;
 }
 
-/*
- * restore_rsfp
- * Restore a source filter.
- */
-
-static void
-restore_rsfp(pTHX_ void *f)
-{
-    dVAR;
-    PerlIO * const fp = (PerlIO*)f;
-
-    if (PL_rsfp == PerlIO_stdin())
-       PerlIO_clearerr(PL_rsfp);
-    else if (PL_rsfp && (PL_rsfp != fp))
-       PerlIO_close(PL_rsfp);
-    PL_rsfp = fp;
-}
 
 #ifndef PERL_NO_UTF16_FILTER
 static I32