Mod_perl breaks IO::Capture module 
Author Message
 Mod_perl breaks IO::Capture module

A user of clp.misc created a module for me that captures STDERR from
external processes and throws it into a variable.  In standard Perl, the
module works perfectly.  The problem arises when I try to run it through
mod_perl.  Apache keeps the child open forever (as if the script never
exited, and was waiting for something).  The reason I am posting is because
I have no idea what might be causing the problem.  The author is now too
busy to help.  I hope someone else can help.  See the module below.

Thanks
Mark

package IO::Capture;
use strict;
use warnings;
use Symbol qw(gensym);

sub new {

       or croak("Usage: IO::Capture->new(\$filehandle)");
   if( ref $filehandle or ref \$filehandle eq "GLOB" ) {
      $filehandle = \*$filehandle; # this is a sort of typecast.
   } else {
      $filehandle = caller() . "::" . $filehandle
          unless $filehandle =~ /::/ or
              $filehandle =~ /^STD(?:IN|OUT|ERR)\z/;
      no strict 'refs';
      $filehandle = \*$filehandle;
   }
   defined(fileno $filehandle)
       or croak("Argument to IO::Capture->new has no fileno()");
   my $save = gensym;
   open $save, ">&".fileno($filehandle)
      or die sprintf("Couldn't dup2(%s,%s): $!\n",
         fileno($save),fileno($filehandle));
   my  ($getresponse, $sendresponse) = (gensym, gensym);
   pipe($getresponse, $sendresponse) or die "pipe: $!";
   my  ($readnew, $writenew) = (gensym, gensym);
   pipe($readnew, $writenew) or die "pipe: $!";
   open( $filehandle, ">&" . fileno($writenew) )
      or die sprintf("Couldn't dup2(%s,%s): $!\n",
         fileno($filehandle),fileno($writenew));
   close($writenew);
   defined( my $pid = fork ) or do {
      my $err = $!;
      unless( open $filehandle, ">&".fileno $save ) {
         my $err2 = $!;
         open STDERR, $^O =~ /win/i ? ">con" : ">/dev/tty"
             if $filehandle == \*STDERR;
         die "fork: $err, dup2: $err2";
      }
      die "fork: $err";
   };
   # readnew, writenew, and sendresponse are automatically closed
   # when we return here in the parent because they go out of scope,
   # resulting in their their refcounts going to 0.
   return bless [$filehandle, $save, $getresponse, $pid], $class
      if $pid;
   close($getresponse); # not used, so close it.
   close($writenew); # MUST close this, or deadlock will occur!
   # MUST close or re-open $filehandle, or deadlock will occur!
   $filehandle == \*STDERR and (
      open STDERR, ">&".fileno $save or
      open STDERR, $^O =~ /win/i ? ">con" : ">/dev/tty"
   ) or close $filehandle;
   close $save; # not used from here on, so close it.
   my ($got, $n) = "";
   1 while $n = sysread $readnew, $got, 4096, length $got;
   die "sysread: $!" unless defined $n;
   print $sendresponse $got or die "print: $!";
   exit;

Quote:
}

sub capture {
   my $self = shift;

   unless( open $fh, ">&" . fileno $saved ) {
      open $fh, $^O =~ /win/i ? ">con" : ">/dev/tty"
         if $fh == \*STDERR;
      die "Couldn't restore filehandle: $!";
   } else { close $saved }
   my ($got, $n) = "";
   while($n = sysread $get, $got, 4096, length $got) {}
   defined($n) or die "sysread: $!";
   if( waitpid $pid, 0 ) {
      warn sprintf "Child exited with code 0x%04X", $? if $?;
   } else { warn "waitpid: $!" }
   return $got;

Quote:
}

# like using autouse.pm but even more lightweight.
sub croak {
   undef &croak;
   require Carp;
   *croak = \&Carp::croak;
   goto &croak;

Quote:
}

1;
__END__
perl -MIO::Capture
   $x = IO::Capture->new(\*STDERR);
   print "now capturing\n";
   warn qq[captured ok\n];
   print "captured text 'captured ok' shouldn't have appeard\n";
   $y = $x->capture;
   print "capture didn't block\n";
   print $y;
   warn "Restored ok\n";
__END__
now capturing
captured text 'captured ok' shouldn't have appeard
capture didn't block
captured ok
Restored ok

perl -MIO::Capture
   $x = IO::Capture->new(\*STDERR);
   print "now capturing\n";
   system(q[perl -e "print STDERR qq[captured ok\n]"]);
   print "captured text 'captured ok' shouldn't have appeard\n";
   $y = $x->capture;
   print "capture didn't block\n";
   print $y;
   warn "Restored ok\n";
__END__
now capturing
captured text 'captured ok' shouldn't have appeard
capture didn't block
captured ok
Restored ok



Thu, 12 Aug 2004 08:16:46 GMT  
 
 [ 1 post ] 

 Relevant Pages 

1. Broken CPAN Module. IO modules no longer compile

2. How do I capture a Broken Pipe Error?

3. capturing lines even with breaks (from specific point in text doc to another)

4. Capturing/Monitoring subprocess IO

5. Module Problems: IO object version 1.19 does not match $IO:: 1.15

6. capturing another programms IO - without buffering

7. IO::Socket broken on win

8. Apache 1.3.17 breaks mod_perl 1.24

9. Timeout in IO::Socket broken?

10. IO::Socket "Broken pipe" crashes script

11. IO::SELECT IS BROKE!

12. Is IO::Socket and Alarm broken?

 

 
Powered by phpBB® Forum Software