#include <unistd.h>
#endif
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+# ifdef I_SYS_WAIT
+# include <sys/wait.h>
+# endif
+#endif
+
#ifdef __BEOS__
# define HZ 1000000
#endif
return 0;
}
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+void
+Perl_dump_sv_child(pTHX_ SV *sv)
+{
+ ssize_t got;
+ int sock = PL_dumper_fd;
+ SV *target;
+
+ if(sock == -1)
+ return;
+
+ PerlIO_flush(Perl_debug_log);
+
+ got = write(sock, &sv, sizeof(sv));
+
+ if(got < 0) {
+ perror("Debug leaking scalars parent write failed");
+ abort();
+ }
+ if(got < sizeof(target)) {
+ perror("Debug leaking scalars parent short write");
+ abort();
+ }
+
+ got = read(sock, &target, sizeof(target));
+
+ if(got < 0) {
+ perror("Debug leaking scalars parent read failed");
+ abort();
+ }
+ if(got < sizeof(target)) {
+ perror("Debug leaking scalars parent short read");
+ abort();
+ }
+
+ if (target != sv) {
+ perror("Debug leaking scalars parent target != sv");
+ abort();
+ }
+}
+#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
/* wait for all pseudo-forked children to finish */
PERL_WAIT_FOR_CHILDREN;
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;
+
+ 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. */
+
+ f = sysconf(_SC_OPEN_MAX);
+ if(f < 0) {
+ perror("Debug leaking scalars sysconf failed");
+ 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));
+
+ if(got == 0)
+ break;
+ if(got < 0) {
+ perror("Debug leaking scalars child read failed");
+ abort();
+ }
+ if(got < sizeof(target)) {
+ perror("Debug leaking scalars child short read");
+ abort();
+ }
+ sv_dump(target);
+ PerlIO_flush(Perl_debug_log);
+
+ /* Write something back as synchronisation. */
+ got = write(sock, &target, sizeof(target));
+
+ if(got < 0) {
+ perror("Debug leaking scalars child write failed");
+ abort();
+ }
+ if(got < sizeof(target)) {
+ perror("Debug leaking scalars child short write");
+ abort();
+ }
+ }
+ _exit(0);
+ }
+ 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_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;
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 *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;
"-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)",
"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':
}
#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. */
(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",
while (isDIGIT(s2[-1]) || s2[-1] == '-' || s2[-1] == '.'
|| s2[-1] == '_') s2--;
if (strnEQ(s2-4,"perl",4))
- /*SUPPRESS 530*/
while ((s = moreswitches(s)))
;
}