X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=perl.c;h=0b21655c46075bf0564f17b9e70a8660057b5b2d;hb=ffd4ff43bd2a65a31e5f3808320b98b9851ba91e;hp=c87be807e153028bd3fc9c11765692443733c71c;hpb=3125a5a42ead64ccadc87f6d7676d933d8d6582c;p=p5sagit%2Fp5-mst-13.2.git diff --git a/perl.c b/perl.c index c87be80..0b21655 100644 --- a/perl.c +++ b/perl.c @@ -96,6 +96,15 @@ char *nw_get_sitelib(const char *pl); # 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__ @@ -156,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); @@ -189,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); @@ -209,6 +218,7 @@ void perl_construct(pTHXx) { dVAR; + PERL_UNUSED_ARG(my_perl); #ifdef MULTIPLICITY init_interp(); PL_perl_destruct_level = 1; @@ -248,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(); } @@ -322,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) { @@ -394,39 +400,95 @@ void Perl_dump_sv_child(pTHX_ SV *sv) { ssize_t got; - int sock = PL_dumper_fd; - SV *target; - - if(sock == -1) + 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); - got = write(sock, &sv, sizeof(sv)); + /* 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 write failed"); + perror("Debug leaking scalars parent sendmsg failed"); abort(); } - if(got < sizeof(target)) { - perror("Debug leaking scalars parent short write"); + if(got < sizeof(sv)) { + perror("Debug leaking scalars parent short sendmsg"); abort(); } - got = read(sock, &target, sizeof(target)); + /* 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(target)) { + if(got < sizeof(returned_errno) + 1) { perror("Debug leaking scalars parent short read"); + PerlIO_flush(PerlIO_stderr()); abort(); } - if (target != sv) { - perror("Debug leaking scalars parent target != sv"); - 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 @@ -449,14 +511,16 @@ perl_destruct(pTHXx) pid_t child; #endif + PERL_UNUSED_ARG(my_perl); + /* wait for all pseudo-forked children to finish */ PERL_WAIT_FOR_CHILDREN; 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; @@ -506,10 +570,12 @@ perl_destruct(pTHXx) } 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]); @@ -517,51 +583,120 @@ perl_destruct(pTHXx) 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 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) { - perror("Debug leaking scalars sysconf failed"); - abort(); + where = "sysconf failed"; + goto abort; } while (f--) { if (f == sock) continue; - if (f == debug_fd) - continue; close(f); } while (1) { SV *target; - ssize_t got = read(sock, &target, sizeof(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) { - perror("Debug leaking scalars child read failed"); - abort(); + where = "recv failed"; + goto abort; } if(got < sizeof(target)) { - perror("Debug leaking scalars child short read"); - abort(); + 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); - /* Write something back as synchronisation. */ - got = write(sock, &target, sizeof(target)); + got = write(sock, &success, sizeof(success)); if(got < 0) { - perror("Debug leaking scalars child write failed"); - abort(); + where = "write failed"; + goto abort; } - if(got < sizeof(target)) { - perror("Debug leaking scalars child short write"); - 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]); @@ -1073,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); @@ -1232,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 } @@ -1256,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 @@ -1273,7 +1409,7 @@ setuid perl scripts securely.\n"); if (!PL_rehash_seed_set) PL_rehash_seed = get_hash_seed(); { - const char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); + const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG"); if (s && (atoi(s) == 1)) PerlIO_printf(Perl_debug_log, "HASH_SEED = %"UVuf"\n", PL_rehash_seed); @@ -1549,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); @@ -1572,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++; @@ -1811,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"); @@ -1839,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 */ @@ -1994,6 +2184,8 @@ perl_run(pTHXx) int ret = 0; dJMPENV; + PERL_UNUSED_ARG(my_perl); + oldscope = PL_scopestack_ix; #ifdef VMS VMSISH_HUSHED = 0; @@ -2046,8 +2238,10 @@ S_run_body(pTHX_ I32 oldscope) if (!PL_restartop) { DEBUG_x(dump_all()); +#ifdef DEBUGGING 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))); @@ -2150,7 +2344,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) @@ -2393,6 +2587,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; } @@ -2564,11 +2761,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; } @@ -2788,12 +2982,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; @@ -2818,8 +3010,7 @@ Perl_moreswitches(pTHX_ char *s) 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"); @@ -2898,9 +3089,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') { @@ -2919,8 +3108,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; @@ -3224,7 +3415,7 @@ S_init_main_stash(pTHX) SvREFCNT_dec(GvHV(gv)); GvHV(gv) = (HV*)SvREFCNT_inc(PL_defstash); SvREADONLY_on(gv); - Perl_hv_name_set(aTHX_ PL_defstash, "main", 4, 0); + hv_name_set(PL_defstash, "main", 4, 0); PL_incgv = gv_HVadd(gv_AVadd(gv_fetchpv("INC",TRUE, SVt_PVAV))); GvMULTI_on(PL_incgv); PL_hintgv = gv_fetchpv("\010",TRUE, SVt_PV); /* ^H */ @@ -3235,6 +3426,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; @@ -4164,22 +4358,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); } @@ -4252,18 +4446,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]) { @@ -4283,7 +4476,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) @@ -4603,11 +4796,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; @@ -4763,7 +4956,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(); @@ -4773,8 +4966,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 */ @@ -5001,17 +5194,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);