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
#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
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
#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
#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
# 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
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);
/* 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 */
ENTER;
SAVEVPTR(PL_curcop);
- lex_start(NULL);
+ lex_start(NULL, NULL);
utilize(!(flags & PERL_LOADMOD_DENY), start_subparse(FALSE, 0),
veop, modname, imop);
LEAVE;
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;
/* 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 */
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;
{
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)
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);
}
}
#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 */
STATIC int
S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
- int *suidscript)
+ int *suidscript, PerlIO **rsfpp)
{
#ifndef IAMSUID
const char *quote;
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
"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));
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
#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;
* 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
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 */
* 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");
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,
* #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.
*/
/* 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,
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)
}
STATIC void
-S_find_beginning(pTHX_ SV* linestr_sv)
+S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp)
{
dVAR;
register char *s;
/* 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");
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;
* by counting lines we already skipped over
*/
for (; maclines > 0 ; maclines--)
- PerlIO_ungetc(PL_rsfp, '\n');
+ PerlIO_ungetc(rsfp, '\n');
break;
#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
STRLEN len;
ENTER;
- lex_start(sv);
+ lex_start(sv, NULL);
SAVETMPS;
/* switch to eval mode */
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();
TAINT_PROPER("eval");
ENTER;
- lex_start(sv);
+ lex_start(sv, NULL);
SAVETMPS;
/* switch to eval mode */
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);
#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);
__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);
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);
parser->bufend = ls + SvCUR(parser->linestr);
}
+
#ifdef PERL_MAD
parser->endwhite = proto->endwhite;
parser->faketokens = proto->faketokens;
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);
#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)
*/
void
-Perl_lex_start(pTHX_ SV *line)
+Perl_lex_start(pTHX_ SV *line, PerlIO *rsfp)
{
dVAR;
const char *s = NULL;
/* initialise lexer state */
SAVECOPLINE(PL_curcop);
- SAVEDESTRUCTOR_X(restore_rsfp, PL_rsfp);
#ifdef PERL_MAD
parser->curforce = -1;
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';
parser->linestart = SvPVX(parser->linestr);
parser->bufend = parser->bufptr + SvCUR(parser->linestr);
parser->last_lop = parser->last_uni = NULL;
- PL_rsfp = 0;
}
{
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);
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
projects / p5sagit/p5-mst-13.2.git / commitdiff