#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) {
# endif
if ((long) PL_mmap_page_size < 0) {
if (errno) {
- SV *error = ERRSV;
+ SV * const error = ERRSV;
(void) SvUPGRADE(error, SVt_PV);
Perl_croak(aTHX_ "panic: sysconf: %s", SvPV_nolen_const(error));
}
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;
if (CALL_FPTR(PL_threadhook)(aTHX)) {
/* Threads hook has vetoed further cleanup */
- return STATUS_NATIVE_EXPORT;
+ return STATUS_EXIT;
}
+#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;
*/
sv_clean_objs();
PL_sv_objcount = 0;
+ if (PL_defoutgv && !SvREFCNT(PL_defoutgv))
+ PL_defoutgv = Nullgv; /* may have been freed */
}
/* unhook hooks which will soon be, or use, destroyed data */
#endif
/* The exit() function will do everything that needs doing. */
- return STATUS_NATIVE_EXPORT;
+ return STATUS_EXIT;
}
/* jettison our possibly duplicated environment */
{
/* 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 ** const array = HvARRAY(PL_strtab);
+ HE *hent = array[0];
+
for (;;) {
if (hent && ckWARN_d(WARN_INTERNAL)) {
+ HE * const 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);
+ "Unbalanced string table refcount: (%ld) for \"%s\"",
+ (long)(HeVAL(hent) - Nullsv), HeKEY(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);
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;
Safefree(PL_mess_sv);
PL_mess_sv = Nullsv;
}
- return STATUS_NATIVE_EXPORT;
+ return STATUS_EXIT;
}
/*
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
PL_curstash = PL_defstash;
if (PL_checkav)
call_list(oldscope, PL_checkav);
- ret = STATUS_NATIVE_EXPORT;
+ ret = STATUS_EXIT;
break;
case 3:
PerlIO_printf(Perl_error_log, "panic: top_env\n");
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:");
+ Perl_sv_catpv(aTHX_ opts_prog,"\" Compile-time options:"
# ifdef DEBUGGING
- sv_catpv(PL_Sv," DEBUGGING");
+ " DEBUGGING"
+# endif
+# ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ " DEBUG_LEAKING_SCALARS_FORK_DUMP"
+# endif
+# ifdef FAKE_THREADS
+ " FAKE_THREADS"
# endif
# ifdef MULTIPLICITY
- sv_catpv(PL_Sv," MULTIPLICITY");
+ " MULTIPLICITY"
+# endif
+# ifdef MYMALLOC
+ " MYMALLOC"
+# endif
+# ifdef PERL_DONT_CREATE_GVSV
+ " PERL_DONT_CREATE_GVSV"
+# endif
+# ifdef PERL_GLOBAL_STRUCT
+ " PERL_GLOBAL_STRUCT"
+# endif
+# ifdef PERL_IMPLICIT_CONTEXT
+ " PERL_IMPLICIT_CONTEXT"
+# endif
+# ifdef PERL_IMPLICIT_SYS
+ " PERL_IMPLICIT_SYS"
+# endif
+# ifdef PERL_MALLOC_WRAP
+ " PERL_MALLOC_WRAP"
+# endif
+# ifdef PERL_NEED_APPCTX
+ " PERL_NEED_APPCTX"
+# endif
+# ifdef PERL_NEED_TIMESBASE
+ " PERL_NEED_TIMESBASE"
+# endif
+# ifdef PERL_OLD_COPY_ON_WRITE
+ " PERL_OLD_COPY_ON_WRITE"
+# endif
+# ifdef PERL_USE_SAFE_PUTENV
+ " PERL_USE_SAFE_PUTENV"
+# endif
+# ifdef PL_OP_SLAB_ALLOC
+ " PL_OP_SLAB_ALLOC"
+# endif
+# ifdef THREADS_HAVE_PIDS
+ " THREADS_HAVE_PIDS"
# endif
# ifdef USE_5005THREADS
- sv_catpv(PL_Sv," USE_5005THREADS");
+ " USE_5005THREADS"
# endif
-# ifdef USE_ITHREADS
- sv_catpv(PL_Sv," USE_ITHREADS");
+# ifdef USE_64_BIT_ALL
+ " USE_64_BIT_ALL"
# endif
# ifdef USE_64_BIT_INT
- sv_catpv(PL_Sv," USE_64_BIT_INT");
+ " USE_64_BIT_INT"
# endif
-# ifdef USE_64_BIT_ALL
- sv_catpv(PL_Sv," USE_64_BIT_ALL");
+# ifdef USE_ITHREADS
+ " USE_ITHREADS"
+# endif
+# ifdef USE_LARGE_FILES
+ " USE_LARGE_FILES"
# endif
# ifdef USE_LONG_DOUBLE
- sv_catpv(PL_Sv," USE_LONG_DOUBLE");
+ " USE_LONG_DOUBLE"
# endif
-# ifdef USE_LARGE_FILES
- sv_catpv(PL_Sv," USE_LARGE_FILES");
+# ifdef USE_PERLIO
+ " USE_PERLIO"
# endif
-# ifdef USE_SOCKS
- sv_catpv(PL_Sv," USE_SOCKS");
+# ifdef USE_REENTRANT_API
+ " USE_REENTRANT_API"
+# endif
+# ifdef USE_SFIO
+ " USE_SFIO"
# endif
# ifdef USE_SITECUSTOMIZE
- sv_catpv(PL_Sv," USE_SITECUSTOMIZE");
+ " 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
+ " 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++;
d = s;
if (!*s)
break;
- if (!strchr("DIMUdmtwA", *s))
+ if (!strchr("CDIMUdmtwA", *s))
Perl_croak(aTHX_ "Illegal switch in PERL5OPT: -%c", *s);
while (++s && *s) {
if (isSPACE(*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 */
* or explicitly in some platforms.
* locale.c:Perl_init_i18nl10n() if the environment
* look like the user wants to use UTF-8. */
-#if defined(SYMBIAN)
+#if defined(__SYMBIAN32__)
PL_unicode = PERL_UNICODE_STD_FLAG; /* See PERL_SYMBIAN_CONSOLE_UTF8. */
#endif
if (PL_unicode) {
int ret = 0;
dJMPENV;
+ PERL_UNUSED_ARG(my_perl);
+
oldscope = PL_scopestack_ix;
#ifdef VMS
VMSISH_HUSHED = 0;
if (PerlEnv_getenv("PERL_DEBUG_MSTATS"))
dump_mstats("after execution: ");
#endif
- ret = STATUS_NATIVE_EXPORT;
+ ret = STATUS_EXIT;
break;
case 3:
if (PL_restartop) {
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;
}
for (; isALNUM(**s); (*s)++) ;
}
else if (givehelp) {
- char **p = (char **)usage_msgd;
+ const char *const *p = usage_msgd;
while (*p) PerlIO_printf(PerlIO_stdout(), "%s\n", *p++);
}
# ifdef EBCDIC
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");
PL_preambleav = newAV();
s++;
{
- char *start = s;
- SV *sv = newSVpv("use assertions::activate", 24);
+ char * const start = s;
+ SV * const 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 == '=') {
- 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') {
- Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, s-start, start);
+ Perl_croak(aTHX_ "Can't use '%c' after -A%.*s", *s, (int)(s-start), start);
}
av_push(PL_preambleav, sv);
return 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;
(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",
PerlIO_printf(PerlIO_stdout(),"Built on " __DATE__ " " __TIME__ "\n\n");
wce_hitreturn();
#endif
-#ifdef SYMBIAN
+#ifdef __SYMBIAN32__
PerlIO_printf(PerlIO_stdout(),
"Symbian port by Nokia, 2004-2005\n");
#endif
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;
#endif /* IAMSUID */
if (!PL_rsfp) {
/* PSz 16 Sep 03 Keep neat error message */
- Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
- CopFILE(PL_curcop), Strerror(errno));
+ if (PL_e_script)
+ Perl_croak(aTHX_ "Can't open "BIT_BUCKET": %s\n", Strerror(errno));
+ else
+ Perl_croak(aTHX_ "Can't open perl script \"%s\": %s\n",
+ CopFILE(PL_curcop), Strerror(errno));
}
}
cmplen = sizeof(fsd.fd_req.path);
if (strnEQ(fsd.fd_req.path, us.f_fname, cmplen) &&
fdst.st_dev == fsd.fd_req.dev) {
- check_okay = 1;
- on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
- on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
- }
+ check_okay = 1;
+ on_nosuid = fsd.fd_req.flags & PERL_MOUNT_NOSUID;
+ on_noexec = fsd.fd_req.flags & PERL_MOUNT_NOEXEC;
}
}
}
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)
if (!PL_tainting) {
#ifndef VMS
s = PerlEnv_getenv("PERL5LIB");
+/*
+ * It isn't possible to delete an environment variable with
+ * PERL_USE_SAFE_PUTENV set unless unsetenv() is also available, so in that
+ * case we treat PERL5LIB as undefined if it has a zero-length value.
+ */
+#if defined(PERL_USE_SAFE_PUTENV) && ! defined(HAS_UNSETENV)
+ if (s && *s != '\0')
+#else
if (s)
+#endif
incpush(s, TRUE, TRUE, TRUE, FALSE);
else
incpush(PerlEnv_getenv("PERLLIB"), FALSE, FALSE, TRUE, FALSE);
#endif /* MACOS_TRADITIONAL */
}
-#if defined(DOSISH) || defined(EPOC) || defined(SYMBIAN)
+#if defined(DOSISH) || defined(EPOC) || defined(__SYMBIAN32__)
# define PERLLIB_SEP ';'
#else
# if defined(VMS)
* 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 */
STATUS_ALL_FAILURE;
break;
default:
- STATUS_NATIVE_SET(status);
+ STATUS_UNIX_EXIT_SET(status);
break;
}
my_exit_jump();
Perl_my_failure_exit(pTHX)
{
#ifdef VMS
- if (vaxc$errno & 1) {
- if (STATUS_NATIVE & 1) /* fortuitiously includes "-1" */
- STATUS_NATIVE_SET(44);
+ /* We have been called to fall on our sword. The desired exit code
+ * should be already set in STATUS_UNIX, but could be shifted over
+ * by 8 bits. STATUS_UNIX_EXIT_SET will handle the cases where a
+ * that code is set.
+ *
+ * If an error code has not been set, then force the issue.
+ */
+ if (MY_POSIX_EXIT) {
+
+ /* In POSIX_EXIT mode follow Perl documentations and use 255 for
+ * the exit code when there isn't an error.
+ */
+
+ if (STATUS_UNIX == 0)
+ STATUS_UNIX_EXIT_SET(255);
+ else {
+ STATUS_UNIX_EXIT_SET(STATUS_UNIX);
+
+ /* The exit code could have been set by $? or vmsish which
+ * means that it may not be fatal. So convert
+ * success/warning codes to fatal.
+ */
+ if ((STATUS_NATIVE & (STS$K_SEVERE|STS$K_ERROR)) == 0)
+ STATUS_UNIX_EXIT_SET(255);
+ }
}
else {
- if (!vaxc$errno) /* unlikely */
- STATUS_NATIVE_SET(44);
- else
- STATUS_NATIVE_SET(vaxc$errno);
+ /* Traditionally Perl on VMS always expects a Fatal Error. */
+ if (vaxc$errno & 1) {
+
+ /* So force success status to failure */
+ if (STATUS_NATIVE & 1)
+ STATUS_ALL_FAILURE;
+ }
+ else {
+ if (!vaxc$errno) {
+ STATUS_UNIX = EINTR; /* In case something cares */
+ STATUS_ALL_FAILURE;
+ }
+ else {
+ int severity;
+ STATUS_NATIVE = vaxc$errno; /* Should already be this */
+
+ /* Encode the severity code */
+ severity = STATUS_NATIVE & STS$M_SEVERITY;
+ STATUS_UNIX = (severity ? severity : 1) << 8;
+
+ /* Perl expects this to be a fatal error */
+ if (severity != STS$K_SEVERE)
+ STATUS_ALL_FAILURE;
+ }
+ }
}
+
#else
int exitstatus;
if (errno & 255)
}
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);
https://perl5.git.perl.org / perl5.git / blobdiff