#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
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) {
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);
/* free the pointer tables used for cloning */
ptr_table_free(PL_ptr_table);
PL_ptr_table = (PTR_TBL_t*)NULL;
- ptr_table_free(PL_shared_hek_table);
- PL_shared_hek_table = (PTR_TBL_t*)NULL;
#endif
/* free special SVs */
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);
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;
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
register SV *sv;
register char *s;
const char *cddir = Nullch;
+#ifdef USE_SITECUSTOMIZE
bool minus_f = FALSE;
+#endif
PL_fdscript = -1;
PL_suidscript = -1;
break;
case 'f':
+#ifdef USE_SITECUSTOMIZE
minus_f = TRUE;
+#endif
s++;
goto reswitch;
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;
}
* Removed -h because the user already knows that option. Others? */
static const char * const usage_msg[] = {
-"-0[octal] specify record separator (\\0, if no argument)",
-"-A[name] activate all/given assertions",
-"-a autosplit mode with -n or -p (splits $_ into @F)",
-"-C[number/list] enables the listed Unicode features",
-"-c check syntax only (runs BEGIN and CHECK blocks)",
-"-d[:debugger] run program under debugger",
-"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
-"-e program one line of program (several -e's allowed, omit programfile)",
-#ifdef USE_SITECUSTOMIZE
-"-f don't do $sitelib/sitecustomize.pl at startup",
-#endif
-"-F/pattern/ split() pattern for -a switch (//'s are optional)",
-"-i[extension] edit <> files in place (makes backup if extension supplied)",
-"-Idirectory specify @INC/#include directory (several -I's allowed)",
-"-l[octal] enable line ending processing, specifies line terminator",
-"-[mM][-]module execute \"use/no module...\" before executing program",
-"-n assume \"while (<>) { ... }\" loop around program",
-"-p assume loop like -n but print line also, like sed",
-"-P run program through C preprocessor before compilation",
-"-s enable rudimentary parsing for switches after programfile",
-"-S look for programfile using PATH environment variable",
-"-t enable tainting warnings",
-"-T enable tainting checks",
-"-u dump core after parsing program",
-"-U allow unsafe operations",
-"-v print version, subversion (includes VERY IMPORTANT perl info)",
-"-V[:variable] print configuration summary (or a single Config.pm variable)",
-"-w enable many useful warnings (RECOMMENDED)",
-"-W enable all warnings",
-"-x[directory] strip off text before #!perl line and perhaps cd to directory",
-"-X disable all warnings",
+"-0[octal] specify record separator (\\0, if no argument)",
+"-A[mod][=pattern] activate all/given assertions",
+"-a autosplit mode with -n or -p (splits $_ into @F)",
+"-C[number/list] enables the listed Unicode features",
+"-c check syntax only (runs BEGIN and CHECK blocks)",
+"-d[:debugger] run program under debugger",
+"-D[number/list] set debugging flags (argument is a bit mask or alphabets)",
+"-e program one line of program (several -e's allowed, omit programfile)",
+"-f don't do $sitelib/sitecustomize.pl at startup",
+"-F/pattern/ split() pattern for -a switch (//'s are optional)",
+"-i[extension] edit <> files in place (makes backup if extension supplied)",
+"-Idirectory specify @INC/#include directory (several -I's allowed)",
+"-l[octal] enable line ending processing, specifies line terminator",
+"-[mM][-]module execute \"use/no module...\" before executing program",
+"-n assume \"while (<>) { ... }\" loop around program",
+"-p assume loop like -n but print line also, like sed",
+"-P run program through C preprocessor before compilation",
+"-s enable rudimentary parsing for switches after programfile",
+"-S look for programfile using PATH environment variable",
+"-t enable tainting warnings",
+"-T enable tainting checks",
+"-u dump core after parsing program",
+"-U allow unsafe operations",
+"-v print version, subversion (includes VERY IMPORTANT perl info)",
+"-V[:variable] print configuration summary (or a single Config.pm variable)",
+"-w enable many useful warnings (RECOMMENDED)",
+"-W enable all warnings",
+"-x[directory] strip off text before #!perl line and perhaps cd to directory",
+"-X disable all warnings",
"\n",
NULL
};
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;
"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");
}
#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. */
forbid_setid("-A");
if (!PL_preambleav)
PL_preambleav = newAV();
- if (*++s) {
- SV *sv = newSVpv("use assertions::activate split(/,/,q", 0);
- sv_catpvn(sv, "\0", 1); /* Use NUL as q//-delimiter. */
- sv_catpv(sv,s);
- sv_catpvn(sv, "\0)", 2);
- s+=strlen(s);
+ s++;
+ {
+ char *start = s;
+ SV *sv = newSVpv("use assertions::activate", 24);
+ while(isALNUM(*s) || *s == ':') ++s;
+ if (s != start) {
+ sv_catpvn(sv, "::", 2);
+ sv_catpvn(sv, start, s-start);
+ }
+ if (*s == '=') {
+ Perl_sv_catpvf(aTHX_ sv, " split(/,/,q%c%s%c)", 0, ++s, 0);
+ s+=strlen(s);
+ }
+ else if (*s != '\0') {
+ Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start);
+ }
av_push(PL_preambleav, sv);
+ return s;
}
- else
- av_push(PL_preambleav, newSVpvn("use assertions::activate",24));
- return s;
case 'M':
forbid_setid("-M"); /* XXX ? */
/* FALL THROUGH */
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;
DEBUG_P(PerlIO_printf(Perl_debug_log,
"PL_preprocess: scriptname=\"%s\", cpp=\"%s\", sv=\"%s\", CPPMINUS=\"%s\"\n",
- scriptname, SvPVX (cpp), SvPVX (sv), CPPMINUS));
+ scriptname, SvPVX_const (cpp), SvPVX_const (sv),
+ CPPMINUS));
# if defined(MSDOS) || defined(WIN32) || defined(VMS)
quote = "\"";
DEBUG_P(PerlIO_printf(Perl_debug_log,
"PL_preprocess: cmd=\"%s\"\n",
- SvPVX(cmd)));
+ SvPVX_const(cmd)));
- PL_rsfp = PerlProc_popen(SvPVX(cmd), (char *)"r");
+ PL_rsfp = PerlProc_popen((char *)SvPVX_const(cmd), (char *)"r");
SvREFCNT_dec(cmd);
SvREFCNT_dec(cpp);
}
*/
#ifdef DOSUID
- char *s, *s2;
+ const char *s, *s2;
if (PerlLIO_fstat(PerlIO_fileno(PL_rsfp),&PL_statbuf) < 0) /* normal stat is insecure */
Perl_croak(aTHX_ "Can't stat script \"%s\"",PL_origfilename);
if (PL_statbuf.st_mode & (S_ISUID|S_ISGID)) {
I32 len;
- STRLEN n_a;
+ const char *linestr;
#ifdef IAMSUID
if (PL_fdscript < 0 || PL_suidscript != 1)
PL_doswitches = FALSE; /* -s is insecure in suid */
/* PSz 13 Nov 03 But -s was caught elsewhere ... so unsetting it here is useless(?!) */
CopLINE_inc(PL_curcop);
+ linestr = SvPV_nolen_const(PL_linestr);
if (sv_gets(PL_linestr, PL_rsfp, 0) == Nullch ||
- strnNE(SvPV(PL_linestr,n_a),"#!",2) ) /* required even on Sys V */
+ strnNE(linestr,"#!",2) ) /* required even on Sys V */
Perl_croak(aTHX_ "No #! line");
- s = SvPV(PL_linestr,n_a)+2;
+ linestr+=2;
+ s = linestr;
/* PSz 27 Feb 04 */
/* Sanity check on line length */
if (strlen(s) < 1 || strlen(s) > 4000)
while (isSPACE(*s)) s++;
/* Sanity check on buffer end */
while ((*s) && !isSPACE(*s)) s++;
- for (s2 = s; (s2 > SvPV(PL_linestr,n_a)+2 &&
+ for (s2 = s; (s2 > linestr &&
(isDIGIT(s2[-1]) || s2[-1] == '.' || s2[-1] == '_'
|| s2[-1] == '-')); s2--) ;
/* Sanity check on buffer start */
- if ( (s2-4 < SvPV(PL_linestr,n_a)+2 || strnNE(s2-4,"perl",4)) &&
- (s-9 < SvPV(PL_linestr,n_a)+2 || strnNE(s-9,"perl",4)) )
+ if ( (s2-4 < linestr || strnNE(s2-4,"perl",4)) &&
+ (s-9 < linestr || strnNE(s-9,"perl",4)) )
Perl_croak(aTHX_ "Not a perl script");
while (*s == ' ' || *s == '\t') s++;
/*
while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
|| s2[-1] == '_') s2--;
if (strnEQ(s2-4,"perl",4))
- /*SUPPRESS 530*/
while ((s = moreswitches(s)))
;
}
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)
S_incpush_if_exists(pTHX_ SV *dir)
{
Stat_t tmpstatbuf;
- if (PerlLIO_stat(SvPVX(dir), &tmpstatbuf) >= 0 &&
+ if (PerlLIO_stat(SvPVX_const(dir), &tmpstatbuf) >= 0 &&
S_ISDIR(tmpstatbuf.st_mode)) {
av_push(GvAVn(PL_incgv), dir);
dir = NEWSV(0,0);
* 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)
{
- char *p, *nl;
- (void)idx;
- (void)maxlen;
+ const char * const p = SvPVX_const(PL_e_script);
+ const char *nl = strchr(p, '\n');
+
+ PERL_UNUSED_ARG(idx);
+ PERL_UNUSED_ARG(maxlen);
- p = SvPVX(PL_e_script);
- nl = strchr(p, '\n');
nl = (nl) ? nl+1 : SvEND(PL_e_script);
if (nl-p == 0) {
filter_del(read_e_script);