X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=5c3f416d8e3319e69453521b3fa916c5f8f7024d;hb=eb9bdbdff170fbef354c89f26311bc9e4a0e7245;hp=b4b68dc559871263da82bd6b639a1be6a03f1df3;hpb=10516c54a74630cf74b5f3650f62a47cae3b2ac0;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index b4b68dc..5c3f416 100644 --- a/perl.c +++ b/perl.c @@ -92,6 +92,21 @@ char *nw_get_sitelib(const char *pl); #include #endif +#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP +# ifdef I_SYS_WAIT +# include +# endif +# ifdef I_SYSUIO +# include +# endif + +union control_un { + struct cmsghdr cm; + char control[CMSG_SPACE(sizeof(int))]; +}; + +#endif + #ifdef __BEOS__ # define HZ 1000000 #endif @@ -203,6 +218,7 @@ void perl_construct(pTHXx) { dVAR; + PERL_UNUSED_ARG(my_perl); #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -336,11 +352,8 @@ perl_construct(pTHXx) if ((long) PL_mmap_page_size < 0) { if (errno) { SV *error = ERRSV; - char *msg; - STRLEN n_a; (void) SvUPGRADE(error, SVt_PV); - msg = SvPVx(error, n_a); - Perl_croak(aTHX_ "panic: sysconf: %s", msg); + Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error)); } else Perl_croak(aTHX_ "panic: sysconf: pagesize unknown"); @@ -386,6 +399,104 @@ Perl_nothreadhook(pTHX) return 0; } +#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP +void +Perl_dump_sv_child(pTHX_ SV *sv) +{ + ssize_t got; + const int sock = PL_dumper_fd; + const int debug_fd = PerlIO_fileno(Perl_debug_log); + union control_un control; + struct msghdr msg; + struct iovec vec[2]; + struct cmsghdr *cmptr; + int returned_errno; + unsigned char buffer[256]; + + if(sock == -1 || debug_fd == -1) + return; + + PerlIO_flush(Perl_debug_log); + + /* All these shenanigans are to pass a file descriptor over to our child for + it to dump out to. We can't let it hold open the file descriptor when it + forks, as the file descriptor it will dump to can turn out to be one end + of pipe that some other process will wait on for EOF. (So as it would + be open, the wait would be forever. */ + + msg.msg_control = control.control; + msg.msg_controllen = sizeof(control.control); + /* We're a connected socket so we don't need a destination */ + msg.msg_name = NULL; + msg.msg_namelen = 0; + msg.msg_iov = vec; + msg.msg_iovlen = 1; + + cmptr = CMSG_FIRSTHDR(&msg); + cmptr->cmsg_len = CMSG_LEN(sizeof(int)); + cmptr->cmsg_level = SOL_SOCKET; + cmptr->cmsg_type = SCM_RIGHTS; + *((int *)CMSG_DATA(cmptr)) = 1; + + vec[0].iov_base = (void*)&sv; + vec[0].iov_len = sizeof(sv); + got = sendmsg(sock, &msg, 0); + + if(got < 0) { + perror("Debug leaking scalars parent sendmsg failed"); + abort(); + } + if(got < sizeof(sv)) { + perror("Debug leaking scalars parent short sendmsg"); + abort(); + } + + /* Return protocol is + int: errno value + unsigned char: length of location string (0 for empty) + unsigned char*: string (not terminated) + */ + vec[0].iov_base = (void*)&returned_errno; + vec[0].iov_len = sizeof(returned_errno); + vec[1].iov_base = buffer; + vec[1].iov_len = 1; + + got = readv(sock, vec, 2); + + if(got < 0) { + perror("Debug leaking scalars parent read failed"); + PerlIO_flush(PerlIO_stderr()); + abort(); + } + if(got < sizeof(returned_errno) + 1) { + perror("Debug leaking scalars parent short read"); + PerlIO_flush(PerlIO_stderr()); + abort(); + } + + if (*buffer) { + got = read(sock, buffer + 1, *buffer); + if(got < 0) { + perror("Debug leaking scalars parent read 2 failed"); + PerlIO_flush(PerlIO_stderr()); + abort(); + } + + if(got < *buffer) { + perror("Debug leaking scalars parent short read 2"); + PerlIO_flush(PerlIO_stderr()); + abort(); + } + } + + if (returned_errno || *buffer) { + Perl_warn(aTHX_ "Debug leaking scalars child failed%s%.*s with errno" + " %d: %s", (*buffer ? " at " : ""), (int) *buffer, buffer + 1, + returned_errno, strerror(returned_errno)); + } +} +#endif + /* =for apidoc perl_destruct @@ -400,6 +511,11 @@ perl_destruct(pTHXx) dVAR; volatile int destruct_level; /* 0=none, 1=full, 2=full with checks */ HV *hv; +#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP + pid_t child; +#endif + + PERL_UNUSED_ARG(my_perl); /* wait for all pseudo-forked children to finish */ PERL_WAIT_FOR_CHILDREN; @@ -407,8 +523,8 @@ perl_destruct(pTHXx) destruct_level = PL_perl_destruct_level; #ifdef DEBUGGING { - const char *s; - if ((s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"))) { + const char * const s = PerlEnv_getenv("PERL_DESTRUCT_LEVEL"); + if (s) { const int i = atoi(s); if (destruct_level < i) destruct_level = i; @@ -421,6 +537,7 @@ perl_destruct(pTHXx) int x = 0; JMPENV_PUSH(x); + PERL_UNUSED_VAR(x); if (PL_endav && !PL_minus_c) call_list(PL_scopestack_ix, PL_endav); JMPENV_POP; @@ -436,9 +553,168 @@ perl_destruct(pTHXx) return STATUS_NATIVE_EXPORT; } +#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP + if (destruct_level != 0) { + /* Fork here to create a child. Our child's job is to preserve the + state of scalars prior to destruction, so that we can instruct it + to dump any scalars that we later find have leaked. + There's no subtlety in this code - it assumes POSIX, and it doesn't + fail gracefully */ + int fd[2]; + + if(socketpair(AF_UNIX, SOCK_STREAM, 0, fd)) { + perror("Debug leaking scalars socketpair failed"); + abort(); + } + + child = fork(); + if(child == -1) { + perror("Debug leaking scalars fork failed"); + abort(); + } + if (!child) { + /* We are the child */ + const int sock = fd[1]; + const int debug_fd = PerlIO_fileno(Perl_debug_log); + int f; + const char *where; + /* Our success message is an integer 0, and a char 0 */ + static const char success[sizeof(int) + 1]; + + close(fd[0]); + + /* We need to close all other file descriptors otherwise we end up + with interesting hangs, where the parent closes its end of a + pipe, and sits waiting for (another) child to terminate. Only + that child never terminates, because it never gets EOF, because + we also have the far end of the pipe open. We even need to + close the debugging fd, because sometimes it happens to be one + end of a pipe, and a process is waiting on the other end for + EOF. Normally it would be closed at some point earlier in + destruction, but if we happen to cause the pipe to remain open, + EOF never occurs, and we get an infinite hang. Hence all the + games to pass in a file descriptor if it's actually needed. */ + + f = sysconf(_SC_OPEN_MAX); + if(f < 0) { + where = "sysconf failed"; + goto abort; + } + while (f--) { + if (f == sock) + continue; + close(f); + } + + while (1) { + SV *target; + union control_un control; + struct msghdr msg; + struct iovec vec[1]; + struct cmsghdr *cmptr; + ssize_t got; + int got_fd; + + msg.msg_control = control.control; + msg.msg_controllen = sizeof(control.control); + /* We're a connected socket so we don't need a source */ + msg.msg_name = NULL; + msg.msg_namelen = 0; + msg.msg_iov = vec; + msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]); + + vec[0].iov_base = (void*)⌖ + vec[0].iov_len = sizeof(target); + + got = recvmsg(sock, &msg, 0); + + if(got == 0) + break; + if(got < 0) { + where = "recv failed"; + goto abort; + } + if(got < sizeof(target)) { + where = "short recv"; + goto abort; + } + + if(!(cmptr = CMSG_FIRSTHDR(&msg))) { + where = "no cmsg"; + goto abort; + } + if(cmptr->cmsg_len != CMSG_LEN(sizeof(int))) { + where = "wrong cmsg_len"; + goto abort; + } + if(cmptr->cmsg_level != SOL_SOCKET) { + where = "wrong cmsg_level"; + goto abort; + } + if(cmptr->cmsg_type != SCM_RIGHTS) { + where = "wrong cmsg_type"; + goto abort; + } + + got_fd = *(int*)CMSG_DATA(cmptr); + /* For our last little bit of trickery, put the file descriptor + back into Perl_debug_log, as if we never actually closed it + */ + if(got_fd != debug_fd) { + if (dup2(got_fd, debug_fd) == -1) { + where = "dup2"; + goto abort; + } + } + sv_dump(target); + + PerlIO_flush(Perl_debug_log); + + got = write(sock, &success, sizeof(success)); + + if(got < 0) { + where = "write failed"; + goto abort; + } + if(got < sizeof(success)) { + where = "short write"; + goto abort; + } + } + _exit(0); + abort: + { + int send_errno = errno; + unsigned char length = (unsigned char) strlen(where); + struct iovec failure[3] = { + {(void*)&send_errno, sizeof(send_errno)}, + {&length, 1}, + {(void*)where, length} + }; + int got = writev(sock, failure, 3); + /* Bad news travels fast. Faster than data. We'll get a SIGPIPE + in the parent if we try to read from the socketpair after the + child has exited, even if there was data to read. + So sleep a bit to give the parent a fighting chance of + reading the data. */ + sleep(2); + _exit((got == -1) ? errno : 0); + } + /* End of child. */ + } + PL_dumper_fd = fd[0]; + close(fd[1]); + } +#endif + /* We must account for everything. */ /* Destroy the main CV and syntax tree */ + /* Do this now, because destroying ops can cause new SVs to be generated + in Perl_pad_swipe, and when running with -DDEBUG_LEAKING_SCALARS they + PL_curcop to point to a valid op from which the filename structure + member is copied. */ + PL_curcop = &PL_compiling; if (PL_main_root) { /* ensure comppad/curpad to refer to main's pad */ if (CvPADLIST(PL_main_cv)) { @@ -447,7 +723,6 @@ perl_destruct(pTHXx) op_free(PL_main_root); PL_main_root = Nullop; } - PL_curcop = &PL_compiling; PL_main_start = Nullop; SvREFCNT_dec(PL_main_cv); PL_main_cv = Nullcv; @@ -806,23 +1081,23 @@ perl_destruct(pTHXx) { /* Yell and reset the HeVAL() slots that are still holding refcounts, * so that sv_free() won't fail on them. + * Now that the global string table is using a single hunk of memory + * for both HE and HEK, we either need to explicitly unshare it the + * correct way, or actually free things here. */ - I32 riter; - I32 max; - HE *hent; - HE **array; - - riter = 0; - max = HvMAX(PL_strtab); - array = HvARRAY(PL_strtab); - hent = array[0]; + I32 riter = 0; + const I32 max = HvMAX(PL_strtab); + HE **array = HvARRAY(PL_strtab); + HE *hent = array[0]; + for (;;) { if (hent && ckWARN_d(WARN_INTERNAL)) { + HE *next = HeNEXT(hent); Perl_warner(aTHX_ packWARN(WARN_INTERNAL), "Unbalanced string table refcount: (%d) for \"%s\"", HeVAL(hent) - Nullsv, HeKEY(hent)); - HeVAL(hent) = Nullsv; - hent = HeNEXT(hent); + Safefree(hent); + hent = next; } if (!hent) { if (++riter > max) @@ -830,6 +1105,11 @@ perl_destruct(pTHXx) hent = array[riter]; } } + + Safefree(array); + HvARRAY(PL_strtab) = 0; + HvTOTALKEYS(PL_strtab) = 0; + HvFILL(PL_strtab) = 0; } SvREFCNT_dec(PL_strtab); @@ -837,8 +1117,6 @@ perl_destruct(pTHXx) /* free the pointer tables used for cloning */ ptr_table_free(PL_ptr_table); PL_ptr_table = (PTR_TBL_t*)NULL; - ptr_table_free(PL_shared_hek_table); - PL_shared_hek_table = (PTR_TBL_t*)NULL; #endif /* free special SVs */ @@ -888,10 +1166,31 @@ perl_destruct(pTHXx) PL_op_name[sv->sv_debug_optype]: "(none)", sv->sv_debug_cloned ? " (cloned)" : "" ); +#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP + Perl_dump_sv_child(aTHX_ sv); +#endif } } } } +#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP + { + int status; + fd_set rset; + /* Wait for up to 4 seconds for child to terminate. + This seems to be the least effort way of timing out on reaping + its exit status. */ + struct timeval waitfor = {4, 0}; + int sock = PL_dumper_fd; + + shutdown(sock, 1); + FD_ZERO(&rset); + FD_SET(sock, &rset); + select(sock + 1, &rset, NULL, NULL, &waitfor); + waitpid(child, &status, WNOHANG); + close(sock); + } +#endif #endif PL_sv_count = 0; @@ -927,8 +1226,6 @@ perl_destruct(pTHXx) Safefree(PL_psig_pend); PL_psig_pend = (int*)NULL; PL_formfeed = Nullsv; - Safefree(PL_ofmt); - PL_ofmt = Nullch; nuke_stacks(); PL_tainting = FALSE; PL_taint_warn = FALSE; @@ -1098,6 +1395,8 @@ perl_parse(pTHXx_ XSINIT_t xsinit, int argc, char **argv, char **env) int ret; dJMPENV; + PERL_UNUSED_VAR(my_perl); + #ifdef SETUID_SCRIPTS_ARE_SECURE_NOW #ifdef IAMSUID #undef IAMSUID @@ -1115,15 +1414,10 @@ setuid perl scripts securely.\n"); if (!PL_rehash_seed_set) PL_rehash_seed = get_hash_seed(); { - char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); + const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); - if (s) { - int i = atoi(s); - - if (i == 1) - PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", - PL_rehash_seed); - } + if (s && (atoi(s) == 1)) + PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed); } #endif /* #if defined(USE_HASH_SEED) || defined(USE_HASH_SEED_EXPLICIT) */ @@ -1140,10 +1434,10 @@ setuid perl scripts securely.\n"); * --jhi */ const char *s = NULL; int i; - UV mask = + const UV mask = ~(UV)(PTRSIZE == 4 ? 3 : PTRSIZE == 8 ? 7 : PTRSIZE == 16 ? 15 : 0); /* Do the mask check only if the args seem like aligned. */ - UV aligned = + const UV aligned = (mask < ~(UV)0) && ((PTR2UV(argv[0]) & mask) == PTR2UV(argv[0])); /* See if all the arguments are contiguous in memory. Note @@ -1287,7 +1581,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) register SV *sv; register char *s; const char *cddir = Nullch; +#ifdef USE_SITECUSTOMIZE bool minus_f = FALSE; +#endif PL_fdscript = -1; PL_suidscript = -1; @@ -1382,7 +1678,9 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) break; case 'f': +#ifdef USE_SITECUSTOMIZE minus_f = TRUE; +#endif s++; goto reswitch; @@ -1837,6 +2135,8 @@ perl_run(pTHXx) int ret = 0; dJMPENV; + PERL_UNUSED_ARG(my_perl); + oldscope = PL_scopestack_ix; #ifdef VMS VMSISH_HUSHED = 0; @@ -2236,6 +2536,9 @@ Perl_call_sv(pTHX_ SV *sv, I32 flags) POPEVAL(cx); PL_curpm = newpm; LEAVE; + PERL_UNUSED_VAR(newsp); + PERL_UNUSED_VAR(gimme); + PERL_UNUSED_VAR(optype); } JMPENV_POP; } @@ -2381,8 +2684,7 @@ Perl_eval_pv(pTHX_ const char *p, I32 croak_on_error) PUTBACK; if (croak_on_error && SvTRUE(ERRSV)) { - STRLEN n_a; - Perl_croak(aTHX_ SvPVx(ERRSV, n_a)); + Perl_croak(aTHX_ SvPVx_nolen_const(ERRSV)); } return sv; @@ -2433,37 +2735,35 @@ S_usage(pTHX_ const char *name) /* XXX move this out into a module ? */ * Removed -h because the user already knows that option. Others? */ static const char * const usage_msg[] = { -"-0[octal] specify record separator (\\0, if no argument)", -"-A[name] 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)", -"-d[:debugger] run program under debugger", -"-D[number/list] set debugging flags (argument is a bit mask or alphabets)", -"-e program one line of program (several -e's allowed, omit programfile)", -#ifdef USE_SITECUSTOMIZE -"-f don't do $sitelib/sitecustomize.pl at startup", -#endif -"-F/pattern/ split() pattern for -a switch (//'s are optional)", -"-i[extension] edit <> files in place (makes backup if extension supplied)", -"-Idirectory specify @INC/#include directory (several -I's allowed)", -"-l[octal] enable line ending processing, specifies line terminator", -"-[mM][-]module execute \"use/no module...\" before executing program", -"-n assume \"while (<>) { ... }\" loop around program", -"-p assume loop like -n but print line also, like sed", -"-P run program through C preprocessor before compilation", -"-s enable rudimentary parsing for switches after programfile", -"-S look for programfile using PATH environment variable", -"-t enable tainting warnings", -"-T enable tainting checks", -"-u dump core after parsing program", -"-U allow unsafe operations", -"-v print version, subversion (includes VERY IMPORTANT perl info)", -"-V[:variable] print configuration summary (or a single Config.pm variable)", -"-w enable many useful warnings (RECOMMENDED)", -"-W enable all warnings", -"-x[directory] strip off text before #!perl line and perhaps cd to directory", -"-X disable all warnings", +"-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)", +"-d[:debugger] run program under debugger", +"-D[number/list] set debugging flags (argument is a bit mask or alphabets)", +"-e program one line of program (several -e's allowed, omit programfile)", +"-f don't do $sitelib/sitecustomize.pl at startup", +"-F/pattern/ split() pattern for -a switch (//'s are optional)", +"-i[extension] edit <> files in place (makes backup if extension supplied)", +"-Idirectory specify @INC/#include directory (several -I's allowed)", +"-l[octal] enable line ending processing, specifies line terminator", +"-[mM][-]module execute \"use/no module...\" before executing program", +"-n assume \"while (<>) { ... }\" loop around program", +"-p assume loop like -n but print line also, like sed", +"-P run program through C preprocessor before compilation", +"-s enable rudimentary parsing for switches after programfile", +"-S look for programfile using PATH environment variable", +"-t enable tainting warnings", +"-T enable tainting checks", +"-u dump core after parsing program", +"-U allow unsafe operations", +"-v print version, subversion (includes VERY IMPORTANT perl info)", +"-V[:variable] print configuration summary (or a single Config.pm variable)", +"-w enable many useful warnings (RECOMMENDED)", +"-W enable all warnings", +"-x[directory] strip off text before #!perl line and perhaps cd to directory", +"-X disable all warnings", "\n", NULL }; @@ -2658,7 +2958,6 @@ Perl_moreswitches(pTHX_ char *s) "Recompile perl with -DDEBUGGING to use -D switch (did you mean -d ?)\n"); for (s++; isALNUM(*s); s++) ; #endif - /*SUPPRESS 530*/ return s; } case 'h': @@ -2674,8 +2973,8 @@ Perl_moreswitches(pTHX_ char *s) } #endif /* __CYGWIN__ */ PL_inplace = savepv(s+1); - /*SUPPRESS 530*/ - for (s = PL_inplace; *s && !isSPACE(*s); s++) ; + for (s = PL_inplace; *s && !isSPACE(*s); s++) + ; if (*s) { *s++ = '\0'; if (*s == '-') /* Additional switches on #! line. */ @@ -2735,17 +3034,27 @@ Perl_moreswitches(pTHX_ char *s) forbid_setid("-A"); if (!PL_preambleav) PL_preambleav = newAV(); - if (*++s) { - SV *sv = newSVpv("use assertions::activate split(/,/,q", 0); - sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */ - sv_catpv(sv,s); - sv_catpvn(sv, "\0)", 2); - s+=strlen(s); + s++; + { + char *start = s; + SV *sv = newSVpv("use assertions::activate", 24); + while(isALNUM(*s) || *s == ':') ++s; + if (s != start) { + sv_catpvn(sv, "::", 2); + sv_catpvn(sv, start, s-start); + } + if (*s == '=') { + sv_catpvn(sv, " split(/,/,q\0", 13); + sv_catpv(sv, s+1); + sv_catpvn(sv, "\0)", 2); + s+=strlen(s); + } + else if (*s != '\0') { + Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start); + } av_push(PL_preambleav, sv); + return s; } - else - av_push(PL_preambleav, newSVpvn("use assertions::activate",24)); - return s; case 'M': forbid_setid("-M"); /* XXX ? */ /* FALL THROUGH */ @@ -2825,13 +3134,13 @@ Perl_moreswitches(pTHX_ char *s) (void *)upg_version(PL_patchlevel); #if !defined(DGUX) PerlIO_printf(PerlIO_stdout(), - Perl_form(aTHX_ "\nThis is perl, v%"SVf" built for %s", + Perl_form(aTHX_ "\nThis is perl, %"SVf" built for %s", vstringify(PL_patchlevel), ARCHNAME)); #else /* DGUX */ /* Adjust verbose output as in the perl that ships with the DG/UX OS from EMC */ PerlIO_printf(PerlIO_stdout(), - Perl_form(aTHX_ "\nThis is perl, v%"SVf"\n", + Perl_form(aTHX_ "\nThis is perl, %"SVf"\n", vstringify(PL_patchlevel))); PerlIO_printf(PerlIO_stdout(), Perl_form(aTHX_ " built under %s at %s %s\n", @@ -3184,7 +3493,8 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) DEBUG_P(PerlIO_printf(Perl_debug_log, "PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n", - scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS)); + scriptname, SvPVX_const (cpp), SvPVX_const (sv), + CPPMINUS)); # if defined(MSDOS) || defined(WIN32) || defined(VMS) quote = "\""; @@ -3225,9 +3535,9 @@ S_open_script(pTHX_ const char *scriptname, bool dosearch, SV *sv) DEBUG_P(PerlIO_printf(Perl_debug_log, "PL_preprocess: cmd=\"%s\"\n", - SvPVX(cmd))); + SvPVX_const(cmd))); - PL_rsfp = PerlProc_popen(SvPVX(cmd), (char *)"r"); + PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r"); SvREFCNT_dec(cmd); SvREFCNT_dec(cpp); } @@ -3422,13 +3732,13 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) */ #ifdef DOSUID - char *s, *s2; + const char *s, *s2; if (PerlLIO_fstat(PerlIO_fileno(PL_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; - STRLEN n_a; + const char *linestr; #ifdef IAMSUID if (PL_fdscript < 0 || PL_suidscript != 1) @@ -3526,10 +3836,12 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) 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); + linestr = SvPV_nolen_const(PL_linestr); if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch || - strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */ + strnNE(linestr,"#!",2) ) /* required even on Sys V */ Perl_croak(aTHX_ "No #! line"); - s = SvPV(PL_linestr,n_a)+2; + linestr+=2; + s = linestr; /* PSz 27 Feb 04 */ /* Sanity check on line length */ if (strlen(s) < 1 || strlen(s) > 4000) @@ -3538,12 +3850,12 @@ S_validate_suid(pTHX_ const char *validarg, const char *scriptname) while (isSPACE(*s)) s++; /* Sanity check on buffer end */ while ((*s) && !isSPACE(*s)) s++; - for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 && + for (s2 = s; (s2 > linestr && (isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_' || s2[-1] == '-')); s2--) ; /* Sanity check on buffer start */ - if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) && - (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) ) + if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) && + (s-9 < linestr || strnNE(s-9,"perl",4)) ) Perl_croak(aTHX_ "Not a perl script"); while (*s == ' ' || *s == '\t') s++; /* @@ -3833,7 +4145,6 @@ S_find_beginning(pTHX) while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.' || s2[-1] == '_') s2--; if (strnEQ(s2-4,"perl",4)) - /*SUPPRESS 530*/ while ((s = moreswitches(s))) ; } @@ -4363,7 +4674,7 @@ STATIC SV * S_incpush_if_exists(pTHX_ SV *dir) { Stat_t tmpstatbuf; - if (PerlLIO_stat(SvPVX(dir), &tmpstatbuf) >= 0 && + if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 && S_ISDIR(tmpstatbuf.st_mode)) { av_push(GvAVn(PL_incgv), dir); dir = NEWSV(0,0); @@ -4836,17 +5147,19 @@ S_my_exit_jump(pTHX) } JMPENV_JUMP(2); + PERL_UNUSED_VAR(gimme); + PERL_UNUSED_VAR(newsp); } static I32 read_e_script(pTHX_ int idx, SV *buf_sv, int maxlen) { - char *p, *nl; - (void)idx; - (void)maxlen; + const char * const p = SvPVX_const(PL_e_script); + const char *nl = strchr(p, '\n'); + + PERL_UNUSED_ARG(idx); + PERL_UNUSED_ARG(maxlen); - p = SvPVX(PL_e_script); - nl = strchr(p, '\n'); nl = (nl) ? nl+1 : SvEND(PL_e_script); if (nl-p == 0) { filter_del(read_e_script);