1package Net::IMAP::Simple::PipeSocket; 2 3use strict; 4use warnings; 5use Carp; 6use IPC::Open3; 7use IO::Select; 8use Symbol 'gensym'; 9use base 'Tie::Handle'; 10 11sub new { 12 my $class = shift; 13 my %args = @_; 14 15 croak "command (e.g. 'ssh hostname dovecot') argument required" unless $args{cmd}; 16 17 open my $fake, "+>", undef or die "initernal error dealing with blarg: $!"; ## no critic 18 19 my($wtr, $rdr, $err); $err = gensym; 20 my $pid = eval { open3($wtr, $rdr, $err, $args{cmd}) } or croak $@; 21 my $sel = IO::Select->new($err); 22 23 # my $orig = select $wtr; $|=1; 24 # select $rdr; $|=1; 25 # select $orig; 26 27 my $this = tie *{$fake}, $class, 28 (%args, pid=>$pid, wtr=>$wtr, rdr=>$rdr, err=>$err, sel=>$sel, ) 29 or croak $!; 30 31 return $fake; 32} 33 34sub UNTIE { return $_[0]->_waitpid } 35sub DESTROY { return $_[0]->_waitpid } 36 37sub FILENO { 38 my $this = shift; 39 my $rdr = $this->{rdr}; 40 41 # do we mean rdr or wtr? meh? 42 return fileno($rdr); # probably need this for select() on the read handle 43} 44 45sub TIEHANDLE { 46 my $class = shift; 47 my $this = bless {@_}, $class; 48 49 return $this; 50} 51 52sub _chkerr { 53 my $this = shift; 54 my $sel = $this->{sel}; 55 56 while( my @rdy = $sel->can_read(0) ) { 57 for my $fh (@rdy) { 58 if( eof($fh) ) { 59 $sel->remove($fh); 60 next; 61 } 62 my $line = <$fh>; 63 warn "PIPE ERR: $line"; 64 } 65 } 66 67 return 68} 69 70sub PRINT { 71 my $this = shift; 72 my $wtr = $this->{wtr}; 73 74 $this->_chkerr; 75 return print $wtr @_; 76} 77 78sub READLINE { 79 my $this = shift; 80 my $rdr = $this->{rdr}; 81 82 $this->_chkerr; 83 my $line = <$rdr>; 84 return $line; 85} 86 87sub _waitpid { 88 my $this = shift; 89 90 if( my $pid = delete $this->{pid} ) { 91 for my $key (qw(wtr rdr err)) { 92 close delete $this->{$key} if exists $this->{$key}; 93 } 94 95 kill 1, $pid; 96 # doesn't really matter if this works... we hung up all the 97 # filehandles, so ... it's probably dead anyway. 98 99 waitpid( $pid, 0 ); 100 my $child_exit_status = $? >> 8; 101 return $child_exit_status; 102 } 103 104 return; 105} 106 107sub CLOSE { 108 my $this = shift; 109 my $rdr = $this->{rdr}; 110 my $wtr = $this->{wtr}; 111 112 close $rdr or warn "PIPE ERR (close-r): $!"; 113 close $wtr or warn "PIPE ERR (close-w): $!"; 114 115 return; 116} 117 1181; 119 120__END__ 121 122=head1 NAME 123 124Net::IMAP::Simple::PipeSocket - a little wrapper around IPC-Open3 that feels like a socket 125 126=head1 SYNOPSIS 127 128This module is really just a wrapper around IPC-Open3 that can be dropped in 129place of a socket handle. The L<Net::IMAP::Simple> code assumes the socket is 130always a socket and is never a pipe and re-writing it all would be horrible. 131 132This abstraction is used only for that purpose. 133