From: Nicholas Clark <nick@ccl4.org>
Date: Sun, 26 Jun 2005 22:19:22 +0000 (+0000)
Subject: Tweak the child dump socket protocol to return error messages to the
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=808ad2d056cb45de9ecfc820f8a60d1c7ec74e62;p=p5sagit%2Fp5-mst-13.2.git

Tweak the child dump socket protocol to return error messages to the
parent so that it can display what went wrong.

p4raw-id: //depot/perl@24986
---

diff --git a/perl.c b/perl.c
index 6e04e4b..765b7ce 100644
--- a/perl.c
+++ b/perl.c
@@ -405,11 +405,12 @@ 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);
-    SV *target;
     union control_un control;
     struct msghdr msg;
-    struct iovec vec[1];
+    struct iovec vec[2];
     struct cmsghdr *cmptr;
+    int returned_errno;
+    unsigned char buffer[256];
 
     if(sock == -1 || debug_fd == -1)
 	return;
@@ -428,7 +429,7 @@ Perl_dump_sv_child(pTHX_ SV *sv)
     msg.msg_name = NULL;
     msg.msg_namelen = 0;
     msg.msg_iov = vec;
-    msg.msg_iovlen = sizeof(vec)/sizeof(vec[0]);
+    msg.msg_iovlen = 1;
 
     cmptr = CMSG_FIRSTHDR(&msg);
     cmptr->cmsg_len = CMSG_LEN(sizeof(int));
@@ -449,20 +450,48 @@ Perl_dump_sv_child(pTHX_ SV *sv)
 	abort();
     }
 
-    got = read(sock, &target, sizeof(target));
+    /* 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(target)) {
+    if(got < sizeof(returned_errno) + 1) {
 	perror("Debug leaking scalars parent short read");
+	PerlIO_flush(PerlIO_stderr());
 	abort();
     }
 
-    if (target != sv) {
-	perror("Debug leaking scalars parent target != sv");
-	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
@@ -542,10 +571,12 @@ perl_destruct(pTHXx)
 	}
 	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]);
 
@@ -563,8 +594,8 @@ perl_destruct(pTHXx)
 
 	    f = sysconf(_SC_OPEN_MAX);
 	    if(f < 0) {
-		perror("Debug leaking scalars sysconf failed");
-		abort();
+		where = "sysconf failed";
+		goto abort;
 	    }
 	    while (f--) {
 		if (f == sock)
@@ -597,46 +628,75 @@ perl_destruct(pTHXx)
 		if(got == 0)
 		    break;
 		if(got < 0) {
-		    /*perror("Debug leaking scalars child recv failed");*/
-		    _exit(1);
+		    where = "recv failed";
+		    goto abort;
 		}
 		if(got < sizeof(target)) {
-		    /*perror("Debug leaking scalars child short recv");*/
-		    _exit(2);
+		    where = "short recv";
+		    goto abort;
 		}
 
-		if(!(cmptr = CMSG_FIRSTHDR(&msg)))
-		    _exit(3);
-		if(cmptr->cmsg_len != CMSG_LEN(sizeof(int)))
-		    _exit(4);
-		if(cmptr->cmsg_level != SOL_SOCKET)
-		    _exit(5);
-		if(cmptr->cmsg_type != SCM_RIGHTS)
-		    _exit(6);
+		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)
-		    dup2(got_fd, debug_fd);
+		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, &target, sizeof(target));
+		got = write(sock, &success, sizeof(success));
 
 		if(got < 0) {
-		    perror("Debug leaking scalars child write failed");
-		    PerlIO_flush(Perl_debug_log);
-		    _exit(7);
+		    where = "write failed";
+		    goto abort;
 		}
-		if(got < sizeof(target)) {
-		    perror("Debug leaking scalars child short write");
-		    _exit(8);
+		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];