#include <unistd.h>
#endif
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+# 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__
# define HZ 1000000
#endif
perl_construct(pTHXx)
{
dVAR;
+ PERL_UNUSED_ARG(my_perl);
#ifdef MULTIPLICITY
init_interp();
PL_perl_destruct_level = 1;
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) {
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
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;
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;
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;
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)) {
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;
{
/* 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)
hent = array[riter];
}
}
+
+ Safefree(array);
+ HvARRAY(PL_strtab) = 0;
+ HvTOTALKEYS(PL_strtab) = 0;
+ HvFILL(PL_strtab) = 0;
}
SvREFCNT_dec(PL_strtab);
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;
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();
{
- char *s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
-
- if (s) {
- int i = atoi(s);
+ const char * const s = PerlEnv_getenv("PERL_HASH_SEED_DEBUG");
- 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) */
* --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
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 MULTIPLICITY
- sv_catpv(PL_Sv," MULTIPLICITY");
+ sv_catpv(opts_prog," MULTIPLICITY");
# 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");
+ sv_catpv(opts_prog," USE_ITHREADS");
# 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");
+ sv_catpv(opts_prog," USE_64_BIT_ALL");
# 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");
+ sv_catpv(opts_prog," USE_LARGE_FILES");
# endif
# ifdef USE_SOCKS
- sv_catpv(PL_Sv," USE_SOCKS");
+ sv_catpv(opts_prog," USE_SOCKS");
# 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");
+ sv_catpv(opts_prog," PERL_IMPLICIT_CONTEXT");
# endif
# ifdef PERL_IMPLICIT_SYS
- sv_catpv(PL_Sv," PERL_IMPLICIT_SYS");
+ sv_catpv(opts_prog," PERL_IMPLICIT_SYS");
# 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++;
int ret = 0;
dJMPENV;
+ PERL_UNUSED_ARG(my_perl);
+
oldscope = PL_scopestack_ix;
#ifdef VMS
VMSISH_HUSHED = 0;
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;
(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",
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_statname = NEWSV(66,0); /* last filename we did stat on */
- if (PL_osname)
- Safefree(PL_osname);
+ Safefree(PL_osname);
PL_osname = savepv(OSNAME);
}
}
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);
projects / p5sagit/p5-mst-13.2.git / blobdiff