[svn:ponie] rev 291 - in trunk/perl: . ext/Socket/t t/op
[email protected] 24 Jun 2005 15:13:22 -0000
| Newsgroups | perl.ponie.changes |
|---|---|
| Message-ID | <[email protected]> |
Author: nicholas
Date: Fri Jun 24 08:13:22 2005
New Revision: 291
Modified:
trunk/perl/embed.fnc
trunk/perl/embed.h
trunk/perl/embedvar.h
trunk/perl/ext/Socket/t/socketpair.t
trunk/perl/intrpvar.h
trunk/perl/perl.c
trunk/perl/perlapi.h
trunk/perl/proto.h
trunk/perl/sv.c
trunk/perl/t/op/alarm.t
Log:
Merge 24940 and 24976 from blead (DEBUG_LEAKING_SCALARS_FORK_DUMP)
Modified: trunk/perl/embed.fnc
==============================================================================
--- trunk/perl/embed.fnc (original)
+++ trunk/perl/embed.fnc Fri Jun 24 08:13:22 2005
@@ -1436,4 +1436,8 @@ dp |bool |is_gv_magical_sv|SV *name|U32
Apd |char* |savesvpv |SV* sv
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+p |void |dump_sv_child |SV *sv
+#endif
+
END_EXTERN_C
Modified: trunk/perl/embed.h
==============================================================================
--- trunk/perl/embed.h (original)
+++ trunk/perl/embed.h Fri Jun 24 08:13:22 2005
@@ -2139,6 +2139,11 @@
#define is_gv_magical_sv Perl_is_gv_magical_sv
#endif
#define savesvpv Perl_savesvpv
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+#ifdef PERL_CORE
+#define dump_sv_child Perl_dump_sv_child
+#endif
+#endif
#define ck_anoncode Perl_ck_anoncode
#define ck_bitop Perl_ck_bitop
#define ck_concat Perl_ck_concat
@@ -4616,6 +4621,11 @@
#define is_gv_magical_sv(a,b) Perl_is_gv_magical_sv(aTHX_ a,b)
#endif
#define savesvpv(a) Perl_savesvpv(aTHX_ a)
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+#ifdef PERL_CORE
+#define dump_sv_child(a) Perl_dump_sv_child(aTHX_ a)
+#endif
+#endif
#define ck_anoncode(a) Perl_ck_anoncode(aTHX_ a)
#define ck_bitop(a) Perl_ck_bitop(aTHX_ a)
#define ck_concat(a) Perl_ck_concat(aTHX_ a)
Modified: trunk/perl/embedvar.h
==============================================================================
--- trunk/perl/embedvar.h (original)
+++ trunk/perl/embedvar.h Fri Jun 24 08:13:22 2005
@@ -228,6 +228,7 @@
#define PL_doextract (vTHX->Idoextract)
#define PL_doswitches (vTHX->Idoswitches)
#define PL_dowarn (vTHX->Idowarn)
+#define PL_dumper_fd (vTHX->Idumper_fd)
#define PL_e_script (vTHX->Ie_script)
#define PL_egid (vTHX->Iegid)
#define PL_encoding (vTHX->Iencoding)
@@ -533,6 +534,7 @@
#define PL_Idoextract PL_doextract
#define PL_Idoswitches PL_doswitches
#define PL_Idowarn PL_dowarn
+#define PL_Idumper_fd PL_dumper_fd
#define PL_Ie_script PL_e_script
#define PL_Iegid PL_egid
#define PL_Iencoding PL_encoding
Modified: trunk/perl/ext/Socket/t/socketpair.t
==============================================================================
--- trunk/perl/ext/Socket/t/socketpair.t (original)
+++ trunk/perl/ext/Socket/t/socketpair.t Fri Jun 24 08:13:22 2005
@@ -211,8 +211,10 @@ ok (shutdown(LEFT, 1), "shutdown left fo
# eof uses buffering. eof is indicated by a sysread of zero.
# but for a datagram socket there's no way it can know nothing will ever be
# sent
+TODO: {
SKIP: {
skip "$^O does length 0 udp reads", 2 if ($^O eq 'os390');
+ todo_skip ("FreeBSD hangs forever for some reason - FIXME", 2) if $^O eq 'freebsd';
my $alarmed = 0;
local $SIG{ALRM} = sub { $alarmed = 1; };
@@ -223,7 +225,7 @@ SKIP: {
"read on right should be interrupted");
is ($alarmed, 1, "alarm should have fired");
}
-
+}
alarm 30;
#ok (eof RIGHT, "right is at EOF");
Modified: trunk/perl/intrpvar.h
==============================================================================
--- trunk/perl/intrpvar.h (original)
+++ trunk/perl/intrpvar.h Fri Jun 24 08:13:22 2005
@@ -543,6 +543,11 @@ PERLVARI(Isuidscript, int, -1) /* fd for
PERLVAR(IParrot, Parrot_Interp)
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+/* File descriptor to talk to the child which dumps scalars. */
+PERLVARI(Idumper_fd, int, -1)
+#endif
+
/* New variables must be added to the very end, before this comment,
* for binary compatibility (the offsets of the old members must not change).
* (Don't forget to add your variable also to perl_clone()!)
Modified: trunk/perl/perl.c
==============================================================================
--- trunk/perl/perl.c (original)
+++ trunk/perl/perl.c Fri Jun 24 08:13:22 2005
@@ -94,6 +94,12 @@ char *nw_get_sitelib(const char *pl);
#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
@@ -447,6 +453,48 @@ Perl_nothreadhook(pTHX)
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
@@ -489,6 +537,9 @@ perl_destruct(pTHXx)
{
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;
@@ -526,6 +577,66 @@ perl_destruct(pTHXx)
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) {
+ int sock = fd[1];
+ /* We are the child */
+ close(fd[0]);
+
+ 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 */
@@ -1001,10 +1112,31 @@ perl_destruct(pTHXx)
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;
Modified: trunk/perl/perlapi.h
==============================================================================
--- trunk/perl/perlapi.h (original)
+++ trunk/perl/perlapi.h Fri Jun 24 08:13:22 2005
@@ -221,6 +221,8 @@ END_EXTERN_C
#define PL_doswitches (*Perl_Idoswitches_ptr(aTHX))
#undef PL_dowarn
#define PL_dowarn (*Perl_Idowarn_ptr(aTHX))
+#undef PL_dumper_fd
+#define PL_dumper_fd (*Perl_Idumper_fd_ptr(aTHX))
#undef PL_e_script
#define PL_e_script (*Perl_Ie_script_ptr(aTHX))
#undef PL_egid
Modified: trunk/perl/proto.h
==============================================================================
--- trunk/perl/proto.h (original)
+++ trunk/perl/proto.h Fri Jun 24 08:13:22 2005
@@ -1377,4 +1377,8 @@ PERL_CALLCONV bool Perl_is_gv_magical_sv
PERL_CALLCONV char* Perl_savesvpv(pTHX_ SV* sv);
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+PERL_CALLCONV void Perl_dump_sv_child(pTHX_ SV *sv);
+#endif
+
END_EXTERN_C
Modified: trunk/perl/sv.c
==============================================================================
--- trunk/perl/sv.c (original)
+++ trunk/perl/sv.c Fri Jun 24 08:13:22 2005
@@ -4922,10 +4922,14 @@ Perl_sv_free(pTHX_ SV *sv)
SvREFCNT_set(sv, (~(U32)0)/2);
return;
}
- if (ckWARN_d(WARN_INTERNAL))
+ if (ckWARN_d(WARN_INTERNAL)) {
Perl_warner(aTHX_ packWARN(WARN_INTERNAL),
"Attempt to free unreferenced scalar: SV 0x%"UVxf
pTHX__FORMAT, PTR2UV(sv) pTHX__VALUE);
+#ifdef DEBUG_LEAKING_SCALARS_FORK_DUMP
+ Perl_dump_sv_child(aTHX_ sv);
+#endif
+ }
return;
}
/* --SvREFCNT(sv) becomes: */
Modified: trunk/perl/t/op/alarm.t
==============================================================================
--- trunk/perl/t/op/alarm.t (original)
+++ trunk/perl/t/op/alarm.t Fri Jun 24 08:13:22 2005
@@ -45,6 +45,7 @@ $diff = time - $start_time;
is( $@, "ALARM!\n", 'alarm w/$SIG{ALRM} vs system()' );
{
+ local $TODO = "system() blocks alarm on $^O - FIXME" if $^O eq 'freebsd';
local $TODO = "Why does system() block alarm() on $^O?"
if $^O eq 'VMS' || $^O eq'MacOS' || $^O eq 'dos';
ok( abs($diff - 3) <= 1, " right time (waited $diff secs for 3-sec alarm)" );