diff options
Diffstat (limited to 'ext/IO')
| -rw-r--r-- | ext/IO/Makefile.PL | 1 | ||||
| -rw-r--r-- | ext/IO/lib/IO/File.pm | 13 | ||||
| -rw-r--r-- | ext/IO/lib/IO/Handle.pm | 56 | ||||
| -rw-r--r-- | ext/IO/lib/IO/Pipe.pm | 235 | ||||
| -rw-r--r-- | ext/IO/lib/IO/Socket.pm | 45 |
5 files changed, 185 insertions, 165 deletions
diff --git a/ext/IO/Makefile.PL b/ext/IO/Makefile.PL index eb059bf8e7..4a34be61fb 100644 --- a/ext/IO/Makefile.PL +++ b/ext/IO/Makefile.PL @@ -4,4 +4,5 @@ WriteMakefile( MAN3PODS => ' ', # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'lib/IO/Handle.pm', + XS_VERSION => 1.15 ); diff --git a/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm index e44d77f1fe..0f8df001de 100644 --- a/ext/IO/lib/IO/File.pm +++ b/ext/IO/lib/IO/File.pm @@ -11,12 +11,12 @@ IO::File - supply object methods for filehandles use IO::File; $fh = new IO::File; - if ($fh->open "< file") { + if ($fh->open("< file")) { print <$fh>; $fh->close; } - $fh = new IO::File "> FOO"; + $fh = new IO::File "> file"; if (defined $fh) { print $fh "bar\n"; $fh->close; @@ -31,13 +31,12 @@ IO::File - supply object methods for filehandles $fh = new IO::File "file", O_WRONLY|O_APPEND; if (defined $fh) { print $fh "corge\n"; - undef $fh; # automatically closes the file - } - $pos = $fh->getpos; - $fh->setpos $pos; + $pos = $fh->getpos; + $fh->setpos($pos); - $fh->setvbuf($buffer_var, _IOLBF, 1024); + undef $fh; # automatically closes the file + } autoflush STDOUT 1; diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm index 03118ee55e..135351fac0 100644 --- a/ext/IO/lib/IO/Handle.pm +++ b/ext/IO/lib/IO/Handle.pm @@ -1,3 +1,4 @@ + package IO::Handle; =head1 NAME @@ -9,39 +10,33 @@ IO::Handle - supply object methods for I/O handles use IO::Handle; $fh = new IO::Handle; - if ($fh->open "< file") { - print <$fh>; - $fh->close; - } - - $fh = new IO::Handle "> FOO"; - if (defined $fh) { - print $fh "bar\n"; + if ($fh->fdopen(fileno(STDIN),"r")) { + print $fh->getline; $fh->close; } - $fh = new IO::Handle "file", "r"; - if (defined $fh) { - print <$fh>; - undef $fh; # automatically closes the file - } - - $fh = new IO::Handle "file", O_WRONLY|O_APPEND; - if (defined $fh) { - print $fh "corge\n"; - undef $fh; # automatically closes the file + $fh = new IO::Handle; + if ($fh->fdopen(fileno(STDOUT),"w")) { + $fh->print("Some text\n"); } - $pos = $fh->getpos; - $fh->setpos $pos; - $fh->setvbuf($buffer_var, _IOLBF, 1024); + undef $fh; # automatically closes the file if it's open + autoflush STDOUT 1; =head1 DESCRIPTION -C<IO::Handle> is the base class for all other IO handle classes. +C<IO::Handle> is the base class for all other IO handle classes. It is +not intended that objects of C<IO::Handle> would be created directly, +but instead C<IO::Handle> is inherited from by several other classes +in the IO hierarchy. + +If you are reading this documentation, looking for a replacement for +the C<FileHandle> package, then I suggest you read the documentation +for C<IO::File> + A C<IO::Handle> object is a reference to a symbol (see the C<Symbol> package) =head1 CONSTRUCTOR @@ -167,7 +162,7 @@ module keeps a C<timeout> variable in 'io_socket_timeout'. L<perlfunc>, L<perlop/"I/O Operators">, -L<FileHandle> +L<IO::File> =head1 BUGS @@ -184,7 +179,7 @@ Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> require 5.000; use strict; -use vars qw($VERSION @EXPORT_OK $AUTOLOAD @ISA); +use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA); use Carp; use Symbol; use SelectSaver; @@ -192,7 +187,8 @@ use SelectSaver; require Exporter; @ISA = qw(Exporter); -$VERSION = "1.1402"; +$VERSION = "1.1501"; +$XS_VERSION = "1.15"; @EXPORT_OK = qw( autoflush @@ -231,7 +227,7 @@ $VERSION = "1.1402"; require DynaLoader; @IO::ISA = qw(DynaLoader); -bootstrap IO $VERSION; +bootstrap IO $XS_VERSION; sub AUTOLOAD { if ($AUTOLOAD =~ /::(_?[a-z])/) { @@ -314,14 +310,8 @@ sub fdopen { sub close { @_ == 1 or croak 'usage: $fh->close()'; my($fh) = @_; - my $r = close($fh); - - # This may seem as though it should be in IO::Pipe, but the - # object gets blessed out of IO::Pipe when reader/writer is called - waitpid(${*$fh}{'io_pipe_pid'},0) - if(defined ${*$fh}{'io_pipe_pid'}); - $r; + close($fh); } ################################################ diff --git a/ext/IO/lib/IO/Pipe.pm b/ext/IO/lib/IO/Pipe.pm index 34cb0daad2..499856a6c6 100644 --- a/ext/IO/lib/IO/Pipe.pm +++ b/ext/IO/lib/IO/Pipe.pm @@ -1,7 +1,145 @@ +# IO::Pipe.pm # +# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights +# reserved. This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. package IO::Pipe; +require 5.000; + +use IO::Handle; +use strict; +use vars qw($VERSION); +use Carp; +use Symbol; + +$VERSION = "1.09"; + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::Pipe"; + @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]"; + + my $me = bless gensym(), $class; + + my($readfh,$writefh) = @_ ? @_ : $me->handles; + + pipe($readfh, $writefh) + or return undef; + + @{*$me} = ($readfh, $writefh); + + $me; +} + +sub handles { + @_ == 1 or croak 'usage: $pipe->handles()'; + (IO::Pipe::End->new(), IO::Pipe::End->new()); +} + +my $do_spawn = $^O eq 'os2'; + +sub _doit { + my $me = shift; + my $rw = shift; + + my $pid = $do_spawn ? 0 : fork(); + + if($pid) { # Parent + return $pid; + } + elsif(defined $pid) { # Child or spawn + my $fh; + my $io = $rw ? \*STDIN : \*STDOUT; + my ($mode, $save) = $rw ? "r" : "w"; + if ($do_spawn) { + require Fcntl; + $save = IO::Handle->new_from_fd($io, $mode); + # Close in child: + fcntl(shift, Fcntl::F_SETFD(), 1) or croak "fcntl: $!"; + $fh = $rw ? ${*$me}[0] : ${*$me}[1]; + } else { + shift; + $fh = $rw ? $me->reader() : $me->writer(); # close the other end + } + bless $io, "IO::Handle"; + $io->fdopen($fh, $mode); + + if ($do_spawn) { + $pid = eval { system 1, @_ }; # 1 == P_NOWAIT + my $err = $!; + + $io->fdopen($save, $mode); + $save->close or croak "Cannot close $!"; + croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0; + return $pid; + } else { + exec @_ or + croak "IO::Pipe: Cannot exec: $!"; + } + } + else { + croak "IO::Pipe: Cannot fork: $!"; + } + + # NOT Reached +} + +sub reader { + @_ >= 1 or croak 'usage: $pipe->reader()'; + my $me = shift; + my $fh = ${*$me}[0]; + my $pid = $me->_doit(0, $fh, @_) + if(@_); + + close ${*$me}[1]; + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +sub writer { + @_ >= 1 or croak 'usage: $pipe->writer()'; + my $me = shift; + my $fh = ${*$me}[1]; + my $pid = $me->_doit(1, $fh, @_) + if(@_); + + close ${*$me}[0]; + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +package IO::Pipe::End; + +use vars qw(@ISA); + +@ISA = qw(IO::Handle); + +sub close { + my $fh = shift; + my $r = $fh->SUPER::close(@_); + + waitpid(${*$fh}{'io_pipe_pid'},0) + if(defined ${*$fh}{'io_pipe_pid'}); + + $r; +} + +1; + +__END__ + =head1 NAME IO::pipe - supply object methods for pipes @@ -79,7 +217,7 @@ is called and C<ARGS> are passed to exec. This method is called during construction by C<IO::Pipe::new> on the newly created C<IO::Pipe> object. It returns an array of two objects -blessed into C<IO::Handle>, or a subclass thereof. +blessed into C<IO::Pipe::End>, or a subclass thereof. =back @@ -93,101 +231,8 @@ Graham Barr <bodg@tiuk.ti.com> =head1 COPYRIGHT -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free +Copyright (c) 1996 Graham Barr. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut - -require 5.000; -use strict; -use vars qw($VERSION); -use Carp; -use Symbol; -require IO::Handle; - -$VERSION = "1.08"; - -sub new { - my $type = shift; - my $class = ref($type) || $type || "IO::Pipe"; - @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]"; - - my $me = bless gensym(), $class; - - my($readfh,$writefh) = @_ ? @_ : $me->handles; - - pipe($readfh, $writefh) - or return undef; - - @{*$me} = ($readfh, $writefh); - - $me; -} - -sub handles { - @_ == 1 or croak 'usage: $pipe->handles()'; - (IO::Handle->new(), IO::Handle->new()); -} - -sub _doit { - my $me = shift; - my $rw = shift; - - my $pid = fork(); - - if($pid) { # Parent - return $pid; - } - elsif(defined $pid) { # Child - my $fh = $rw ? $me->reader() : $me->writer(); - my $io = $rw ? \*STDIN : \*STDOUT; - - bless $io, "IO::Handle"; - $io->fdopen($fh, $rw ? "r" : "w"); - exec @_ or - croak "IO::Pipe: Cannot exec: $!"; - } - else { - croak "IO::Pipe: Cannot fork: $!"; - } - - # NOT Reached -} - -sub reader { - @_ >= 1 or croak 'usage: $pipe->reader()'; - my $me = shift; - my $fh = ${*$me}[0]; - my $pid = $me->_doit(0,@_) - if(@_); - - close(${*$me}[1]); - bless $me, ref($fh); - *{*$me} = *{*$fh}; # Alias self to handle - bless $fh, 'IO::Pipe::DeadEnd'; # Really wan't un-bless here - ${*$me}{'io_pipe_pid'} = $pid - if defined $pid; - - $me; -} - -sub writer { - @_ >= 1 or croak 'usage: $pipe->writer()'; - my $me = shift; - my $fh = ${*$me}[1]; - my $pid = $me->_doit(1,@_) - if(@_); - - close(${*$me}[0]); - bless $me, ref($fh); - *{*$me} = *{*$fh}; # Alias self to handle - bless $fh, 'IO::Pipe::DeadEnd'; # Really wan't un-bless here - ${*$me}{'io_pipe_pid'} = $pid - if defined $pid; - - $me; -} - -1; - diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index 6a69c6b624..264d1ac076 100644 --- a/ext/IO/lib/IO/Socket.pm +++ b/ext/IO/lib/IO/Socket.pm @@ -1,4 +1,8 @@ +# IO::Socket.pm # +# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights +# reserved. This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. package IO::Socket; @@ -114,7 +118,7 @@ use Exporter; @ISA = qw(IO::Handle); -$VERSION = "1.15"; +$VERSION = "1.16"; sub import { my $pkg = shift; @@ -136,16 +140,7 @@ my @domain2pkg = (); sub register_domain { my($p,$d) = @_; - $domain2pkg[$d] = bless \$d, $p; -} - -sub _domain2pkg { - my $domain = shift; - - croak "Unsupported socket domain" - unless defined $domain2pkg[$domain]; - - $domain2pkg[$domain] + $domain2pkg[$d] = $p; } sub configure { @@ -155,12 +150,13 @@ sub configure { croak 'IO::Socket: Cannot configure a generic socket' unless defined $domain; - my $class = ref(_domain2pkg($domain)); + croak "IO::Socket: Unsupported socket domain" + unless defined $domain2pkg[$domain]; croak "IO::Socket: Cannot configure socket in domain '$domain'" unless ref($fh) eq "IO::Socket"; - bless($fh, $class); + bless($fh, $domain2pkg[$domain]); $fh->configure; } @@ -168,18 +164,13 @@ sub socket { @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)'; my($fh,$domain,$type,$protocol) = @_; - if(!defined ${*$fh}{'io_socket_domain'} - || !ref(${*$fh}{'io_socket_domain'}) - || ${${*$fh}{'io_socket_domain'}} != $domain) { - my $pkg = - ${*$fh}{'io_socket_domain'} = _domain2pkg($domain); - } - socket($fh,$domain,$type,$protocol) or return undef; - ${*$fh}{'io_socket_type'} = $type; - ${*$fh}{'io_socket_proto'} = $protocol; + ${*$fh}{'io_socket_domain'} = $domain; + ${*$fh}{'io_socket_type'} = $type; + ${*$fh}{'io_socket_proto'} = $protocol; + $fh; } @@ -352,7 +343,7 @@ sub timeout { sub sockdomain { @_ == 1 or croak 'usage: $fh->sockdomain()'; my $fh = shift; - ${${*$fh}{'io_socket_domain'}} + ${*$fh}{'io_socket_domain'}; } sub socktype { @@ -549,9 +540,6 @@ sub configure { my $pname = (getprotobynumber($proto))[0]; $type = $arg->{Type} || $socket_type{$pname}; - my $domain = AF_INET; - ${*$fh}{'io_socket_domain'} = bless \$domain; - $fh->socket(AF_INET, $type, $proto) or return _error($fh,"$!"); @@ -667,9 +655,6 @@ sub configure { my $type = $arg->{Type} || SOCK_STREAM; - my $domain = AF_UNIX; - ${*$fh}{'io_socket_domain'} = bless \$domain; - $fh->socket(AF_UNIX, $type, 0) or return undef; @@ -713,7 +698,7 @@ Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> =head1 COPYRIGHT -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free +Copyright (c) 1996 Graham Barr. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. |