home *** CD-ROM | disk | FTP | other *** search
/ PC World 2005 December (Special) / PCWorld_2005-12_Special_cd.bin / Bezpecnost / lsti / lsti.exe / framework-2.5.exe / Pipe.pm < prev    next >
Text File  |  2005-01-27  |  5KB  |  258 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.123";
  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. =head1 NAME
  162.  
  163. IO::Pipe - supply object methods for pipes
  164.  
  165. =head1 SYNOPSIS
  166.  
  167.     use IO::Pipe;
  168.  
  169.     $pipe = new IO::Pipe;
  170.  
  171.     if($pid = fork()) { # Parent
  172.         $pipe->reader();
  173.  
  174.         while(<$pipe>) {
  175.         ...
  176.         }
  177.  
  178.     }
  179.     elsif(defined $pid) { # Child
  180.         $pipe->writer();
  181.  
  182.         print $pipe ...
  183.     }
  184.  
  185.     or
  186.  
  187.     $pipe = new IO::Pipe;
  188.  
  189.     $pipe->reader(qw(ls -l));
  190.  
  191.     while(<$pipe>) {
  192.         ...
  193.     }
  194.  
  195. =head1 DESCRIPTION
  196.  
  197. C<IO::Pipe> provides an interface to creating pipes between
  198. processes.
  199.  
  200. =head1 CONSTRUCTOR
  201.  
  202. =over 4
  203.  
  204. =item new ( [READER, WRITER] )
  205.  
  206. Creates an C<IO::Pipe>, which is a reference to a newly created symbol
  207. (see the C<Symbol> package). C<IO::Pipe::new> optionally takes two
  208. arguments, which should be objects blessed into C<IO::Handle>, or a
  209. subclass thereof. These two objects will be used for the system call
  210. to C<pipe>. If no arguments are given then method C<handles> is called
  211. on the new C<IO::Pipe> object.
  212.  
  213. These two handles are held in the array part of the GLOB until either
  214. C<reader> or C<writer> is called.
  215.  
  216. =back
  217.  
  218. =head1 METHODS
  219.  
  220. =over 4
  221.  
  222. =item reader ([ARGS])
  223.  
  224. The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
  225. handle at the reading end of the pipe. If C<ARGS> are given then C<fork>
  226. is called and C<ARGS> are passed to exec.
  227.  
  228. =item writer ([ARGS])
  229.  
  230. The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
  231. handle at the writing end of the pipe. If C<ARGS> are given then C<fork>
  232. is called and C<ARGS> are passed to exec.
  233.  
  234. =item handles ()
  235.  
  236. This method is called during construction by C<IO::Pipe::new>
  237. on the newly created C<IO::Pipe> object. It returns an array of two objects
  238. blessed into C<IO::Pipe::End>, or a subclass thereof.
  239.  
  240. =back
  241.  
  242. =head1 SEE ALSO
  243.  
  244. L<IO::Handle>
  245.  
  246. =head1 AUTHOR
  247.  
  248. Graham Barr. Currently maintained by the Perl Porters.  Please report all
  249. bugs to <perl5-porters@perl.org>.
  250.  
  251. =head1 COPYRIGHT
  252.  
  253. Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved.
  254. This program is free software; you can redistribute it and/or
  255. modify it under the same terms as Perl itself.
  256.  
  257. =cut
  258.