if (PL_perl_destruct_level > 0)
init_interp();
#endif
- /* Init the real globals (and main thread)? */
- if (!PL_linestr) {
- PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
-
- PL_linestr = newSV_type(SVt_PVIV);
- SvGROW(PL_linestr, 80);
-
- if (!SvREADONLY(&PL_sv_undef)) {
- /* set read-only and try to insure than we wont see REFCNT==0
- very often */
-
- SvREADONLY_on(&PL_sv_undef);
- SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
-
- sv_setpv(&PL_sv_no,PL_No);
- /* value lookup in void context - happens to have the side effect
- of caching the numeric forms. */
- SvIV(&PL_sv_no);
- SvNV(&PL_sv_no);
- SvREADONLY_on(&PL_sv_no);
- SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
-
- sv_setpv(&PL_sv_yes,PL_Yes);
- SvIV(&PL_sv_yes);
- SvNV(&PL_sv_yes);
- SvREADONLY_on(&PL_sv_yes);
- SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
-
- SvREADONLY_on(&PL_sv_placeholder);
- SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
- }
+ PL_curcop = &PL_compiling; /* needed by ckWARN, right away */
+
+ /* set read-only and try to insure than we wont see REFCNT==0
+ very often */
+
+ SvREADONLY_on(&PL_sv_undef);
+ SvREFCNT(&PL_sv_undef) = (~(U32)0)/2;
+
+ sv_setpv(&PL_sv_no,PL_No);
+ /* value lookup in void context - happens to have the side effect
+ of caching the numeric forms. */
+ SvIV(&PL_sv_no);
+ SvNV(&PL_sv_no);
+ SvREADONLY_on(&PL_sv_no);
+ SvREFCNT(&PL_sv_no) = (~(U32)0)/2;
+
+ sv_setpv(&PL_sv_yes,PL_Yes);
+ SvIV(&PL_sv_yes);
+ SvNV(&PL_sv_yes);
+ SvREADONLY_on(&PL_sv_yes);
+ SvREFCNT(&PL_sv_yes) = (~(U32)0)/2;
- PL_sighandlerp = (Sighandler_t) Perl_sighandler;
+ SvREADONLY_on(&PL_sv_placeholder);
+ SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
+
+ PL_sighandlerp = (Sighandler_t) Perl_sighandler;
#ifdef PERL_USES_PL_PIDSTATUS
- PL_pidstatus = newHV();
+ PL_pidstatus = newHV();
#endif
- }
PL_rs = newSVpvs("\n");
init_stacks();
init_ids();
- PL_lex_state = LEX_NOTPARSING;
JMPENV_BOOTSTRAP;
STATUS_ALL_SUCCESS;
PL_stashcache = newHV();
- PL_patchlevel = Perl_newSVpvf(aTHX_ "%d.%d.%d", (int)PERL_REVISION,
+ PL_patchlevel = Perl_newSVpvf(aTHX_ "v%d.%d.%d", (int)PERL_REVISION,
(int)PERL_VERSION, (int)PERL_SUBVERSION);
#ifdef HAS_MMAP
/* 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 */
- SvREFCNT_dec(PL_rsfp_filters);
- PL_rsfp_filters = NULL;
-
if (PL_minus_F) {
Safefree(PL_splitstr);
PL_splitstr = NULL;
PL_DBsingle = NULL;
PL_DBtrace = NULL;
PL_DBsignal = NULL;
- PL_DBassertion = NULL;
PL_DBcv = NULL;
PL_dbargs = NULL;
PL_debstash = NULL;
PL_preambleav = NULL;
SvREFCNT_dec(PL_subname);
PL_subname = NULL;
- SvREFCNT_dec(PL_linestr);
- PL_linestr = NULL;
#ifdef PERL_USES_PL_PIDSTATUS
SvREFCNT_dec(PL_pidstatus);
PL_pidstatus = NULL;
SvREFCNT_dec(PL_errors);
PL_errors = NULL;
+ SvREFCNT_dec(PL_isarev);
+
FREETMPS;
if (destruct_level >= 2 && ckWARN_d(WARN_INTERNAL)) {
if (PL_scopestack_ix != 0)
S_parse_body(pTHX_ char **env, XSINIT_t xsinit)
{
dVAR;
+ PerlIO *rsfp;
int argc = PL_origargc;
char **argv = PL_origargv;
const char *scriptname = NULL;
#ifdef USE_SITECUSTOMIZE
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);
- sv_setpvn(PL_linestr,"",0);
sv = newSVpvs(""); /* first used for -I flags */
SAVEFREESV(sv);
init_main_stash();
case 'W':
case 'X':
case 'w':
- case 'A':
if ((s = moreswitches(s)))
goto reswitch;
break;
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);
{
int suidscript;
const int fdscript
- = open_script(scriptname, dosearch, sv, &suidscript);
+ = open_script(scriptname, dosearch, sv, &suidscript, &rsfp);
- validate_suid(validarg, scriptname, fdscript, suidscript);
+ 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();
+ find_beginning(linestr_sv, rsfp);
if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
Perl_croak(aTHX_ "Can't chdir to %s",cddir);
}
CvPADLIST(PL_compcv) = pad_new(0);
+ PL_isarev = newHV();
+
boot_core_PerlIO();
boot_core_UNIVERSAL();
boot_core_xsutils();
+ boot_core_mro();
if (xsinit)
(*xsinit)(aTHX); /* in case linked C routines want magical variables */
}
#endif
- init_lexer();
+ 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 {
}
}
#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 {
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)",
}
}
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 */
# define PERLVARIC(var,type,init) PERL_GET_INTERP->var = init;
# endif
# include "intrpvar.h"
-# include "thrdvar.h"
# undef PERLVAR
# undef PERLVARA
# undef PERLVARI
# 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
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);
+#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 (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)
+ 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(PL_linestr, PL_rsfp, 0) == NULL)
+ if (sv_gets(linestr_sv, rsfp, 0) == NULL)
Perl_croak(aTHX_ "No #! line");
- linestr = SvPV_nolen_const(PL_linestr);
+ linestr = SvPV_nolen_const(linestr_sv);
/* required even on Sys V */
if (!*linestr || !linestr[1] || strnNE(linestr,"#!",2))
Perl_croak(aTHX_ "No #! line");
* 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)
#endif /* DOSUID */
PERL_UNUSED_ARG(validarg);
PERL_UNUSED_ARG(scriptname);
+ PERL_UNUSED_ARG(linestr_sv);
}
STATIC void
-S_find_beginning(pTHX)
+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(PL_linestr, 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(PL_linestr, 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;
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;
}
Safefree(PL_savestack);
}
-STATIC void
-S_init_lexer(pTHX)
-{
- dVAR;
- PerlIO *tmpfp;
- tmpfp = PL_rsfp;
- PL_rsfp = NULL;
- lex_start(PL_linestr);
- PL_rsfp = tmpfp;
- PL_subname = newSVpvs("main");
-}
STATIC void
S_init_predump_symbols(pTHX)
https://perl5.git.perl.org / perl5.git / blobdiff