File Coverage

blib/lib/Net/IMAP/Simple/PipeSocket.pm
Criterion Covered Total %
statement 21 75 28.0
branch 0 18 0.0
condition n/a
subroutine 7 17 41.1
pod 0 1 0.0
total 28 111 25.2


line stmt bran cond sub pod time code
1             package Net::IMAP::Simple::PipeSocket;
2              
3 20     20   122 use strict;
  20         44  
  20         503  
4 20     20   94 use warnings;
  20         34  
  20         496  
5 20     20   85 use Carp;
  20         37  
  20         1032  
6 20     20   8628 use IPC::Open3;
  20         49068  
  20         927  
7 20     20   128 use IO::Select;
  20         42  
  20         587  
8 20     20   96 use Symbol 'gensym';
  20         39  
  20         626  
9 20     20   100 use base 'Tie::Handle';
  20         35  
  20         9106  
10              
11             sub new {
12 0     0 0   my $class = shift;
13 0           my %args = @_;
14              
15 0 0         croak "command (e.g. 'ssh hostname dovecot') argument required" unless $args{cmd};
16              
17 0 0         open my $fake, "+>", undef or die "initernal error dealing with blarg: $!"; ## no critic
18              
19 0           my($wtr, $rdr, $err); $err = gensym;
  0            
20 0 0         my $pid = eval { open3($wtr, $rdr, $err, $args{cmd}) } or croak $@;
  0            
21 0           my $sel = IO::Select->new($err);
22              
23             # my $orig = select $wtr; $|=1;
24             # select $rdr; $|=1;
25             # select $orig;
26              
27 0 0         my $this = tie *{$fake}, $class,
  0            
28             (%args, pid=>$pid, wtr=>$wtr, rdr=>$rdr, err=>$err, sel=>$sel, )
29             or croak $!;
30              
31 0           return $fake;
32             }
33              
34 0     0     sub UNTIE { return $_[0]->_waitpid }
35 0     0     sub DESTROY { return $_[0]->_waitpid }
36              
37             sub FILENO {
38 0     0     my $this = shift;
39 0           my $rdr = $this->{rdr};
40              
41             # do we mean rdr or wtr? meh?
42 0           return fileno($rdr); # probably need this for select() on the read handle
43             }
44              
45             sub TIEHANDLE {
46 0     0     my $class = shift;
47 0           my $this = bless {@_}, $class;
48              
49 0           return $this;
50             }
51              
52             sub _chkerr {
53 0     0     my $this = shift;
54 0           my $sel = $this->{sel};
55              
56 0           while( my @rdy = $sel->can_read(0) ) {
57 0           for my $fh (@rdy) {
58 0 0         if( eof($fh) ) {
59 0           $sel->remove($fh);
60 0           next;
61             }
62 0           my $line = <$fh>;
63 0           warn "PIPE ERR: $line";
64             }
65             }
66              
67             return
68 0           }
69              
70             sub PRINT {
71 0     0     my $this = shift;
72 0           my $wtr = $this->{wtr};
73              
74 0           $this->_chkerr;
75 0           return print $wtr @_;
76             }
77              
78             sub READLINE {
79 0     0     my $this = shift;
80 0           my $rdr = $this->{rdr};
81              
82 0           $this->_chkerr;
83 0           my $line = <$rdr>;
84 0           return $line;
85             }
86              
87             sub _waitpid {
88 0     0     my $this = shift;
89              
90 0 0         if( my $pid = delete $this->{pid} ) {
91 0           for my $key (qw(wtr rdr err)) {
92 0 0         close delete $this->{$key} if exists $this->{$key};
93             }
94              
95 0           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 0           waitpid( $pid, 0 );
100 0           my $child_exit_status = $? >> 8;
101 0           return $child_exit_status;
102             }
103              
104 0           return;
105             }
106              
107             sub CLOSE {
108 0     0     my $this = shift;
109 0           my $rdr = $this->{rdr};
110 0           my $wtr = $this->{wtr};
111              
112 0 0         close $rdr or warn "PIPE ERR (close-r): $!";
113 0 0         close $wtr or warn "PIPE ERR (close-w): $!";
114              
115 0           return;
116             }
117              
118             1;
119              
120             __END__