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