From 5bca0e5c44847dd38035c0213c6b171875a5209f Mon Sep 17 00:00:00 2001
From: Rocco Caputo <rcaputo@cpan.org>
Date: Fri, 22 Apr 2005 20:32:11 -0400
Subject: [PATCH] ActiveState Perl + Tk + POE::Wheel::Run + coderefs = Pain.
 ActiveState Perl emulates fork() with iThreads.  Only Perl's core exit() will
 properly "exit" a "process".  Tk overrides exit() with its own XS magic. 
 This seems to kill off the parent "process".  When POE::Wheel::Run is used to
 run subroutines (coderefs) in child processes, it must somehow exit() the
 child process, simulating exec. Under Windows, that's Perl's core exit(),
 which is usurped by Tk, which causes ALL MANNER OF EVIL!  DON'T GO THERE!  WE
 SURE AREN'T!

---
 lib/POE/Wheel/Run.pm                | 55 ++++++++++++++++++-----------
 tests/30_loops/00_base/wheel_run.pm |  8 ++++-
 2 files changed, 41 insertions(+), 22 deletions(-)

diff --git a/lib/POE/Wheel/Run.pm b/lib/POE/Wheel/Run.pm
index 7e8df3a36..82a9e9de6 100644
--- a/lib/POE/Wheel/Run.pm
+++ b/lib/POE/Wheel/Run.pm
@@ -395,7 +395,7 @@ sub new {
     close $stdin_write;
     close $stdout_read;
     close $stderr_read if defined $stderr_read;
-    
+
     # Need to close on Win32 because std handles aren't dup'ed, no
     # harm elsewhere.  Close STDERR later to not influence possible
     # die.
@@ -412,7 +412,8 @@ sub new {
     open( STDOUT, ">&" . fileno($stdout_write) )
       or die "can't redirect stdout in child pid $$: $!";
 
-    # Need to close on Win32 because std handles aren't dup'ed, no harm elsewhere
+    # Need to close on Win32 because std handles aren't dup'ed, no
+    # harm elsewhere
     close STDERR;
 
     # Redirect STDERR to the write end of the stderr pipe.  If the
@@ -432,15 +433,27 @@ sub new {
     close $sem_pipe_write;
 
     if (POE::Kernel::RUNNING_IN_HELL)  {
-	# The Win32 pseudo fork sets up the std handles in the child based on the true win32 handles
-	# For the exec these get remembered, so manipulation of STDIN/OUT/ERR is not enough. Only 
-	# necessary for the exec, as Perl CODE subroutine goes through 0/1/2 which are correct. 
-	# But ofcourse that coderef might invoke exec, so better do it regardless.
-	# HACK: Using Win32::Console as nothing else exposes SetStdHandle
-	Win32::Console::_SetStdHandle(STD_INPUT_HANDLE(),  FdGetOsFHandle(fileno($stdin_read)));
-	Win32::Console::_SetStdHandle(STD_OUTPUT_HANDLE(), FdGetOsFHandle(fileno($stdout_write)));
-	Win32::Console::_SetStdHandle(STD_ERROR_HANDLE(),  FdGetOsFHandle(fileno($stderr_write)));
+      # The Win32 pseudo fork sets up the std handles in the child
+      # based on the true win32 handles For the exec these get
+      # remembered, so manipulation of STDIN/OUT/ERR is not enough.
+      # Only necessary for the exec, as Perl CODE subroutine goes
+      # through 0/1/2 which are correct.  But ofcourse that coderef
+      # might invoke exec, so better do it regardless.
+      # HACK: Using Win32::Console as nothing else exposes SetStdHandle
+      Win32::Console::_SetStdHandle(
+        STD_INPUT_HANDLE(),
+        FdGetOsFHandle(fileno($stdin_read))
+      );
+      Win32::Console::_SetStdHandle(
+        STD_OUTPUT_HANDLE(),
+        FdGetOsFHandle(fileno($stdout_write))
+      );
+      Win32::Console::_SetStdHandle(
+        STD_ERROR_HANDLE(),
+        FdGetOsFHandle(fileno($stderr_write))
+      );
     }
+
     # Exec the program depending on its form.
     if (ref($program) eq 'CODE') {
 
@@ -465,20 +478,20 @@ sub new {
       # Give up with a plain exit if we must.
       # On win32 cannot _exit as it will kill *all* threads, meaning parent too
       unless (POE::Kernel::RUNNING_IN_HELL) {
-	  eval { POSIX::_exit(0);  };
-	  eval { kill KILL => $$;  };
-	  eval { exec("$^X -e 0"); };
+    eval { POSIX::_exit(0);  };
+    eval { kill KILL => $$;  };
+    eval { exec("$^X -e 0"); };
       };
       exit(0);
     } else {
-	if (ref($program) eq 'ARRAY') {
-	  exec(@$program, @$prog_args)
-	    or die "can't exec (@$program) in child pid $$: $!";
-	}
-	else {
-	  exec(join(" ", $program, @$prog_args))
-	    or die "can't exec ($program) in child pid $$: $!";
-	}
+  if (ref($program) eq 'ARRAY') {
+    exec(@$program, @$prog_args)
+      or die "can't exec (@$program) in child pid $$: $!";
+  }
+  else {
+    exec(join(" ", $program, @$prog_args))
+      or die "can't exec ($program) in child pid $$: $!";
+  }
     }
     die "insanity check passed";
   }
diff --git a/tests/30_loops/00_base/wheel_run.pm b/tests/30_loops/00_base/wheel_run.pm
index 6a86f4a13..1de1bc3ee 100644
--- a/tests/30_loops/00_base/wheel_run.pm
+++ b/tests/30_loops/00_base/wheel_run.pm
@@ -231,7 +231,13 @@ my $program =
 
 my $coderef_flush_count = 0;
 
-{ my $program = sub {
+if ($^O eq "MSWin32" and exists $INC{"Tk.pm"}) {
+  ok(23, "SKIP: Wheel::Run + Tk + ActiveState + CODE program = pain");
+  ok(24, "SKIP: Wheel::Run + Tk + ActiveState + CODE program = pain");
+  $coderef_flush_count = 3;
+}
+else {
+  my $program = sub {
     my ($out, $err) = @_;
     local $/ = q(!);
     OUTER: while (1) {