home *** CD-ROM | disk | FTP | other *** search
/ PC Welt 2006 November (DVD) / PCWELT_11_2006.ISO / casper / filesystem.squashfs / usr / lib / perl / 5.8.8 / IO / Pipe.pm < prev    next >
Encoding:
Perl POD Document  |  2006-07-07  |  3.3 KB  |  161 lines
  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.  
  7. package IO::Pipe;
  8.  
  9. use 5.006_001;
  10.  
  11. use IO::Handle;
  12. use strict;
  13. our($VERSION);
  14. use Carp;
  15. use Symbol;
  16.  
  17. $VERSION = "1.13";
  18.  
  19. sub new {
  20.     my $type = shift;
  21.     my $class = ref($type) || $type || "IO::Pipe";
  22.     @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]";
  23.  
  24.     my $me = bless gensym(), $class;
  25.  
  26.     my($readfh,$writefh) = @_ ? @_ : $me->handles;
  27.  
  28.     pipe($readfh, $writefh)
  29.     or return undef;
  30.  
  31.     @{*$me} = ($readfh, $writefh);
  32.  
  33.     $me;
  34. }
  35.  
  36. sub handles {
  37.     @_ == 1 or croak 'usage: $pipe->handles()';
  38.     (IO::Pipe::End->new(), IO::Pipe::End->new());
  39. }
  40.  
  41. my $do_spawn = $^O eq 'os2' || $^O eq 'MSWin32';
  42.  
  43. sub _doit {
  44.     my $me = shift;
  45.     my $rw = shift;
  46.  
  47.     my $pid = $do_spawn ? 0 : fork();
  48.  
  49.     if($pid) { # Parent
  50.         return $pid;
  51.     }
  52.     elsif(defined $pid) { # Child or spawn
  53.         my $fh;
  54.         my $io = $rw ? \*STDIN : \*STDOUT;
  55.         my ($mode, $save) = $rw ? "r" : "w";
  56.         if ($do_spawn) {
  57.           require Fcntl;
  58.           $save = IO::Handle->new_from_fd($io, $mode);
  59.       my $handle = shift;
  60.           # Close in child:
  61.       unless ($^O eq 'MSWin32') {
  62.             fcntl($handle, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
  63.       }
  64.           $fh = $rw ? ${*$me}[0] : ${*$me}[1];
  65.         } else {
  66.           shift;
  67.           $fh = $rw ? $me->reader() : $me->writer(); # close the other end
  68.         }
  69.         bless $io, "IO::Handle";
  70.         $io->fdopen($fh, $mode);
  71.     $fh->close;
  72.  
  73.         if ($do_spawn) {
  74.           $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
  75.           my $err = $!;
  76.     
  77.           $io->fdopen($save, $mode);
  78.           $save->close or croak "Cannot close $!";
  79.           croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0;
  80.           return $pid;
  81.         } else {
  82.           exec @_ or
  83.             croak "IO::Pipe: Cannot exec: $!";
  84.         }
  85.     }
  86.     else {
  87.         croak "IO::Pipe: Cannot fork: $!";
  88.     }
  89.  
  90.     # NOT Reached
  91. }
  92.  
  93. sub reader {
  94.     @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )';
  95.     my $me = shift;
  96.  
  97.     return undef
  98.     unless(ref($me) || ref($me = $me->new));
  99.  
  100.     my $fh  = ${*$me}[0];
  101.     my $pid;
  102.     $pid = $me->_doit(0, $fh, @_)
  103.         if(@_);
  104.  
  105.     close ${*$me}[1];
  106.     bless $me, ref($fh);
  107.     *$me = *$fh;          # Alias self to handle
  108.     $me->fdopen($fh->fileno,"r")
  109.     unless defined($me->fileno);
  110.     bless $fh;                  # Really wan't un-bless here
  111.     ${*$me}{'io_pipe_pid'} = $pid
  112.         if defined $pid;
  113.  
  114.     $me;
  115. }
  116.  
  117. sub writer {
  118.     @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )';
  119.     my $me = shift;
  120.  
  121.     return undef
  122.     unless(ref($me) || ref($me = $me->new));
  123.  
  124.     my $fh  = ${*$me}[1];
  125.     my $pid;
  126.     $pid = $me->_doit(1, $fh, @_)
  127.         if(@_);
  128.  
  129.     close ${*$me}[0];
  130.     bless $me, ref($fh);
  131.     *$me = *$fh;          # Alias self to handle
  132.     $me->fdopen($fh->fileno,"w")
  133.     unless defined($me->fileno);
  134.     bless $fh;                  # Really wan't un-bless here
  135.     ${*$me}{'io_pipe_pid'} = $pid
  136.         if defined $pid;
  137.  
  138.     $me;
  139. }
  140.  
  141. package IO::Pipe::End;
  142.  
  143. our(@ISA);
  144.  
  145. @ISA = qw(IO::Handle);
  146.  
  147. sub close {
  148.     my $fh = shift;
  149.     my $r = $fh->SUPER::close(@_);
  150.  
  151.     waitpid(${*$fh}{'io_pipe_pid'},0)
  152.     if(defined ${*$fh}{'io_pipe_pid'});
  153.  
  154.     $r;
  155. }
  156.  
  157. 1;
  158.  
  159. __END__
  160.  
  161.