1# IO::Pipe.pm
2#
3# Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. 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
7package IO::Pipe;
8
9use 5.008_001;
10
11use IO::Handle;
12use strict;
13use Carp;
14use Symbol;
15
16our $VERSION = "1.49";
17
18sub new {
19    my $type = shift;
20    my $class = ref($type) || $type || "IO::Pipe";
21    @_ == 0 || @_ == 2 or croak "usage: $class->([READFH, WRITEFH])";
22
23    my $me = bless gensym(), $class;
24
25    my($readfh,$writefh) = @_ ? @_ : $me->handles;
26
27    pipe($readfh, $writefh)
28	or return undef;
29
30    @{*$me} = ($readfh, $writefh);
31
32    $me;
33}
34
35sub handles {
36    @_ == 1 or croak 'usage: $pipe->handles()';
37    (IO::Pipe::End->new(), IO::Pipe::End->new());
38}
39
40my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
41
42sub _doit {
43    my $me = shift;
44    my $rw = shift;
45
46    my $pid = $do_spawn ? 0 : fork();
47
48    if($pid) { # Parent
49        return $pid;
50    }
51    elsif(defined $pid) { # Child or spawn
52        my $fh;
53        my $io = $rw ? \*STDIN : \*STDOUT;
54        my ($mode, $save) = $rw ? "r" : "w";
55        if ($do_spawn) {
56          require Fcntl;
57          $save = IO::Handle->new_from_fd($io, $mode);
58	  my $handle = shift;
59          # Close in child:
60	  unless ($^O eq 'MSWin32') {
61            fcntl($handle, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
62	  }
63          $fh = $rw ? ${*$me}[0] : ${*$me}[1];
64        } else {
65          shift;
66          $fh = $rw ? $me->reader() : $me->writer(); # close the other end
67        }
68        bless $io, "IO::Handle";
69        $io->fdopen($fh, $mode);
70	$fh->close;
71
72        if ($do_spawn) {
73          $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
74          my $err = $!;
75
76          $io->fdopen($save, $mode);
77          $save->close or croak "Cannot close $!";
78          croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0;
79          return $pid;
80        } else {
81          exec @_ or
82            croak "IO::Pipe: Cannot exec: $!";
83        }
84    }
85    else {
86        croak "IO::Pipe: Cannot fork: $!";
87    }
88
89    # NOT Reached
90}
91
92sub reader {
93    @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )';
94    my $me = shift;
95
96    return undef
97	unless(ref($me) || ref($me = $me->new));
98
99    my $fh  = ${*$me}[0];
100    my $pid;
101    $pid = $me->_doit(0, $fh, @_)
102        if(@_);
103
104    close ${*$me}[1];
105    bless $me, ref($fh);
106    *$me = *$fh;          # Alias self to handle
107    $me->fdopen($fh->fileno,"r")
108	unless defined($me->fileno);
109    bless $fh;                  # Really wan't un-bless here
110    ${*$me}{'io_pipe_pid'} = $pid
111        if defined $pid;
112
113    $me;
114}
115
116sub writer {
117    @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )';
118    my $me = shift;
119
120    return undef
121	unless(ref($me) || ref($me = $me->new));
122
123    my $fh  = ${*$me}[1];
124    my $pid;
125    $pid = $me->_doit(1, $fh, @_)
126        if(@_);
127
128    close ${*$me}[0];
129    bless $me, ref($fh);
130    *$me = *$fh;          # Alias self to handle
131    $me->fdopen($fh->fileno,"w")
132	unless defined($me->fileno);
133    bless $fh;                  # Really wan't un-bless here
134    ${*$me}{'io_pipe_pid'} = $pid
135        if defined $pid;
136
137    $me;
138}
139
140package IO::Pipe::End;
141
142our(@ISA);
143
144@ISA = qw(IO::Handle);
145
146sub close {
147    my $fh = shift;
148    my $r = $fh->SUPER::close(@_);
149
150    waitpid(${*$fh}{'io_pipe_pid'},0)
151	if(defined ${*$fh}{'io_pipe_pid'});
152
153    $r;
154}
155
1561;
157
158__END__
159
160=head1 NAME
161
162IO::Pipe - supply object methods for pipes
163
164=head1 SYNOPSIS
165
166	use IO::Pipe;
167
168	$pipe = IO::Pipe->new();
169
170	if($pid = fork()) { # Parent
171	    $pipe->reader();
172
173	    while(<$pipe>) {
174		...
175	    }
176
177	}
178	elsif(defined $pid) { # Child
179	    $pipe->writer();
180
181	    print $pipe ...
182	}
183
184	or
185
186	$pipe = IO::Pipe->new();
187
188	$pipe->reader(qw(ls -l));
189
190	while(<$pipe>) {
191	    ...
192	}
193
194=head1 DESCRIPTION
195
196C<IO::Pipe> provides an interface to creating pipes between
197processes.
198
199=head1 CONSTRUCTOR
200
201=over 4
202
203=item new ( [READER, WRITER] )
204
205Creates an C<IO::Pipe>, which is a reference to a newly created symbol
206(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two
207arguments, which should be objects blessed into C<IO::Handle>, or a
208subclass thereof. These two objects will be used for the system call
209to C<pipe>. If no arguments are given then method C<handles> is called
210on the new C<IO::Pipe> object.
211
212These two handles are held in the array part of the GLOB until either
213C<reader> or C<writer> is called.
214
215=back
216
217=head1 METHODS
218
219=over 4
220
221=item reader ([ARGS])
222
223The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
224handle at the reading end of the pipe. If C<ARGS> are given then C<fork>
225is called and C<ARGS> are passed to exec.
226
227=item writer ([ARGS])
228
229The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
230handle at the writing end of the pipe. If C<ARGS> are given then C<fork>
231is called and C<ARGS> are passed to exec.
232
233=item handles ()
234
235This method is called during construction by C<IO::Pipe::new>
236on the newly created C<IO::Pipe> object. It returns an array of two objects
237blessed into C<IO::Pipe::End>, or a subclass thereof.
238
239=back
240
241=head1 SEE ALSO
242
243L<IO::Handle>
244
245=head1 AUTHOR
246
247Graham Barr. Currently maintained by the Perl Porters.  Please report all
248bugs at L<https://github.com/Perl/perl5/issues>.
249
250=head1 COPYRIGHT
251
252Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
253This program is free software; you can redistribute it and/or
254modify it under the same terms as Perl itself.
255
256=cut
257