X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=1abb48dbcfc70e181e471825ea6f45426102a929;hb=3f6d40bd7fe955329c1f574485922604c74d8097;hp=89dc73a7835a0c6f607fdce5eec1e4a5e790f6b0;hpb=7191f387c0fa6065ef0d358ee594d31676dff988;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 89dc73a..1abb48d 100644 --- a/perl.c +++ b/perl.c @@ -125,16 +125,22 @@ char *getenv (char *); /* Usually in */ static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen); -#ifdef IAMSUID -#ifndef DOSUID -#define DOSUID -#endif -#endif /* IAMSUID */ - -#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef DOSUID -#undef DOSUID -#endif +# ifdef IAMSUID +/* Drop scriptname */ +# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ validarg, fdscript, suidscript, linestr_sv, rsfp) +# else +/* Drop suidscript */ +# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ validarg, scriptname, fdscript, linestr_sv, rsfp) +# endif +#else +# ifdef SETUID_SCRIPTS_ARE_SECURE_NOW +/* Drop everything. Heck, don't even try to call it */ +# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) NOOP +# else +/* Drop almost everything */ +# define validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp) S_validate_suid(aTHX_ rsfp) +# endif #endif #define CALL_BODY_EVAL(myop) \ @@ -188,6 +194,9 @@ void Perl_sys_init(int* argc, char*** argv) { dVAR; + + PERL_ARGS_ASSERT_SYS_INIT; + PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */ PERL_UNUSED_ARG(argv); PERL_SYS_INIT_BODY(argc, argv); @@ -197,6 +206,9 @@ void Perl_sys_init3(int* argc, char*** argv, char*** env) { dVAR; + + PERL_ARGS_ASSERT_SYS_INIT3; + PERL_UNUSED_ARG(argc); /* may not be used depending on _BODY macro */ PERL_UNUSED_ARG(argv); PERL_UNUSED_ARG(env); @@ -222,6 +234,9 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, struct IPerlProc* ipP) { PerlInterpreter *my_perl; + + PERL_ARGS_ASSERT_PERL_ALLOC_USING; + /* Newx() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); S_init_tls_and_interp(my_perl); @@ -282,11 +297,14 @@ void perl_construct(pTHXx) { dVAR; - PERL_UNUSED_ARG(my_perl); + + PERL_ARGS_ASSERT_PERL_CONSTRUCT; + #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; #else + PERL_UNUSED_ARG(my_perl); if (PL_perl_destruct_level > 0) init_interp(); #endif @@ -472,6 +490,8 @@ Perl_dump_sv_child(pTHX_ SV *sv) int returned_errno; unsigned char buffer[256]; + PERL_ARGS_ASSERT_DUMP_SV_CHILD; + if(sock == -1 || debug_fd == -1) return; @@ -574,7 +594,10 @@ perl_destruct(pTHXx) pid_t child; #endif + PERL_ARGS_ASSERT_PERL_DESTRUCT; +#ifndef MULTIPLICITY PERL_UNUSED_ARG(my_perl); +#endif /* wait for all pseudo-forked children to finish */ PERL_WAIT_FOR_CHILDREN; @@ -1340,6 +1363,8 @@ perl_free(pTHXx) { dVAR; + PERL_ARGS_ASSERT_PERL_FREE; + if (PL_veto_cleanup) return; @@ -1351,10 +1376,17 @@ perl_free(pTHXx) */ const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); if (!s || atoi(s) == 0) { + const U32 old_debug = PL_debug; /* Emulate the PerlHost behaviour of free()ing all memory allocated in this thread at thread exit. */ + if (DEBUG_m_TEST) { + PerlIO_puts(Perl_debug_log, "Disabling memory debugging as we " + "free this thread's memory\n"); + PL_debug &= ~ DEBUG_m_FLAG; + } while(aTHXx->Imemory_debug_header.next != &(aTHXx->Imemory_debug_header)) safesysfree(sTHX + (char *)(aTHXx->Imemory_debug_header.next)); + PL_debug = old_debug; } } #endif @@ -1484,14 +1516,14 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) int ret; dJMPENV; + PERL_ARGS_ASSERT_PERL_PARSE; +#ifndef MULTIPLICITY PERL_UNUSED_ARG(my_perl); +#endif -#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW -#ifdef IAMSUID -#undef IAMSUID - Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now execute\n\ -setuid perl scripts securely.\n"); -#endif /* IAMSUID */ +#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW_AND_IAMSUID + Perl_croak(aTHX_ "suidperl is no longer needed since the kernel can now " + "execute\nsetuid perl scripts securely.\n"); #endif #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) @@ -1674,7 +1706,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) char **argv = PL_origargv; const char *scriptname = NULL; VOL bool dosearch = FALSE; +#ifdef DOSUID const char *validarg = ""; +#endif register SV *sv; register char c; const char *cddir = NULL; @@ -1764,7 +1798,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) if (argv[1] && !strcmp(argv[1], "Dev:Pseudo")) break; #endif - forbid_setid('e', -1); + forbid_setid('e', FALSE); if (!PL_e_script) { PL_e_script = newSVpvs(""); add_read_e_script = TRUE; @@ -1788,7 +1822,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) goto reswitch; case 'I': /* -I handled both here and in moreswitches() */ - forbid_setid('I', -1); + forbid_setid('I', FALSE); if (!*++s && (s=argv[1]) != NULL) { argc--,argv++; } @@ -1805,7 +1839,7 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) Perl_croak(aTHX_ "No directory specified for -I"); break; case 'S': - forbid_setid('S', -1); + forbid_setid('S', FALSE); dosearch = TRUE; s++; goto reswitch; @@ -2027,9 +2061,12 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) init_perllib(); { - int suidscript; - const int fdscript - = open_script(scriptname, dosearch, &suidscript, &rsfp); + bool suidscript = FALSE; + +#ifdef DOSUID + const int fdscript = +#endif + open_script(scriptname, dosearch, &suidscript, &rsfp); validate_suid(validarg, scriptname, fdscript, suidscript, linestr_sv, rsfp); @@ -2057,10 +2094,10 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) #endif ) { - /* This will croak if suidscript is >= 0, as -x cannot be used with + /* This will croak if suidscript is true, as -x cannot be used with setuid scripts. */ forbid_setid('x', suidscript); - /* Hence you can't get here if suidscript >= 0 */ + /* Hence you can't get here if suidscript is true */ find_beginning(linestr_sv, rsfp); if (cddir && PerlDir_chdir( (char *)cddir ) < 0) @@ -2263,7 +2300,10 @@ perl_run(pTHXx) int ret = 0; dJMPENV; + PERL_ARGS_ASSERT_PERL_RUN; +#ifndef MULTIPLICITY PERL_UNUSED_ARG(my_perl); +#endif oldscope = PL_scopestack_ix; #ifdef VMS @@ -2327,8 +2367,6 @@ S_run_body(pTHX_ I32 oldscope) if (!DEBUG_q_TEST) PERL_DEBUG(PerlIO_printf(Perl_debug_log, "\nEXECUTING...\n\n")); #endif - DEBUG_S(PerlIO_printf(Perl_debug_log, "main thread is 0x%"UVxf"\n", - PTR2UV(thr))); if (PL_minus_c) { #ifdef MACOS_TRADITIONAL @@ -2381,6 +2419,9 @@ SV* Perl_get_sv(pTHX_ const char *name, I32 create) { GV *gv; + + PERL_ARGS_ASSERT_GET_SV; + gv = gv_fetchpv(name, create, SVt_PV); if (gv) return GvSV(gv); @@ -2403,6 +2444,9 @@ AV* Perl_get_av(pTHX_ const char *name, I32 create) { GV* const gv = gv_fetchpv(name, create, SVt_PVAV); + + PERL_ARGS_ASSERT_GET_AV; + if (create) return GvAVn(gv); if (gv) @@ -2426,6 +2470,9 @@ HV* Perl_get_hv(pTHX_ const char *name, I32 create) { GV* const gv = gv_fetchpv(name, create, SVt_PVHV); + + PERL_ARGS_ASSERT_GET_HV; + if (create) return GvHVn(gv); if (gv) @@ -2458,6 +2505,9 @@ Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags) /* XXX this is probably not what they think they're getting. * It has the same effect as "sub name;", i.e. just a forward * declaration! */ + + PERL_ARGS_ASSERT_GET_CVN_FLAGS; + if ((flags & ~GV_NOADD_MASK) && !GvCVu(gv)) { SV *const sv = newSVpvn_flags(name, len, flags & SVf_UTF8); return newSUB(start_subparse(FALSE, 0), @@ -2472,6 +2522,8 @@ Perl_get_cvn_flags(pTHX_ const char *name, STRLEN len, I32 flags) CV* Perl_get_cv(pTHX_ const char *name, I32 flags) { + PERL_ARGS_ASSERT_GET_CV; + return get_cvn_flags(name, strlen(name), flags); } @@ -2497,6 +2549,8 @@ Perl_call_argv(pTHX_ const char *sub_name, I32 flags, register char **argv) dVAR; dSP; + PERL_ARGS_ASSERT_CALL_ARGV; + PUSHMARK(SP); if (argv) { while (*argv) { @@ -2521,6 +2575,8 @@ Perl_call_pv(pTHX_ const char *sub_name, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { + PERL_ARGS_ASSERT_CALL_PV; + return call_sv((SV*)get_cv(sub_name, TRUE), flags); } @@ -2538,6 +2594,8 @@ Perl_call_method(pTHX_ const char *methname, I32 flags) /* name of the subroutine */ /* See G_* flags in cop.h */ { + PERL_ARGS_ASSERT_CALL_METHOD; + return call_sv(sv_2mortal(newSVpv(methname,0)), flags | G_METHOD); } @@ -2552,7 +2610,7 @@ L. */ I32 -Perl_call_sv(pTHX_ SV *sv, I32 flags) +Perl_call_sv(pTHX_ SV *sv, VOL I32 flags) /* See G_* flags in cop.h */ { dVAR; dSP; @@ -2566,18 +2624,23 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) OP* const oldop = PL_op; dJMPENV; + PERL_ARGS_ASSERT_CALL_SV; + if (flags & G_DISCARD) { ENTER; SAVETMPS; } + if (!(flags & G_WANT)) { + /* Backwards compatibility - as G_SCALAR was 0, it could be omitted. + */ + flags |= G_SCALAR; + } Zero(&myop, 1, LOGOP); myop.op_next = NULL; if (!(flags & G_NOARGS)) myop.op_flags |= OPf_STACKED; - myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : - (flags & G_ARRAY) ? OPf_WANT_LIST : - OPf_WANT_SCALAR); + myop.op_flags |= OP_GIMME_REVERSE(flags); SAVEOP(); PL_op = (OP*)&myop; @@ -2599,7 +2662,9 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) Zero(&method_op, 1, UNOP); method_op.op_next = PL_op; method_op.op_ppaddr = PL_ppaddr[OP_METHOD]; + method_op.op_type = OP_METHOD; myop.op_ppaddr = PL_ppaddr[OP_ENTERSUB]; + myop.op_type = OP_ENTERSUB; PL_op = (OP*)&method_op; } @@ -2644,7 +2709,7 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) goto redo_body; } PL_stack_sp = PL_stack_base + oldmark; - if (flags & G_ARRAY) + if ((flags & G_WANT) == G_ARRAY) retval = 0; else { retval = 1; @@ -2692,6 +2757,8 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) OP* const oldop = PL_op; dJMPENV; + PERL_ARGS_ASSERT_EVAL_SV; + if (flags & G_DISCARD) { ENTER; SAVETMPS; @@ -2707,9 +2774,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) myop.op_flags = OPf_STACKED; myop.op_next = NULL; myop.op_type = OP_ENTEREVAL; - myop.op_flags |= ((flags & G_VOID) ? OPf_WANT_VOID : - (flags & G_ARRAY) ? OPf_WANT_LIST : - OPf_WANT_SCALAR); + myop.op_flags |= OP_GIMME_REVERSE(flags); if (flags & G_KEEPERR) myop.op_flags |= OPf_SPECIAL; @@ -2745,7 +2810,7 @@ Perl_eval_sv(pTHX_ SV *sv, I32 flags) goto redo_body; } PL_stack_sp = PL_stack_base + oldmark; - if (flags & G_ARRAY) + if ((flags & G_WANT) == G_ARRAY) retval = 0; else { retval = 1; @@ -2780,6 +2845,8 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) dSP; SV* sv = newSVpv(p, 0); + PERL_ARGS_ASSERT_EVAL_PV; + eval_sv(sv, G_SCALAR); SvREFCNT_dec(sv); @@ -2813,6 +2880,9 @@ Perl_require_pv(pTHX_ const char *pv) dVAR; dSP; SV* sv; + + PERL_ARGS_ASSERT_REQUIRE_PV; + PUSHSTACKi(PERLSI_REQUIRE); PUTBACK; sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0); @@ -2826,6 +2896,8 @@ Perl_magicname(pTHX_ const char *sym, const char *name, I32 namlen) { register GV * const gv = gv_fetchpv(sym, GV_ADD, SVt_PV); + PERL_ARGS_ASSERT_MAGICNAME; + if (gv) sv_magic(GvSV(gv), (SV*)gv, PERL_MAGIC_sv, name, namlen); } @@ -2870,6 +2942,8 @@ NULL }; const char * const *p = usage_msg; + PERL_ARGS_ASSERT_USAGE; + PerlIO_printf(PerlIO_stdout(), "\nUsage: %s [switches] [--] [programfile] [arguments]", name); @@ -2901,7 +2975,6 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) " H Hash dump -- usurps values()", " X Scratchpad allocation", " D Cleaning up", - " S Thread synchronization", " T Tokenising", " R Include reference counts of dumped variables (eg when using -Ds)", " J Do not s,t,P-debug (Jump over) opcodes within package DB", @@ -2912,6 +2985,9 @@ Perl_get_debug_opts(pTHX_ const char **s, bool givehelp) NULL }; int i = 0; + + PERL_ARGS_ASSERT_GET_DEBUG_OPTS; + if (isALPHA(**s)) { /* if adding extra options, remember to update DEBUG_MASK */ static const char debopts[] = "psltocPmfrxuUHXDSTRJvCAq"; @@ -2949,6 +3025,9 @@ Perl_moreswitches(pTHX_ const char *s) { dVAR; UV rschar; + const char option = *s; /* used to remember option in -m/-M code */ + + PERL_ARGS_ASSERT_MORESWITCHES; switch (*s) { case '0': @@ -3014,7 +3093,7 @@ Perl_moreswitches(pTHX_ const char *s) s++; return s; case 'd': - forbid_setid('d', -1); + forbid_setid('d', FALSE); s++; /* -dt indicates to the debugger that threads will be used */ @@ -3052,7 +3131,7 @@ Perl_moreswitches(pTHX_ const char *s) case 'D': { #ifdef DEBUGGING - forbid_setid('D', -1); + forbid_setid('D', FALSE); s++; PL_debug = get_debug_opts( (const char **)&s, 1) | DEBUG_TOP_FLAG; #else /* !DEBUGGING */ @@ -3088,7 +3167,7 @@ Perl_moreswitches(pTHX_ const char *s) } return s; case 'I': /* -I handled both here and in parse_body() */ - forbid_setid('I', -1); + forbid_setid('I', FALSE); ++s; while (*s && isSPACE(*s)) ++s; @@ -3137,15 +3216,16 @@ Perl_moreswitches(pTHX_ const char *s) } return s; case 'M': - forbid_setid('M', -1); /* XXX ? */ + forbid_setid('M', FALSE); /* XXX ? */ /* FALL THROUGH */ case 'm': - forbid_setid('m', -1); /* XXX ? */ + forbid_setid('m', FALSE); /* XXX ? */ if (*++s) { const char *start; const char *end; SV *sv; const char *use = "use "; + bool colon = FALSE; /* -M-foo == 'no foo' */ /* Leading space on " no " is deliberate, to make both possibilities the same length. */ @@ -3153,19 +3233,30 @@ Perl_moreswitches(pTHX_ const char *s) sv = newSVpvn(use,4); start = s; /* We allow -M'Module qw(Foo Bar)' */ - while(isALNUM(*s) || *s==':') ++s; + while(isALNUM(*s) || *s==':') { + if( *s++ == ':' ) { + if( *s == ':' ) + s++; + else + colon = TRUE; + } + } + if (s == start) + Perl_croak(aTHX_ "Module name required with -%c option", + option); + if (colon) + Perl_croak(aTHX_ "Invalid module name %.*s with -%c option: " + "contains single ':'", + s - start, start, option); end = s + strlen(s); if (*s != '=') { sv_catpvn(sv, start, end - start); - if (*(start-1) == 'm') { + if (option == 'm') { if (*s != '\0') Perl_croak(aTHX_ "Can't use '%c' after -mname", *s); sv_catpvs( sv, " ()"); } } else { - if (s == start) - Perl_croak(aTHX_ "Module name required with -%c option", - s[-1]); sv_catpvn(sv, start, s-start); /* Use NUL as q''-delimiter. */ sv_catpvs(sv, " split(/,/,q\0"); @@ -3177,7 +3268,7 @@ Perl_moreswitches(pTHX_ const char *s) Perl_av_create_and_push(aTHX_ &PL_preambleav, sv); } else - Perl_croak(aTHX_ "Missing argument to -%c", *(s-1)); + Perl_croak(aTHX_ "Missing argument to -%c", option); return s; case 'n': PL_minus_n = TRUE; @@ -3188,7 +3279,7 @@ Perl_moreswitches(pTHX_ const char *s) s++; return s; case 's': - forbid_setid('s', -1); + forbid_setid('s', FALSE); PL_doswitches = TRUE; s++; return s; @@ -3488,12 +3579,12 @@ S_init_main_stash(pTHX) STATIC int S_open_script(pTHX_ const char *scriptname, bool dosearch, - int *suidscript, PerlIO **rsfpp) + bool *suidscript, PerlIO **rsfpp) { int fdscript = -1; dVAR; - *suidscript = -1; + PERL_ARGS_ASSERT_OPEN_SCRIPT; if (PL_e_script) { PL_origfilename = savepvs("-e"); @@ -3517,7 +3608,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, * Is it a mistake to use a similar /dev/fd/ construct for * suidperl? */ - *suidscript = 1; + *suidscript = TRUE; /* PSz 20 Feb 04 * Be supersafe and do some sanity-checks. * Still, can we be sure we got the right thing? @@ -3560,7 +3651,7 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, * perl with that fd as it has always done. */ } - if (*suidscript != 1) { + if (*suidscript) { Perl_croak(aTHX_ "suidperl needs (suid) fd script\n"); } #else /* IAMSUID */ @@ -3762,29 +3853,22 @@ S_fd_on_nosuid_fs(pTHX_ int fd) } #endif /* IAMSUID */ +#ifdef DOSUID STATIC void -S_validate_suid(pTHX_ const char *validarg, const char *scriptname, - int fdscript, int suidscript, SV *linestr_sv, PerlIO *rsfp) +S_validate_suid(pTHX_ const char *validarg, +# ifndef IAMSUID + const char *scriptname, +# endif + int fdscript, +# ifdef IAMSUID + bool suidscript, +# endif + SV *linestr_sv, PerlIO *rsfp) { dVAR; -#ifdef DOSUID const char *s, *s2; -#endif -#ifdef DOSUID -# ifdef IAMSUID - PERL_UNUSED_ARG(scriptname); -# endif -#else - PERL_UNUSED_ARG(validarg); - PERL_UNUSED_ARG(scriptname); - PERL_UNUSED_ARG(linestr_sv); - PERL_UNUSED_ARG(fdscript); - PERL_UNUSED_ARG(suidscript); -# ifdef SETUID_SCRIPTS_ARE_SECURE_NOW - PERL_UNUSED_ARG(rsfp); -# endif -#endif + PERL_ARGS_ASSERT_VALIDATE_SUID; /* do we need to emulate setuid on scripts? */ @@ -3813,8 +3897,6 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname, * Configure script will set this up for you if you want it. */ -#ifdef DOSUID - 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)) { @@ -3823,7 +3905,7 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname, const char *s_end; # ifdef IAMSUID - if (fdscript < 0 || suidscript != 1) + if (fdscript < 0 || !suidscript) 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 @@ -4100,7 +4182,7 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); Perl_croak(aTHX_ "Effective UID cannot exec script\n"); /* they can't do this */ } # ifdef IAMSUID - else if (fdscript < 0 || suidscript != 1) + else if (fdscript < 0 || !suidscript) /* PSz 13 Nov 03 Caught elsewhere, useless(?!) here */ Perl_croak(aTHX_ "(suid) fdscript needed in suidperl\n"); else { @@ -4156,7 +4238,18 @@ FIX YOUR KERNEL, OR PUT A C WRAPPER AROUND THIS SCRIPT!\n"); PERL_FPU_POST_EXEC Perl_croak(aTHX_ "Can't do setuid (suidperl cannot exec perl)\n"); # endif /* IAMSUID */ +} + #else /* !DOSUID */ + +# ifdef SETUID_SCRIPTS_ARE_SECURE_NOW +/* Don't even need this function. */ +# else +STATIC void +S_validate_suid(pTHX_ PerlIO *rsfp) +{ + PERL_ARGS_ASSERT_VALIDATE_SUID; + 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(rsfp),&PL_statbuf); /* may be either wrapped or real suid */ @@ -4170,8 +4263,9 @@ FIX YOUR KERNEL, PUT A C WRAPPER AROUND THIS SCRIPT, OR USE -u AND UNDUMP!\n"); # endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ /* not set-id, must be wrapped */ } -#endif /* DOSUID */ } +# endif /* SETUID_SCRIPTS_ARE_SECURE_NOW */ +#endif /* DOSUID */ STATIC void S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) @@ -4183,6 +4277,8 @@ S_find_beginning(pTHX_ SV* linestr_sv, PerlIO *rsfp) int maclines = 0; #endif + PERL_ARGS_ASSERT_FIND_BEGINNING; + /* skip forward in input to the real script? */ #ifdef MACOS_TRADITIONAL @@ -4310,7 +4406,7 @@ Perl_doing_taint(int argc, char *argv[], char *envp[]) "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 flag, const int suidscript) +S_forbid_setid(pTHX_ const char flag, const bool suidscript) /* g */ { dVAR; char string[3] = "-x"; @@ -4349,7 +4445,7 @@ S_forbid_setid(pTHX_ const char flag, const int suidscript) * * Also see comments about root running a setuid script, elsewhere. */ - if (suidscript >= 0) + if (suidscript) Perl_croak(aTHX_ "No %s allowed with (suid) fdscript", message); #ifdef IAMSUID /* PSz 11 Nov 03 Catch it in suidperl, always! */ @@ -4488,6 +4584,9 @@ void Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) { dVAR; + + PERL_ARGS_ASSERT_INIT_ARGV_SYMBOLS; + argc--,argv++; /* skip name of script */ if (PL_doswitches) { for (; argc > 0 && **argv == '-'; argc--,argv++) { @@ -4530,6 +4629,8 @@ S_init_postdump_symbols(pTHX_ register int argc, register char **argv, register dVAR; GV* tmpgv; + PERL_ARGS_ASSERT_INIT_POSTDUMP_SYMBOLS; + PL_toptarget = newSV_type(SVt_PVFM); sv_setpvn(PL_toptarget, "", 0); PL_bodytarget = newSV_type(SVt_PVFM); @@ -4760,6 +4861,9 @@ S_incpush_if_exists(pTHX_ SV *dir) { dVAR; Stat_t tmpstatbuf; + + PERL_ARGS_ASSERT_INCPUSH_IF_EXISTS; + if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) { av_push(GvAVn(PL_incgv), dir); @@ -5003,6 +5107,8 @@ Perl_call_list(pTHX_ I32 oldscope, AV *paramList) int ret; dJMPENV; + PERL_ARGS_ASSERT_CALL_LIST; + while (av_len(paramList) >= 0) { cv = (CV*)av_shift(paramList); if (PL_savebegin) { @@ -5096,8 +5202,6 @@ void Perl_my_exit(pTHX_ U32 status) { dVAR; - DEBUG_S(PerlIO_printf(Perl_debug_log, "my_exit: thread %p, status %lu\n", - (void*)thr, (unsigned long) status)); switch (status) { case 0: STATUS_ALL_SUCCESS;