File Coverage

blib/lib/IO/Pipe.pm
Criterion Covered Total %
statement 79 95 83.1
branch 32 58 55.1
condition 4 14 28.5
subroutine 11 11 100.0
pod 4 4 100.0
total 130 182 71.4


line stmt bran cond sub pod time code
1             # IO::Pipe.pm
2             #
3             # Copyright (c) 1996-8 Graham Barr . All rights reserved.
4             # This program is free software; you can redistribute it and/or
5             # modify it under the same terms as Perl itself.
6              
7             package IO::Pipe;
8              
9 4     4   1952 use 5.008_001;
  4         27  
10              
11 4     4   1372 use IO::Handle;
  4         8  
  4         140  
12 4     4   19 use strict;
  4         5  
  4         59  
13 4     4   15 use Carp;
  4         7  
  4         140  
14 4     4   16 use Symbol;
  4         12  
  4         3227  
15              
16             our $VERSION = "1.49";
17              
18             sub new {
19 8     8 1 3345 my $type = shift;
20 8   50     117 my $class = ref($type) || $type || "IO::Pipe";
21 8 50 33     43 @_ == 0 || @_ == 2 or croak "usage: $class->([READFH, WRITEFH])";
22              
23 8         72 my $me = bless gensym(), $class;
24              
25 8 50       317 my($readfh,$writefh) = @_ ? @_ : $me->handles;
26              
27 8 50       296 pipe($readfh, $writefh)
28             or return undef;
29              
30 8         22 @{*$me} = ($readfh, $writefh);
  8         54  
31              
32 8         75 $me;
33             }
34              
35             sub handles {
36 8 50   8 1 30 @_ == 1 or croak 'usage: $pipe->handles()';
37 8         158 (IO::Pipe::End->new(), IO::Pipe::End->new());
38             }
39              
40             my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
41              
42             sub _doit {
43 5     5   12 my $me = shift;
44 5         10 my $rw = shift;
45              
46 5 50       5563 my $pid = $do_spawn ? 0 : fork();
47              
48 5 100       402 if($pid) { # Parent
    50          
49 3         132 return $pid;
50             }
51             elsif(defined $pid) { # Child or spawn
52 2         39 my $fh;
53 2 100       44 my $io = $rw ? \*STDIN : \*STDOUT;
54 2 100       65 my ($mode, $save) = $rw ? "r" : "w";
55 2 50       30 if ($do_spawn) {
56 0         0 require Fcntl;
57 0         0 $save = IO::Handle->new_from_fd($io, $mode);
58 0         0 my $handle = shift;
59             # Close in child:
60 0 0       0 unless ($^O eq 'MSWin32') {
61 0 0       0 fcntl($handle, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
62             }
63 0 0       0 $fh = $rw ? ${*$me}[0] : ${*$me}[1];
  0         0  
  0         0  
64             } else {
65 2         40 shift;
66 2 100       79 $fh = $rw ? $me->reader() : $me->writer(); # close the other end
67             }
68 2         31 bless $io, "IO::Handle";
69 2         43 $io->fdopen($fh, $mode);
70 2         12 $fh->close;
71              
72 2 50       7 if ($do_spawn) {
73 0         0 $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
  0         0  
74 0         0 my $err = $!;
75            
76 0         0 $io->fdopen($save, $mode);
77 0 0       0 $save->close or croak "Cannot close $!";
78 0 0 0     0 croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0;
79 0         0 return $pid;
80             } else {
81 2 0       0 exec @_ or
82             croak "IO::Pipe: Cannot exec: $!";
83             }
84             }
85             else {
86 0         0 croak "IO::Pipe: Cannot fork: $!";
87             }
88              
89             # NOT Reached
90             }
91              
92             sub reader {
93 5 50   5 1 532 @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )';
94 5         19 my $me = shift;
95              
96             return undef
97 5 50 33     39 unless(ref($me) || ref($me = $me->new));
98              
99 5         7 my $fh = ${*$me}[0];
  5         78  
100 5         8 my $pid;
101 5 100       17 $pid = $me->_doit(0, $fh, @_)
102             if(@_);
103              
104 4         30 close ${*$me}[1];
  4         150  
105 4         159 bless $me, ref($fh);
106 4         175 *$me = *$fh; # Alias self to handle
107 4 50       172 $me->fdopen($fh->fileno,"r")
108             unless defined($me->fileno);
109 4         10 bless $fh; # Really wan't un-bless here
110 4 100       37 ${*$me}{'io_pipe_pid'} = $pid
  2         48  
111             if defined $pid;
112              
113 4         94 $me;
114             }
115              
116             sub writer {
117 5 50   5 1 923 @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )';
118 5         32 my $me = shift;
119              
120             return undef
121 5 50 33     82 unless(ref($me) || ref($me = $me->new));
122              
123 5         11 my $fh = ${*$me}[1];
  5         72  
124 5         15 my $pid;
125 5 100       55 $pid = $me->_doit(1, $fh, @_)
126             if(@_);
127              
128 4         48 close ${*$me}[0];
  4         109  
129 4         123 bless $me, ref($fh);
130 4         101 *$me = *$fh; # Alias self to handle
131 4 50       146 $me->fdopen($fh->fileno,"w")
132             unless defined($me->fileno);
133 4         15 bless $fh; # Really wan't un-bless here
134 4 100       34 ${*$me}{'io_pipe_pid'} = $pid
  1         17  
135             if defined $pid;
136              
137 4         58 $me;
138             }
139              
140             package IO::Pipe::End;
141              
142             our(@ISA);
143              
144             @ISA = qw(IO::Handle);
145              
146             sub close {
147 8     8   561206 my $fh = shift;
148 8         88 my $r = $fh->SUPER::close(@_);
149              
150 3         291769 waitpid(${*$fh}{'io_pipe_pid'},0)
151 8 100       70 if(defined ${*$fh}{'io_pipe_pid'});
  8         102  
152              
153 8         53 $r;
154             }
155              
156             1;
157              
158             __END__