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;
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);
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);
forbid_setid('P', -1);
PL_preprocess = TRUE;
s++;
+ deprecate("-P");
goto reswitch;
case 'S':
forbid_setid('S', -1);
}
#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 {
}
}
#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
*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 */
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
/* 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,
* 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");
|| ((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 */
* 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.
}
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");
}
* 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");
}
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)
/* } */
/* 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)
||
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 */
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;
}
https://perl5.git.perl.org / perl5.git / blobdiff