PL_Dir = ipD;
PL_Sock = ipS;
PL_Proc = ipP;
+ INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
return my_perl;
}
my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter));
S_init_tls_and_interp(my_perl);
+#ifndef PERL_TRACK_MEMPOOL
return (PerlInterpreter *) ZeroD(my_perl, 1, PerlInterpreter);
+#else
+ Zero(my_perl, 1, PerlInterpreter);
+ INIT_TRACK_MEMPOOL(PL_memory_debug_header, my_perl);
+ return my_perl;
+#endif
}
#endif /* PERL_IMPLICIT_SYS */
void
perl_free(pTHXx)
{
+#ifdef PERL_TRACK_MEMPOOL
+ /* Emulate the PerlHost behaviour of free()ing all memory allocated in this
+ thread at thread exit. */
+ while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header))
+ safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next));
+#endif
+
#if defined(WIN32) || defined(NETWARE)
# if defined(PERL_IMPLICIT_SYS)
+ {
# ifdef NETWARE
- void *host = nw_internal_host;
+ void *host = nw_internal_host;
# else
- void *host = w32_internal_host;
+ void *host = w32_internal_host;
# endif
- PerlMem_free(aTHXx);
+ PerlMem_free(aTHXx);
# ifdef NETWARE
- nw_delete_internal_host(host);
+ nw_delete_internal_host(host);
# else
- win32_delete_internal_host(host);
+ win32_delete_internal_host(host);
# endif
+ }
# else
PerlMem_free(aTHXx);
# endif
bool minus_f = FALSE;
#endif
- PL_fdscript = -1;
- PL_suidscript = -1;
sv_setpvn(PL_linestr,"",0);
sv = newSVpvs(""); /* first used for -I flags */
SAVEFREESV(sv);
if (argv[1] && !strcmp(argv[1], "Dev:Pseudo"))
break;
#endif
- forbid_setid("-e");
+ forbid_setid('e', -1);
if (!PL_e_script) {
PL_e_script = newSVpvs("");
filter_add(read_e_script, NULL);
goto reswitch;
case 'I': /* -I handled both here and in moreswitches() */
- forbid_setid("-I");
+ forbid_setid('I', -1);
if (!*++s && (s=argv[1]) != NULL) {
argc--,argv++;
}
Perl_croak(aTHX_ "No directory specified for -I");
break;
case 'P':
- forbid_setid("-P");
+ forbid_setid('P', -1);
PL_preprocess = TRUE;
s++;
goto reswitch;
case 'S':
- forbid_setid("-S");
+ forbid_setid('S', -1);
dosearch = TRUE;
s++;
goto reswitch;
TAINT_NOT;
init_perllib();
- open_script(scriptname,dosearch,sv);
+ {
+ int suidscript;
+ const int fdscript
+ = open_script(scriptname, dosearch, sv, &suidscript);
- validate_suid(validarg, scriptname);
+ validate_suid(validarg, scriptname, fdscript, suidscript);
#ifndef PERL_MICRO
-#if defined(SIGCHLD) || defined(SIGCLD)
- {
-#ifndef SIGCHLD
-# define SIGCHLD SIGCLD
-#endif
- Sighandler_t sigstate = rsignal_state(SIGCHLD);
- if (sigstate == (Sighandler_t) SIG_IGN) {
- if (ckWARN(WARN_SIGNAL))
- Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
- "Can't ignore signal CHLD, forcing to default");
- (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
+# if defined(SIGCHLD) || defined(SIGCLD)
+ {
+# ifndef SIGCHLD
+# define SIGCHLD SIGCLD
+# endif
+ Sighandler_t sigstate = rsignal_state(SIGCHLD);
+ if (sigstate == (Sighandler_t) SIG_IGN) {
+ if (ckWARN(WARN_SIGNAL))
+ Perl_warner(aTHX_ packWARN(WARN_SIGNAL),
+ "Can't ignore signal CHLD, forcing to default");
+ (void)rsignal(SIGCHLD, (Sighandler_t)SIG_DFL);
+ }
}
- }
-#endif
+# endif
#endif
+ if (PL_doextract
#ifdef MACOS_TRADITIONAL
- if (PL_doextract || gMacPerl_AlwaysExtract) {
-#else
- if (PL_doextract) {
+ || gMacPerl_AlwaysExtract
#endif
- find_beginning();
- if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
- Perl_croak(aTHX_ "Can't chdir to %s",cddir);
+ ) {
+
+ /* This will croak if suidscript is >= 0, as -x cannot be used with
+ setuid scripts. */
+ forbid_setid('x', suidscript);
+ /* Hence you can't get here if suidscript >= 0 */
+ find_beginning();
+ if (cddir && PerlDir_chdir( (char *)cddir ) < 0)
+ Perl_croak(aTHX_ "Can't chdir to %s",cddir);
+ }
}
PL_main_cv = PL_compcv = (CV*)newSV(0);
s++;
return s;
case 'd':
- forbid_setid("-d");
+ forbid_setid('d', -1);
s++;
/* -dt indicates to the debugger that threads will be used */
case 'D':
{
#ifdef DEBUGGING
- forbid_setid("-D");
+ forbid_setid('D', -1);
s++;
PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG;
#else /* !DEBUGGING */
}
return s;
case 'I': /* -I handled both here and in parse_body() */
- forbid_setid("-I");
+ forbid_setid('I', -1);
++s;
while (*s && isSPACE(*s))
++s;
}
return s;
case 'A':
- forbid_setid("-A");
+ forbid_setid('A', -1);
if (!PL_preambleav)
PL_preambleav = newAV();
s++;
return s;
}
case 'M':
- forbid_setid("-M"); /* XXX ? */
+ forbid_setid('M', -1); /* XXX ? */
/* FALL THROUGH */
case 'm':
- forbid_setid("-m"); /* XXX ? */
+ forbid_setid('m', -1); /* XXX ? */
if (*++s) {
char *start;
SV *sv;
s++;
return s;
case 's':
- forbid_setid("-s");
+ forbid_setid('s', -1);
PL_doswitches = TRUE;
s++;
return s;
sv_setpvn(get_sv("/", TRUE), "\n", 1);
}
-/* PSz 18 Nov 03 fdscript now global but do not change prototype */
-STATIC void
-S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv)
+STATIC int
+S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv,
+ int *suidscript)
{
#ifndef IAMSUID
const char *quote;
const char *cpp_discard_flag;
const char *perl;
#endif
+ int fdscript = -1;
dVAR;
- PL_fdscript = -1;
- PL_suidscript = -1;
+ *suidscript = -1;
if (PL_e_script) {
PL_origfilename = savepvs("-e");
if (strnEQ(scriptname, "/dev/fd/", 8) && isDIGIT(scriptname[8]) ) {
const char *s = scriptname + 8;
- PL_fdscript = atoi(s);
+ fdscript = atoi(s);
while (isDIGIT(*s))
s++;
if (*s) {
* Is it a mistake to use a similar /dev/fd/ construct for
* suidperl?
*/
- PL_suidscript = 1;
+ *suidscript = 1;
/* PSz 20 Feb 04
* Be supersafe and do some sanity-checks.
* Still, can we be sure we got the right thing?
CopFILE_set(PL_curcop, PL_origfilename);
if (*PL_origfilename == '-' && PL_origfilename[1] == '\0')
scriptname = (char *)"";
- if (PL_fdscript >= 0) {
- PL_rsfp = PerlIO_fdopen(PL_fdscript,PERL_SCRIPT_MODE);
+ if (fdscript >= 0) {
+ PL_rsfp = PerlIO_fdopen(fdscript,PERL_SCRIPT_MODE);
# if defined(HAS_FCNTL) && defined(F_SETFD)
if (PL_rsfp)
/* ensure close-on-exec */
* perl with that fd as it has always done.
*/
}
- if (PL_suidscript != 1) {
+ if (*suidscript != 1) {
Perl_croak(aTHX_ "suidperl needs (suid) fd script\n");
}
#else /* IAMSUID */
SvREFCNT_dec(cpp);
}
else if (!*scriptname) {
- forbid_setid("program input from stdin");
+ forbid_setid(0, *suidscript);
PL_rsfp = PerlIO_stdin();
}
else {
Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
CopFILE(PL_curcop), Strerror(errno));
}
+ return fdscript;
}
/* Mention
#endif /* IAMSUID */
STATIC void
-S_validate_suid(pTHX_ const char *validarg, const char *scriptname)
+S_validate_suid(pTHX_ const char *validarg, const char *scriptname,
+ int fdscript, int suidscript)
{
dVAR;
#ifdef IAMSUID
const char *s_end;
#ifdef IAMSUID
- if (PL_fdscript < 0 || PL_suidscript != 1)
+ if (fdscript < 0 || suidscript != 1)
Perl_croak(aTHX_ "Need (suid) fdscript in suidperl\n"); /* We already checked this */
/* PSz 11 Nov 03
* Since the script is opened by perl, not suidperl, some of these
Perl_croak(aTHX_ "Args must match #! line");
#ifndef IAMSUID
- if (PL_fdscript < 0 &&
+ if (fdscript < 0 &&
PL_euid != PL_uid && (PL_statbuf.st_mode & S_ISUID) &&
PL_euid == PL_statbuf.st_uid)
if (!PL_do_undump)
FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n");
#endif /* IAMSUID */
- if (PL_fdscript < 0 &&
+ if (fdscript < 0 &&
PL_euid) { /* oops, we're not the setuid root perl */
/* PSz 18 Feb 04
* When root runs a setuid script, we do not go through the same
* might run also non-setuid ones, and deserves what he gets.
*
* Or, we might drop the PL_euid check above (and rely just on
- * PL_fdscript to avoid loops), and do the execs
+ * fdscript to avoid loops), and do the execs
* even for root.
*/
#ifndef 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 (PL_fdscript < 0 || PL_suidscript != 1)
+ else if (fdscript < 0 || suidscript != 1)
/* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */
Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n");
else {
/* skip forward in input to the real script? */
- forbid_setid("-x");
#ifdef MACOS_TRADITIONAL
/* Since the Mac OS does not honor #! arguments for us, we do it ourselves */
return 0;
}
+/* Passing the flag as a single char rather than a string is a slight space
+ optimisation. The only message that isn't /^-.$/ is
+ "program input from stdin", which is substituted in place of '\0', which
+ could never be a command line flag. */
STATIC void
-S_forbid_setid(pTHX_ const char *s)
+S_forbid_setid(pTHX_ const char flag, const int suidscript)
{
dVAR;
+ char string[3] = "-x";
+ const char *message = "program input from stdin";
+
+ if (flag) {
+ string[1] = flag;
+ message = string;
+ }
+
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
if (PL_euid != PL_uid)
- Perl_croak(aTHX_ "No %s allowed while running setuid", s);
+ Perl_croak(aTHX_ "No %s allowed while running setuid", message);
if (PL_egid != PL_gid)
- Perl_croak(aTHX_ "No %s allowed while running setgid", s);
+ Perl_croak(aTHX_ "No %s allowed while running setgid", message);
#endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */
/* PSz 29 Feb 04
* Checks for UID/GID above "wrong": why disallow
*
* Also see comments about root running a setuid script, elsewhere.
*/
- if (PL_suidscript >= 0)
- Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", s);
+ if (suidscript >= 0)
+ Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message);
#ifdef IAMSUID
/* PSz 11 Nov 03 Catch it in suidperl, always! */
- Perl_croak(aTHX_ "No %s allowed in suidperl", s);
+ Perl_croak(aTHX_ "No %s allowed in suidperl", message);
#endif /* IAMSUID */
}
projects / p5sagit/p5-mst-13.2.git / blobdiff