# ifdef I_SYS_WAIT
# include <sys/wait.h>
# endif
+# ifdef I_SYSUIO
+# include <sys/uio.h>
+# endif
+
+union control_un {
+ struct cmsghdr cm;
+ char control[CMSG_SPACE(sizeof(int))];
+};
+
#endif
#ifdef __BEOS__
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);
{
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);
perl_construct(pTHXx)
{
dVAR;
+ PERL_UNUSED_ARG(my_perl);
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
SvREFCNT(&PL_sv_placeholder) = (~(U32)0)/2;
}
- PL_sighandlerp = Perl_sighandler;
+ PL_sighandlerp = (Sighandler_t) Perl_sighandler;
PL_pidstatus = newHV();
}
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) {
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
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;
}
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]);
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]);
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);
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
}
int ret;
dJMPENV;
+ PERL_UNUSED_VAR(my_perl);
+
#ifdef SETUID_SCRIPTS_ARE_SECURE_NOW
#ifdef IAMSUID
#undef IAMSUID
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);
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);
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++;
# 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");
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 */
int ret = 0;
dJMPENV;
+ PERL_UNUSED_ARG(my_perl);
+
oldscope = PL_scopestack_ix;
#ifdef VMS
VMSISH_HUSHED = 0;
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)));
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)
POPEVAL(cx);
PL_curpm = newpm;
LEAVE;
+ PERL_UNUSED_VAR(newsp);
+ PERL_UNUSED_VAR(gimme);
+ PERL_UNUSED_VAR(optype);
}
JMPENV_POP;
}
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;
}
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;
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");
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') {
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;
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 */
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;
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);
}
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]) {
(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)
* 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;
#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();
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 */
}
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);