X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=3ff4a80eec762031d99fe1f0cc4d47547696c9f9;hb=8aad04aa6a2ab20a526b53089f8919d46434ca7e;hp=7cb4fdfaf6e41a25845d4381b01895eb07f69dcd;hpb=f5542d3a54f14f881b60902316767ce068dbe5dd;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index 7cb4fdf..3ff4a80 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 @@ -150,7 +165,7 @@ perl_alloc_using(struct IPerlMem* ipM, struct IPerlMem* ipMS, struct IPerlProc* ipP) { PerlInterpreter *my_perl; - /* New() needs interpreter, so call malloc() instead */ + /* Newx() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)(*ipM->pMalloc)(ipM, sizeof(PerlInterpreter)); S_init_tls_and_interp(my_perl); Zero(my_perl, 1, PerlInterpreter); @@ -183,7 +198,7 @@ perl_alloc(void) { PerlInterpreter *my_perl; - /* New() needs interpreter, so call malloc() instead */ + /* Newx() needs interpreter, so call malloc() instead */ my_perl = (PerlInterpreter*)PerlMem_malloc(sizeof(PerlInterpreter)); S_init_tls_and_interp(my_perl); @@ -203,6 +218,7 @@ void perl_construct(pTHXx) { dVAR; + PERL_UNUSED_ARG(my_perl); #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -242,7 +258,7 @@ perl_construct(pTHXx) SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2; } - PL_sighandlerp = Perl_sighandler; + PL_sighandlerp = (Sighandler_t) Perl_sighandler; PL_pidstatus = newHV(); } @@ -316,12 +332,8 @@ perl_construct(pTHXx) PL_stashcache = newHV(); - PL_patchlevel = newSVpv( - Perl_form(aTHX_ "%d.%d.%d", - (int)PERL_REVISION, - (int)PERL_VERSION, - (int)PERL_SUBVERSION ), 0 - ); + PL_patchlevel = Perl_newSVpvf(aTHX_ "%d.%d.%d", (int)PERL_REVISION, + (int)PERL_VERSION, (int)PERL_SUBVERSION); #ifdef HAS_MMAP if (!PL_mmap_page_size) { @@ -383,6 +395,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 @@ -397,6 +507,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; @@ -404,8 +519,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; @@ -418,6 +533,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; @@ -433,9 +549,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)) { @@ -444,7 +719,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; @@ -803,23 +1077,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) @@ -827,6 +1101,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); @@ -883,10 +1162,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; @@ -908,8 +1208,7 @@ perl_destruct(pTHXx) Safefree(PL_reg_start_tmp); PL_reg_start_tmp = (char**)NULL; PL_reg_start_tmpl = 0; - if (PL_reg_curpm) - Safefree(PL_reg_curpm); + Safefree(PL_reg_curpm); Safefree(PL_reg_poscache); free_tied_hv_pool(); Safefree(PL_op_mask); @@ -922,8 +1221,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; @@ -1069,9 +1366,9 @@ S_set_caret_X(pTHX) { S_procself_val(aTHX_ GvSV(tmpgv), PL_origargv[0]); #else #ifdef OS2 - sv_setpv(GvSV(tmpgv), os2_execname(aTHX)); + sv_setpv(GvSVn(tmpgv), os2_execname(aTHX)); #else - sv_setpv(GvSV(tmpgv),PL_origargv[0]); + sv_setpv(GvSVn(tmpgv),PL_origargv[0]); #endif #endif } @@ -1093,6 +1390,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 @@ -1110,15 +1409,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) */ @@ -1135,10 +1429,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 @@ -1391,9 +1685,8 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) argc--,argv++; } if (s && *s) { - char *p; STRLEN len = strlen(s); - p = savepvn(s, len); + const char * const p = savepvn(s, len); incpush(p, TRUE, TRUE, FALSE, FALSE); sv_catpvn(sv, "-I", 2); sv_catpvn(sv, p, len); @@ -1414,117 +1707,172 @@ S_parse_body(pTHX_ char **env, XSINIT_t xsinit) s++; goto reswitch; case 'V': - if (!PL_preambleav) - PL_preambleav = newAV(); - av_push(PL_preambleav, newSVpv("use Config qw(myconfig config_vars)",0)); - if (*++s != ':') { - STRLEN opts; - - PL_Sv = newSVpv("print myconfig();",0); + { + SV *opts_prog; + + if (!PL_preambleav) + PL_preambleav = newAV(); + av_push(PL_preambleav, + newSVpv("use Config;",0)); + if (*++s != ':') { + STRLEN opts; + + opts_prog = newSVpv("print Config::myconfig(),",0); #ifdef VMS - sv_catpv(PL_Sv,"print \"\\nCharacteristics of this PERLSHR image: \\n\","); + sv_catpv(opts_prog,"\"\\nCharacteristics of this PERLSHR image: \\n\","); #else - sv_catpv(PL_Sv,"print \"\\nCharacteristics of this binary (from libperl): \\n\","); + sv_catpv(opts_prog,"\"\\nCharacteristics of this binary (from libperl): \\n\","); #endif - opts = SvCUR(PL_Sv); + opts = SvCUR(opts_prog); - sv_catpv(PL_Sv,"\" Compile-time options:"); + sv_catpv(opts_prog,"\" Compile-time options:"); # ifdef DEBUGGING - sv_catpv(PL_Sv," DEBUGGING"); + sv_catpv(opts_prog," DEBUGGING"); +# endif +# ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP + sv_catpv(opts_prog," DEBUG_LEAKING_SCALARS_FORK_DUMP"); +# endif +# ifdef FAKE_THREADS + sv_catpv(opts_prog," FAKE_THREADS"); # endif # ifdef MULTIPLICITY - sv_catpv(PL_Sv," MULTIPLICITY"); + sv_catpv(opts_prog," MULTIPLICITY"); +# endif +# ifdef MYMALLOC + sv_catpv(opts_prog," MYMALLOC"); +# endif +# ifdef PERL_DONT_CREATE_GVSV + sv_catpv(opts_prog," PERL_DONT_CREATE_GVSV"); +# endif +# ifdef PERL_GLOBAL_STRUCT + sv_catpv(opts_prog," PERL_GLOBAL_STRUCT"); +# endif +# ifdef PERL_IMPLICIT_CONTEXT + sv_catpv(opts_prog," PERL_IMPLICIT_CONTEXT"); +# endif +# ifdef PERL_IMPLICIT_SYS + sv_catpv(opts_prog," PERL_IMPLICIT_SYS"); +# endif +# ifdef PERL_MALLOC_WRAP + sv_catpv(opts_prog," PERL_MALLOC_WRAP"); +# endif +# ifdef PERL_NEED_APPCTX + sv_catpv(opts_prog," PERL_NEED_APPCTX"); +# endif +# ifdef PERL_NEED_TIMESBASE + sv_catpv(opts_prog," PERL_NEED_TIMESBASE"); +# endif +# ifdef PERL_OLD_COPY_ON_WRITE + sv_catpv(opts_prog," PERL_OLD_COPY_ON_WRITE"); +# endif +# ifdef PL_OP_SLAB_ALLOC + sv_catpv(opts_prog," PL_OP_SLAB_ALLOC"); +# endif +# ifdef THREADS_HAVE_PIDS + sv_catpv(opts_prog," THREADS_HAVE_PIDS"); # endif # ifdef USE_5005THREADS - sv_catpv(PL_Sv," USE_5005THREADS"); + sv_catpv(opts_prog," USE_5005THREADS"); # endif -# ifdef USE_ITHREADS - sv_catpv(PL_Sv," USE_ITHREADS"); +# ifdef USE_64_BIT_ALL + sv_catpv(opts_prog," USE_64_BIT_ALL"); # endif # ifdef USE_64_BIT_INT - sv_catpv(PL_Sv," USE_64_BIT_INT"); + sv_catpv(opts_prog," USE_64_BIT_INT"); # endif -# ifdef USE_64_BIT_ALL - sv_catpv(PL_Sv," USE_64_BIT_ALL"); +# ifdef USE_ITHREADS + sv_catpv(opts_prog," USE_ITHREADS"); +# endif +# ifdef USE_LARGE_FILES + sv_catpv(opts_prog," USE_LARGE_FILES"); # endif # ifdef USE_LONG_DOUBLE - sv_catpv(PL_Sv," USE_LONG_DOUBLE"); + sv_catpv(opts_prog," USE_LONG_DOUBLE"); # endif -# ifdef USE_LARGE_FILES - sv_catpv(PL_Sv," USE_LARGE_FILES"); +# ifdef USE_PERLIO + sv_catpv(opts_prog," USE_PERLIO"); # endif -# ifdef USE_SOCKS - sv_catpv(PL_Sv," USE_SOCKS"); +# ifdef USE_REENTRANT_API + sv_catpv(opts_prog," USE_REENTRANT_API"); +# endif +# ifdef USE_SFIO + sv_catpv(opts_prog," USE_SFIO"); # endif # ifdef USE_SITECUSTOMIZE - sv_catpv(PL_Sv," USE_SITECUSTOMIZE"); + sv_catpv(opts_prog," USE_SITECUSTOMIZE"); # endif -# ifdef PERL_IMPLICIT_CONTEXT - sv_catpv(PL_Sv," PERL_IMPLICIT_CONTEXT"); -# endif -# ifdef PERL_IMPLICIT_SYS - sv_catpv(PL_Sv," PERL_IMPLICIT_SYS"); +# ifdef USE_SOCKS + sv_catpv(opts_prog," USE_SOCKS"); # endif - while (SvCUR(PL_Sv) > opts+76) { - /* find last space after "options: " and before col 76 */ + while (SvCUR(opts_prog) > opts+76) { + /* find last space after "options: " and before col 76 + */ - const char *space; - char *pv = SvPV_nolen(PL_Sv); - const char c = pv[opts+76]; - pv[opts+76] = '\0'; - space = strrchr(pv+opts+26, ' '); - pv[opts+76] = c; - if (!space) break; /* "Can't happen" */ + const char *space; + char *pv = SvPV_nolen(opts_prog); + const char c = pv[opts+76]; + pv[opts+76] = '\0'; + space = strrchr(pv+opts+26, ' '); + pv[opts+76] = c; + if (!space) break; /* "Can't happen" */ - /* break the line before that space */ + /* break the line before that space */ - opts = space - pv; - sv_insert(PL_Sv, opts, 0, - "\\n ", 25); - } + opts = space - pv; + sv_insert(opts_prog, opts, 0, + "\\n ", 25); + } - sv_catpv(PL_Sv,"\\n\","); + sv_catpv(opts_prog,"\\n\","); #if defined(LOCAL_PATCH_COUNT) - if (LOCAL_PATCH_COUNT > 0) { - int i; - sv_catpv(PL_Sv,"\" Locally applied patches:\\n\","); - for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { - if (PL_localpatches[i]) - Perl_sv_catpvf(aTHX_ PL_Sv,"q%c\t%s\n%c,", - 0, PL_localpatches[i], 0); + if (LOCAL_PATCH_COUNT > 0) { + int i; + sv_catpv(opts_prog, + "\" Locally applied patches:\\n\","); + for (i = 1; i <= LOCAL_PATCH_COUNT; i++) { + if (PL_localpatches[i]) + Perl_sv_catpvf(aTHX_ opts_prog,"q%c\t%s\n%c,", + 0, PL_localpatches[i], 0); + } } - } #endif - Perl_sv_catpvf(aTHX_ PL_Sv,"\" Built under %s\\n\"",OSNAME); + Perl_sv_catpvf(aTHX_ opts_prog, + "\" Built under %s\\n\"",OSNAME); #ifdef __DATE__ # ifdef __TIME__ - Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled at %s %s\\n\"",__DATE__,__TIME__); + Perl_sv_catpvf(aTHX_ opts_prog, + ",\" Compiled at %s %s\\n\"",__DATE__, + __TIME__); # else - Perl_sv_catpvf(aTHX_ PL_Sv,",\" Compiled on %s\\n\"",__DATE__); + Perl_sv_catpvf(aTHX_ opts_prog,",\" Compiled on %s\\n\"", + __DATE__); # endif #endif - sv_catpv(PL_Sv, "; \ -$\"=\"\\n \"; \ -@env = map { \"$_=\\\"$ENV{$_}\\\"\" } sort grep {/^PERL/} keys %ENV; "); + sv_catpv(opts_prog, "; $\"=\"\\n \"; " + "@env = map { \"$_=\\\"$ENV{$_}\\\"\" } " + "sort grep {/^PERL/} keys %ENV; "); #ifdef __CYGWIN__ - sv_catpv(PL_Sv,"\ -push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";"); + sv_catpv(opts_prog, + "push @env, \"CYGWIN=\\\"$ENV{CYGWIN}\\\"\";"); #endif - sv_catpv(PL_Sv, "\ -print \" \\%ENV:\\n @env\\n\" if @env; \ -print \" \\@INC:\\n @INC\\n\";"); - } - else { - PL_Sv = newSVpv("config_vars(qw(",0); - sv_catpv(PL_Sv, ++s); - sv_catpv(PL_Sv, "))"); - s += strlen(s); + sv_catpv(opts_prog, + "print \" \\%ENV:\\n @env\\n\" if @env;" + "print \" \\@INC:\\n @INC\\n\";"); + } + else { + ++s; + opts_prog = Perl_newSVpvf(aTHX_ + "Config::config_vars(qw%c%s%c)", + 0, s, 0); + s += strlen(s); + } + av_push(PL_preambleav, opts_prog); + /* don't look for script or read stdin */ + scriptname = BIT_BUCKET; + goto reswitch; } - av_push(PL_preambleav, PL_Sv); - scriptname = BIT_BUCKET; /* don't look for script or read stdin */ - goto reswitch; case 'x': PL_doextract = TRUE; s++; @@ -1653,7 +2001,7 @@ print \" \\@INC:\\n @INC\\n\";"); # define SIGCHLD SIGCLD #endif Sighandler_t sigstate = rsignal_state(SIGCHLD); - if (sigstate == SIG_IGN) { + if (sigstate == (Sighandler_t) SIG_IGN) { if (ckWARN(WARN_SIGNAL)) Perl_warner(aTHX_ packWARN(WARN_SIGNAL), "Can't ignore signal CHLD, forcing to default"); @@ -1681,7 +2029,7 @@ print \" \\@INC:\\n @INC\\n\";"); CvPADLIST(PL_compcv) = pad_new(0); #ifdef USE_5005THREADS CvOWNER(PL_compcv) = 0; - New(666, CvMUTEXP(PL_compcv), 1, perl_mutex); + Newx(CvMUTEXP(PL_compcv), 1, perl_mutex); MUTEX_INIT(CvMUTEXP(PL_compcv)); #endif /* USE_5005THREADS */ @@ -1836,6 +2184,8 @@ perl_run(pTHXx) int ret = 0; dJMPENV; + PERL_UNUSED_ARG(my_perl); + oldscope = PL_scopestack_ix; #ifdef VMS VMSISH_HUSHED = 0; @@ -1992,7 +2342,7 @@ set and the variable does not exist then NULL is returned. HV* Perl_get_hv(pTHX_ const char *name, I32 create) { - GV* gv = gv_fetchpv(name, create, SVt_PVHV); + GV* const gv = gv_fetchpv(name, create, SVt_PVHV); if (create) return GvHVn(gv); if (gv) @@ -2235,6 +2585,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; } @@ -2406,11 +2759,8 @@ Perl_require_pv(pTHX_ const char *pv) dSP; PUSHSTACKi(PERLSI_REQUIRE); PUTBACK; - sv = sv_newmortal(); - sv_setpv(sv, "require '"); - sv_catpv(sv, pv); - sv_catpv(sv, "'"); - eval_sv(sv, G_DISCARD); + sv = Perl_newSVpvf(aTHX_ "require q%c%s%c", 0, pv, 0); + eval_sv(sv_2mortal(sv), G_DISCARD); SPAGAIN; POPSTACK; } @@ -2630,12 +2980,10 @@ Perl_moreswitches(pTHX_ char *s) sv_catpv(sv, start); else { sv_catpvn(sv, start, s-start); - sv_catpv(sv, " split(/,/,q{"); - sv_catpv(sv, ++s); - sv_catpv(sv, "})"); + Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0); } s += strlen(s); - my_setenv("PERL5DB", SvPV(sv, PL_na)); + my_setenv("PERL5DB", SvPV_nolen_const(sv)); } if (!PL_perldb) { PL_perldb = PERLDB_ALL; @@ -2654,15 +3002,13 @@ 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': usage(PL_origargv[0]); my_exit(0); case 'i': - if (PL_inplace) - Safefree(PL_inplace); + Safefree(PL_inplace); #if defined(__CYGWIN__) /* do backup extension automagically */ if (*(s+1) == '\0') { PL_inplace = savepv(".bak"); @@ -2670,8 +3016,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. */ @@ -2741,9 +3087,7 @@ Perl_moreswitches(pTHX_ char *s) 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); + Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0); s+=strlen(s); } else if (*s != '\0') { @@ -2762,8 +3106,10 @@ Perl_moreswitches(pTHX_ char *s) SV *sv; const char *use = "use "; /* -M-foo == 'no foo' */ - if (*s == '-') { use = "no "; ++s; } - sv = newSVpv(use,0); + /* Leading space on " no " is deliberate, to make both + possibilities the same length. */ + if (*s == '-') { use = " no "; ++s; } + sv = newSVpvn(use,4); start = s; /* We allow -M'Module qw(Foo Bar)' */ while(isALNUM(*s) || *s==':') ++s; @@ -2831,13 +3177,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", @@ -3078,6 +3424,9 @@ S_init_main_stash(pTHX) PL_replgv = gv_fetchpv("\022", TRUE, SVt_PV); /* ^R */ GvMULTI_on(PL_replgv); (void)Perl_form(aTHX_ "%240s",""); /* Preallocate temp - for immediate signals. */ +#ifdef PERL_DONT_CREATE_GVSV + gv_SVadd(PL_errgv); +#endif sv_grow(ERRSV, 240); /* Preallocate - for immediate signals. */ sv_setpvn(ERRSV, "", 0); PL_curstash = PL_defstash; @@ -3842,7 +4191,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))) ; } @@ -4008,22 +4356,22 @@ Perl_init_stacks(pTHX) PL_stack_sp = PL_stack_base; PL_stack_max = PL_stack_base + AvMAX(PL_curstack); - New(50,PL_tmps_stack,REASONABLE(128),SV*); + Newx(PL_tmps_stack,REASONABLE(128),SV*); PL_tmps_floor = -1; PL_tmps_ix = -1; PL_tmps_max = REASONABLE(128); - New(54,PL_markstack,REASONABLE(32),I32); + Newx(PL_markstack,REASONABLE(32),I32); PL_markstack_ptr = PL_markstack; PL_markstack_max = PL_markstack + REASONABLE(32); SET_MARK_OFFSET; - New(54,PL_scopestack,REASONABLE(32),I32); + Newx(PL_scopestack,REASONABLE(32),I32); PL_scopestack_ix = 0; PL_scopestack_max = REASONABLE(32); - New(54,PL_savestack,REASONABLE(128),ANY); + Newx(PL_savestack,REASONABLE(128),ANY); PL_savestack_ix = 0; PL_savestack_max = REASONABLE(128); } @@ -4096,18 +4444,17 @@ S_init_predump_symbols(pTHX) PL_statname = NEWSV(66,0); /* last filename we did stat on */ - if (PL_osname) - Safefree(PL_osname); + Safefree(PL_osname); PL_osname = savepv(OSNAME); } void Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) { - char *s; argc--,argv++; /* skip name of script */ if (PL_doswitches) { for (; argc > 0 && **argv == '-'; argc--,argv++) { + char *s; if (!argv[0][1]) break; if (argv[0][1] == '-' && !argv[0][2]) { @@ -4127,7 +4474,7 @@ Perl_init_argv_symbols(pTHX_ register int argc, register char **argv) (void)gv_AVadd(PL_argvgv); av_clear(GvAVn(PL_argvgv)); for (; argc > 0; argc--,argv++) { - SV *sv = newSVpv(argv[0],0); + SV * const sv = newSVpv(argv[0],0); av_push(GvAVn(PL_argvgv),sv); if (!(PL_unicode & PERL_UNICODE_LOCALE_FLAG) || PL_utf8locale) { if (PL_unicode & PERL_UNICODE_ARGV_FLAG) @@ -4447,11 +4794,11 @@ S_incpush(pTHX_ const char *dir, bool addsubdirs, bool addoldvers, bool usesep, * The intent is that /usr/local/bin/perl and .../../lib/perl5 * generates /usr/local/lib/perl5 */ - char *libpath = SvPVX(libdir); + const char *libpath = SvPVX(libdir); STRLEN libpath_len = SvCUR(libdir); if (libpath_len >= 4 && memEQ (libpath, ".../", 4)) { /* Game on! */ - SV *caret_X = get_sv("\030", 0); + SV * const caret_X = get_sv("\030", 0); /* Going to use the SV just as a scratch buffer holding a C string: */ SV *prefix_sv; @@ -4607,7 +4954,7 @@ S_init_main_thread(pTHX) #endif XPV *xpv; - Newz(53, thr, 1, struct perl_thread); + Newxz(thr, 1, struct perl_thread); PL_curcop = &PL_compiling; thr->interp = PERL_GET_INTERP; thr->cvcache = newHV(); @@ -4617,8 +4964,8 @@ S_init_main_thread(pTHX) thr->flags = THRf_R_JOINABLE; MUTEX_INIT(&thr->mutex); /* Handcraft thrsv similarly to mess_sv */ - New(53, PL_thrsv, 1, SV); - Newz(53, xpv, 1, XPV); + Newx(PL_thrsv, 1, SV); + Newxz(xpv, 1, XPV); SvFLAGS(PL_thrsv) = SVt_PV; SvANY(PL_thrsv) = (void*)xpv; SvREFCNT(PL_thrsv) = 1 << 30; /* practically infinite */ @@ -4845,17 +5192,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) { - const 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_const(PL_e_script); - nl = strchr(p, '\n'); nl = (nl) ? nl+1 : SvEND(PL_e_script); if (nl-p == 0) { filter_del(read_e_script);