| Subject: | tied stderr or stdout break redirection |
This attachment shows how redirection breaks if STDERR is tied.
A quick easy solution would be to put:
untie *STDERR if tied *STDERR;
untie *STDOUT if tied *STDOUT;
in POE::Wheel::Run after the fork.
~$ perl -MPOE -le 'print $POE::VERSION'
0.22
POE::Kernel's run() method was never called.
~$ perl -v
This is perl, v5.6.1 built for i686-linux
Copyright 1987-2001, Larry Wall
Perl may be copied only under the terms of either the Artistic License or the
GNU General Public License, which may be found in the Perl 5 source kit.
Complete documentation for Perl, including FAQ lists, should be found on
this system using `man perl' or `perldoc perl'. If you have access to the
Internet, point your browser at http://www.perl.com/, the Perl Home Page.
~$ uname -a
Linux sbeck.office.gossamer-threads.com 2.4.19-gentoo-r7 #3 Sat Sep 7 21:23:01 PDT 2002 i686 AuthenticAMD
#!/usr/bin/perl
use strict;
use POE qw/Wheel::Run Session/;
tie *STDERR, 'Test::Tie::Handle';
POE::Session->create(
inline_states => {
_start => sub {
my ($kernel, $heap) = @_[KERNEL, HEAP];
my $wheel = POE::Wheel::Run->new(
Program => [ 'sh', '-c', 'echo "My stderr" >/dev/stderr' ],
StderrEvent => 'stderr'
);
print "Wheel ID: ", $wheel->ID, "\n";
print "Wheel PID: ", $wheel->PID, "\n\n";
$heap->{wheel} = $wheel;
},
stderr => sub {
my ($heap, $in, $wheel_id) = @_[HEAP, ARG0, ARG1];
print "Got STDERR\n";
print "STDERR($in)\n";
print "Wheel ID: $wheel_id\n";
print "Wheel PID: ", $heap->{wheel}->PID, "\n\n";
delete $heap->{wheel};
}
},
heap => {
wheel => undef
}
);
$poe_kernel->run;
our $Out;
BEGIN {
package Test::Tie::Handle;
use Tie::Handle;
our @ISA = 'Tie::Handle';
use Carp;
sub TIEHANDLE {
my $class = shift;
my $fh = do { \local *HANDLE};
bless $fh,$class;
$fh->OPEN(@_) if (@_);
return $fh;
}
sub EOF { eof($_[0]) }
sub TELL { tell($_[0]) }
sub FILENO { fileno($_[0]) }
sub SEEK { seek($_[0],$_[1],$_[2]) }
sub CLOSE { close($_[0]) }
sub BINMODE { binmode($_[0]) }
sub OPEN {
$_[0]->CLOSE if defined($_[0]->FILENO);
@_ == 2 ? open($_[0], $_[1]) : open($_[0], $_[1], $_[2]);
}
sub READ { read($_[0],$_[1],$_[2]) }
sub READLINE { my $fh = $_[0]; <$fh> }
sub GETC { getc($_[0]) }
sub WRITE {
my $fh = $_[0];
$Out .= substr($_[1],0,$_[2]);
}
}
END {
if ($Out) {
local $SIG{__WARN__};
warn <<END;
The warings were:
$Out
END
}
}