From: Perl 5 Porters Date: Sat, 27 Jul 1996 01:17:48 +0000 (+0000) Subject: Add IO extension X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=8add82fcce53822c8119c2a311f526a412bbc9c7;p=p5sagit%2Fp5-mst-13.2.git Add IO extension --- diff --git a/ext/IO/IO.pm b/ext/IO/IO.pm new file mode 100644 index 0000000..645837b --- /dev/null +++ b/ext/IO/IO.pm @@ -0,0 +1,12 @@ +# + +package IO; + +use IO::Handle; +use IO::Seekable; +use IO::File; +use IO::Pipe; +use IO::Socket; + +1; + diff --git a/ext/IO/IO.xs b/ext/IO/IO.xs new file mode 100644 index 0000000..9dc09b2 --- /dev/null +++ b/ext/IO/IO.xs @@ -0,0 +1,208 @@ +#include "EXTERN.h" +#include "perl.h" +#include "XSUB.h" +#ifdef I_UNISTD +# include +#endif + +typedef int SysRet; +typedef FILE * InputStream; +typedef FILE * OutputStream; + +static int +not_here(s) +char *s; +{ + croak("%s not implemented on this architecture", s); + return -1; +} + +static bool +constant(name, pval) +char *name; +IV *pval; +{ + switch (*name) { + case '_': + if (strEQ(name, "_IOFBF")) +#ifdef _IOFBF + { *pval = _IOFBF; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "_IOLBF")) +#ifdef _IOLBF + { *pval = _IOLBF; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "_IONBF")) +#ifdef _IONBF + { *pval = _IONBF; return TRUE; } +#else + return FALSE; +#endif + break; + case 'S': + if (strEQ(name, "SEEK_SET")) +#ifdef SEEK_SET + { *pval = SEEK_SET; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "SEEK_CUR")) +#ifdef SEEK_CUR + { *pval = SEEK_CUR; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "SEEK_END")) +#ifdef SEEK_END + { *pval = SEEK_END; return TRUE; } +#else + return FALSE; +#endif + if (strEQ(name, "SEEK_EOF")) +#ifdef SEEK_EOF + { *pval = SEEK_EOF; return TRUE; } +#else + return FALSE; +#endif + break; + } + + return FALSE; +} + + +MODULE = IO PACKAGE = IO::Seekable PREFIX = f + +SV * +fgetpos(handle) + InputStream handle + CODE: +#ifdef HAS_FGETPOS + if (handle) { + Fpos_t pos; + fgetpos(handle, &pos); + ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); + } + else { + ST(0) = &sv_undef; + errno = EINVAL; + } +#else + ST(0) = (SV *) not_here("IO::Seekable::fgetpos"); +#endif + +SysRet +fsetpos(handle, pos) + InputStream handle + SV * pos + CODE: +#ifdef HAS_FSETPOS + if (handle) + RETVAL = fsetpos(handle, (Fpos_t*)SvPVX(pos)); + else { + RETVAL = -1; + errno = EINVAL; + } +#else + RETVAL = (SysRet) not_here("IO::Seekable::fsetpos"); +#endif + OUTPUT: + RETVAL + +MODULE = IO PACKAGE = IO::File PREFIX = f + +OutputStream +new_tmpfile(packname = "IO::File") + char * packname + CODE: + RETVAL = tmpfile(); + OUTPUT: + RETVAL + +MODULE = IO PACKAGE = IO::Handle PREFIX = f + +SV * +constant(name) + char * name + CODE: + IV i; + if (constant(name, &i)) + ST(0) = sv_2mortal(newSViv(i)); + else + ST(0) = &sv_undef; + +int +ungetc(handle, c) + InputStream handle + int c + CODE: + if (handle) + RETVAL = ungetc(c, handle); + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +int +ferror(handle) + InputStream handle + CODE: + if (handle) + RETVAL = ferror(handle); + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +SysRet +fflush(handle) + OutputStream handle + CODE: + if (handle) + RETVAL = Fflush(handle); + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +void +setbuf(handle, buf) + OutputStream handle + char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0; + CODE: + if (handle) + setbuf(handle, buf); + + + +SysRet +setvbuf(handle, buf, type, size) + OutputStream handle + char * buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0; + int type + int size + CODE: +#ifdef _IOFBF /* Should be HAS_SETVBUF once Configure tests for that */ + if (handle) + RETVAL = setvbuf(handle, buf, type, size); + else { + RETVAL = -1; + errno = EINVAL; + } +#else + RETVAL = (SysRet) not_here("IO::Handle::setvbuf"); +#endif /* _IOFBF */ + OUTPUT: + RETVAL + + diff --git a/ext/IO/Makefile.PL b/ext/IO/Makefile.PL new file mode 100644 index 0000000..eb059bf --- /dev/null +++ b/ext/IO/Makefile.PL @@ -0,0 +1,7 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => 'IO', + MAN3PODS => ' ', # Pods will be built by installman. + XSPROTOARG => '-noprototypes', # XXX remove later? + VERSION_FROM => 'lib/IO/Handle.pm', +); diff --git a/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm new file mode 100644 index 0000000..c447dfa --- /dev/null +++ b/ext/IO/lib/IO/File.pm @@ -0,0 +1,144 @@ +# + +package IO::File; + +=head1 NAME + +IO::File - supply object methods for filehandles + +=head1 SYNOPSIS + + use IO::File; + + $fh = new IO::File; + if ($fh->open "< file") { + print <$fh>; + $fh->close; + } + + $fh = new IO::File "> FOO"; + if (defined $fh) { + print $fh "bar\n"; + $fh->close; + } + + $fh = new IO::File "file", "r"; + if (defined $fh) { + print <$fh>; + undef $fh; # automatically closes the file + } + + $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; + + $fh->setvbuf($buffer_var, _IOLBF, 1024); + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +C creates a C, which is a reference to a +newly created symbol (see the C package). If it receives any +parameters, they are passed to C; if the open fails, +the C object is destroyed. Otherwise, it is returned to +the caller. + +C accepts one parameter or two. With one parameter, +it is just a front end for the built-in C function. With two +parameters, the first parameter is a filename that may include +whitespace or other special characters, and the second parameter is +the open mode in either Perl form (">", "+<", etc.) or POSIX form +("w", "r+", etc.). + +=head1 SEE ALSO + +L, +L, +L<"IO::Handle"> +L<"IO::Seekable"> + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr + +=head1 REVISION + +$Revision: 1.3 $ + +=cut + +require 5.000; +use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD); +use Carp; +use Symbol; +use English; +use SelectSaver; +use IO::Handle qw(_open_mode_string); +use IO::Seekable; + +require Exporter; +require DynaLoader; + +@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); + +$VERSION = sprintf("%d.%02d", q$Revision: 1.3 $ =~ /(\d+)\.(\d+)/); + +@EXPORT = @IO::Seekable::EXPORT; + +################################################ +## If the Fcntl extension is available, +## export its constants. +## + +sub import { + my $pkg = shift; + my $callpkg = caller; + Exporter::export $pkg, $callpkg; + eval { + require Fcntl; + Exporter::export 'Fcntl', $callpkg; + }; +}; + + +################################################ +## Constructor +## + +sub new { + @_ >= 1 && @_ <= 3 or croak 'usage: new IO::File [FILENAME [,MODE]]'; + my $class = shift; + my $fh = $class->SUPER::new(); + if (@_) { + $fh->open(@_) + or return undef; + } + $fh; +} + +################################################ +## Open +## + +sub open { + @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])'; + my ($fh, $file) = @_; + if (@_ > 2) { + my ($mode, $perms) = @_[2, 3]; + if ($mode =~ /^\d+$/) { + defined $perms or $perms = 0666; + return sysopen($fh, $file, $mode, $perms); + } + $file = "./" . $file unless $file =~ m#^/#; + $file = _open_mode_string($mode) . " $file\0"; + } + open($fh, $file); +} + +1; diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm new file mode 100644 index 0000000..aaba77c --- /dev/null +++ b/ext/IO/lib/IO/Handle.pm @@ -0,0 +1,514 @@ +# + +package IO::Handle; + +=head1 NAME + +IO::Handle - supply object methods for filehandles + +=head1 SYNOPSIS + + 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"; + $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 + } + + $pos = $fh->getpos; + $fh->setpos $pos; + + $fh->setvbuf($buffer_var, _IOLBF, 1024); + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +C creates a C, which is a reference to a +newly created symbol (see the C package). If it receives any +parameters, they are passed to C; if the open fails, +the C object is destroyed. Otherwise, it is returned to +the caller. + +C creates a C like C does. +It requires two parameters, which are passed to C; +if the fdopen fails, the C object is destroyed. +Otherwise, it is returned to the caller. + +C accepts one parameter or two. With one parameter, +it is just a front end for the built-in C function. With two +parameters, the first parameter is a filename that may include +whitespace or other special characters, and the second parameter is +the open mode in either Perl form (">", "+<", etc.) or POSIX form +("w", "r+", etc.). + +C is like C except that its first parameter +is not a filename but rather a file handle name, a IO::Handle object, +or a file descriptor number. + +C is like C found in C, that is it is the +opposite of read. The wrapper for the perl C function is +called C. + +C returns true if the object is currently a valid +file descriptor. + +If the C functions fgetpos() and fsetpos() are available, then +C returns an opaque value that represents the +current position of the IO::Handle, and C uses +that value to return to a previously visited position. + +If the C function setvbuf() is available, then C +sets the buffering policy for the IO::Handle. The calling sequence +for the Perl function is the same as its C counterpart, including the +macros C<_IOFBF>, C<_IOLBF>, and C<_IONBF>, except that the buffer +parameter specifies a scalar variable to use as a buffer. WARNING: A +variable used as a buffer by C must not be +modified in any way until the IO::Handle is closed or until +C is called again, or memory corruption may +result! + +See L for complete descriptions of each of the following +supported C methods, which are just front ends for the +corresponding built-in functions: + + close + fileno + getc + gets + eof + read + truncate + stat + +See L for complete descriptions of each of the following +supported C methods: + + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + format_write + +Furthermore, for doing normal I/O you might need these: + +=over + +=item $fh->print + +See L. + +=item $fh->printf + +See L. + +=item $fh->getline + +This works like <$fh> described in L +except that it's more readable and can be safely called in an +array context but still returns just one line. + +=item $fh->getlines + +This works like <$fh> when called in an array context to +read all the remaining lines in a file, except that it's more readable. +It will also croak() if accidentally called in a scalar context. + +=back + +=head1 + +The reference returned from new is a GLOB reference. Some modules that +inherit from C may want to keep object related variables +in the hash table part of the GLOB. In an attempt to prevent modules +trampling on each other I propose the that any such module should prefix +its variables with its own name separated by _'s. For example the IO::Socket +module keeps a C variable in 'io_socket_timeout'. + +=head1 SEE ALSO + +L, +L, +L + +=head1 BUGS + +Due to backwards compatibility, all filehandles resemble objects +of class C, or actually classes derived from that class. +They actually aren't. Which means you can't derive your own +class from C and inherit those methods. + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr + +=cut + +require 5.000; +use vars qw($VERSION @EXPORT_OK $AUTOLOAD); +use Carp; +use Symbol; +use SelectSaver; + +require Exporter; +@ISA = qw(Exporter); + +## +## TEMPORARY workaround as perl expects handles to be objects +## +@FileHandle::ISA = qw(IO::Handle); + + +$VERSION = sprintf("%d.%02d", q$Revision: 1.8 $ =~ /(\d+)\.(\d+)/); + +@EXPORT_OK = qw( + autoflush + output_field_separator + output_record_separator + input_record_separator + input_line_number + format_page_number + format_lines_per_page + format_lines_left + format_name + format_top_name + format_line_break_characters + format_formfeed + format_write + + print + printf + getline + getlines + + SEEK_SET + SEEK_CUR + SEEK_END + _IOFBF + _IOLBF + _IONBF + + _open_mode_string +); + + +################################################ +## Interaction with the XS. +## + +require DynaLoader; +@IO::ISA = qw(DynaLoader); +bootstrap IO $VERSION; + +sub AUTOLOAD { + if ($AUTOLOAD =~ /::(_?[a-z])/) { + $AutoLoader::AUTOLOAD = $AUTOLOAD; + goto &AutoLoader::AUTOLOAD + } + my $constname = $AUTOLOAD; + $constname =~ s/.*:://; + my $val = constant($constname); + defined $val or croak "$constname is not a valid IO::Handle macro"; + *$AUTOLOAD = sub { $val }; + goto &$AUTOLOAD; +} + + +################################################ +## Constructors, destructors. +## + +sub new { + @_ == 1 or croak 'usage: new IO::Handle'; + my $class = ref($_[0]) || $_[0]; + my $fh = gensym; + bless $fh, $class; +} + +sub new_from_fd { + @_ == 3 or croak 'usage: new_from_fd IO::Handle FD, MODE'; + my $class = shift; + my $fh = gensym; + IO::Handle::fdopen($fh, @_) + or return undef; + bless $fh, $class; + $fh->_ref_fd; + $fh; +} + +# FileHandle::DESTROY use to call close(). This creates a problem +# if 2 Handle objects have the same fd. sv_clear will call io close +# when the refcount in the xpvio becomes zero. +# +# It is defined as empty to stop AUTOLOAD being called :-) + +sub DESTROY { } + +################################################ +## Open and close. +## + +sub _open_mode_string { + my ($mode) = @_; + $mode =~ /^\+?(<|>>?)$/ + or $mode =~ s/^r(\+?)$/$1/ + or $mode =~ s/^a(\+?)$/$1>>/ + or croak "IO::Handle: bad open mode: $mode"; + $mode; +} + +sub fdopen { + @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)'; + my ($fh, $fd, $mode) = @_; + local(*GLOB); + + if (ref($fd) && "".$fd =~ /GLOB\(/o) { + # It's a glob reference; Alias it as we cannot get name of anon GLOBs + my $n = qualify(*GLOB); + *GLOB = *{*$fd}; + $fd = $n; + } elsif ($fd =~ m#^\d+$#) { + # It's an FD number; prefix with "=". + $fd = "=$fd"; + } + + open($fh, _open_mode_string($mode) . '&' . $fd) + ? $fh : undef; +} + +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; +} + +################################################ +## Normal I/O functions. +## + +# fcntl +# flock +# ioctl +# select +# sysread +# syswrite + +sub opened { + @_ == 1 or croak 'usage: $fh->opened()'; + defined fileno($_[0]); +} + +sub fileno { + @_ == 1 or croak 'usage: $fh->fileno()'; + fileno($_[0]); +} + +sub getc { + @_ == 1 or croak 'usage: $fh->getc()'; + getc($_[0]); +} + +sub gets { + @_ == 1 or croak 'usage: $fh->gets()'; + my ($handle) = @_; + scalar <$handle>; +} + +sub eof { + @_ == 1 or croak 'usage: $fh->eof()'; + eof($_[0]); +} + +sub print { + @_ or croak 'usage: $fh->print([ARGS])'; + my $this = shift; + print $this @_; +} + +sub printf { + @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])'; + my $this = shift; + printf $this @_; +} + +sub getline { + @_ == 1 or croak 'usage: $fh->getline'; + my $this = shift; + return scalar <$this>; +} + +sub getlines { + @_ == 1 or croak 'usage: $fh->getline()'; + my $this = shift; + wantarray or + croak "Can't call IO::Handle::getlines in a scalar context, use IO::Handle::getline"; + return <$this>; +} + +sub truncate { + @_ == 2 or croak 'usage: $fh->truncate(LEN)'; + truncate($_[0], $_[1]); +} + +sub read { + @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])'; + read($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub write { + @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])'; + local($\) = ""; + print { $_[0] } substr($_[1], $_[3] || 0, $_[2]); +} + +sub stat { + @_ == 1 or croak 'usage: $fh->stat()'; + stat($_[0]); +} + +################################################ +## State modification functions. +## + +sub autoflush { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $|; + $| = @_ > 1 ? $_[1] : 1; + $prev; +} + +sub output_field_separator { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $,; + $, = $_[1] if @_ > 1; + $prev; +} + +sub output_record_separator { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $\; + $\ = $_[1] if @_ > 1; + $prev; +} + +sub input_record_separator { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $/; + $/ = $_[1] if @_ > 1; + $prev; +} + +sub input_line_number { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $.; + $. = $_[1] if @_ > 1; + $prev; +} + +sub format_page_number { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $%; + $% = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_per_page { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $=; + $= = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_left { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $-; + $- = $_[1] if @_ > 1; + $prev; +} + +sub format_name { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $~; + $~ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_top_name { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $^; + $^ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_line_break_characters { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $:; + $: = $_[1] if @_ > 1; + $prev; +} + +sub format_formfeed { + my $old = new SelectSaver qualify($_[0], caller); + my $prev = $^L; + $^L = $_[1] if @_ > 1; + $prev; +} + +sub formline { + my $fh = shift; + my $picture = shift; + local($^A) = $^A; + local($\) = ""; + formline($picture, @_); + print $fh $^A; +} + +sub format_write { + @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )'; + if (@_ == 2) { + my ($fh, $fmt) = @_; + my $oldfmt = $fh->format_name($fmt); + write($fh); + $fh->format_name($oldfmt); + } else { + write($_[0]); + } +} + + +1; diff --git a/ext/IO/lib/IO/Pipe.pm b/ext/IO/lib/IO/Pipe.pm new file mode 100644 index 0000000..33d7219 --- /dev/null +++ b/ext/IO/lib/IO/Pipe.pm @@ -0,0 +1,177 @@ +# + +package IO::Pipe; + +=head1 NAME + +IO::pipe - supply object methods for pipes + +=head1 SYNOPSIS + + use IO::Pipe; + + $pipe = new IO::Pipe; + + if($pid = fork()) { # Parent + $pipe->reader(); + + while(<$pipe> { + .... + } + + } + elsif(defined $pid) { # Child + $pipe->writer(); + + print $pipe .... + } + + or + + $pipe = new IO::Pipe; + + $pipe->reader(qw(ls -l)); + + while(<$pipe>) { + .... + } + +=head1 DESCRIPTION + +C creates a C, which is a reference to a +newly created symbol (see the C package). C +optionally takes two arguments, which should be objects blessed into +C, or a subclass thereof. These two objects will be used +for the system call to C. If no arguments are given then then +method C is called on the new C object. + +These two handles are held in the array part of the GLOB untill either +C or C is called. + +=over + +=item $fh->reader([ARGS]) + +The object is re-blessed into a sub-class of C, and becomes a +handle at the reading end of the pipe. If C are given then C +is called and C are passed to exec. + +=item $fh->writer([ARGS]) + +The object is re-blessed into a sub-class of C, and becomes a +handle at the writing end of the pipe. If C are given then C +is called and C are passed to exec. + +=item $fh->handles + +This method is called during construction by C +on the newly created C object. It returns an array of two objects +blessed into C, or a subclass thereof. + +=back + +=head1 SEE ALSO + +L + +=head1 AUTHOR + +Graham Barr + +=head1 REVISION + +$Revision: 1.4 $ + +=head1 COPYRIGHT + +Copyright (c) 1995 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 vars qw($VERSION); +use Carp; +use Symbol; +require IO::Handle; + +$VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); + +sub new { + @_ == 1 || @_ == 3 or croak 'usage: new IO::Pipe([$READFH, $WRITEFH])'; + + my $me = bless gensym(), shift; + + 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(@_); + + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + ${*$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(@_); + + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +1; + diff --git a/ext/IO/lib/IO/Seekable.pm b/ext/IO/lib/IO/Seekable.pm new file mode 100644 index 0000000..bfa0b2a --- /dev/null +++ b/ext/IO/lib/IO/Seekable.pm @@ -0,0 +1,71 @@ +# + +package IO::Seekable; + +=head1 NAME + +IO::Seekable - supply seek based methods for I/O objects + +=head1 DESCRIPTION + +C does not have a constuctor of its own as is intended to +be inherited by other C based objects. It provides methods +which allow seeking of the file descriptors. + +If the C functions fgetpos() and fsetpos() are available, then +C returns an opaque value that represents the +current position of the IO::File, and C uses +that value to return to a previously visited position. + +See L for complete descriptions of each of the following +supported C methods, which are just front ends for the +corresponding built-in functions: + + clearerr + seek + tell + +=head1 SEE ALSO + +L, +L, +L<"IO::Handle"> +L<"IO::File"> + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr + +=head1 REVISION + +$Revision: 1.4 $ + +=cut + +require 5.000; +use Carp; +use vars qw($VERSION @EXPORT @ISA); +use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); +require Exporter; + +@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); +@ISA = qw(Exporter); + +$VERSION = sprintf("%d.%02d", q$Revision: 1.4 $ =~ /(\d+)\.(\d+)/); + +sub clearerr { + @_ == 1 or croak 'usage: $fh->clearerr()'; + seek($_[0], 0, SEEK_CUR); +} + +sub seek { + @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)'; + seek($_[0], $_[1], $_[2]); +} + +sub tell { + @_ == 1 or croak 'usage: $fh->tell()'; + tell($_[0]); +} + +1; diff --git a/ext/IO/lib/IO/Select.pm b/ext/IO/lib/IO/Select.pm new file mode 100644 index 0000000..208be0c --- /dev/null +++ b/ext/IO/lib/IO/Select.pm @@ -0,0 +1,280 @@ +# IO::Select.pm + +package IO::Select; + +=head1 NAME + +IO::Select - OO interface to the system select call + +=head1 SYNOPSYS + + use IO::Select; + + $s = IO::Select->new(); + + $s->add(\*STDIN); + $s->add($some_handle); + + @ready = $s->can_read($timeout); + + @ready = IO::Select->new(@handles)->read(0); + +=head1 DESCRIPTION + +The C package implements an object approach to the system C is a static method, that is you call it with the package name +like C. C, C and C are either C or +C objects. C is optional and has the same effect as +before. + +The result will be an array of 3 elements, each a reference to an array +which will hold the handles that are ready for reading, writing and have +error conditions respectively. Upon error an empty array is returned. + +=back + +=head1 EXAMPLE + +Here is a short example which shows how C could be used +to write a server which communicates with several sockets while also +listening for more connections on a listen socket + + use IO::Select; + use IO::Socket; + + $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080); + $sel = new IO::Select( $lsn ); + + while(@ready = $sel->can_read) { + foreach $fh (@ready) { + if($fh == $lsn) { + # Create a new socket + $new = $lsn->accept; + $sel->add($new); + } + else { + # Process socket + + # Maybe we have finished with the socket + $sel->remove($fh); + $fh->close; + } + } + } + +=head1 AUTHOR + +Graham Barr + +=head1 REVISION + +$Revision: 1.2 $ + +=head1 COPYRIGHT + +Copyright (c) 1995 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 + +use strict; +use vars qw($VERSION @ISA); +require Exporter; + +$VERSION = sprintf("%d.%02d", q$Revision: 1.2 $ =~ /(\d+)\.(\d+)/); + +@ISA = qw(Exporter); # This is only so we can do version checking + +sub new +{ + my $self = shift; + my $type = ref($self) || $self; + + my $vec = bless [''], $type; + + $vec->add(@_) + if @_; + + $vec; +} + +sub add +{ + my $vec = shift; + my $f; + + foreach $f (@_) + { + my $fn = $f =~ /^\d+$/ ? $f : fileno($f); + next + unless defined $fn; + vec($vec->[0],$fn++,1) = 1; + $vec->[$fn] = $f; + } +} + +sub remove +{ + my $vec = shift; + my $f; + + foreach $f (@_) + { + my $fn = $f =~ /^\d+$/ ? $f : fileno($f); + next + unless defined $fn; + vec($vec->[0],$fn++,1) = 0; + $vec->[$fn] = undef; + } +} + +sub can_read +{ + my $vec = shift; + my $timeout = shift; + + my $r = $vec->[0]; + + select($r,undef,undef,$timeout) > 0 + ? _handles($vec, $r) + : (); +} + +sub can_write +{ + my $vec = shift; + my $timeout = shift; + + my $w = $vec->[0]; + + select(undef,$w,undef,$timeout) > 0 + ? _handles($vec, $w) + : (); +} + +sub has_error +{ + my $vec = shift; + my $timeout = shift; + + my $e = $vec->[0]; + + select(undef,undef,$e,$timeout) > 0 + ? _handles($vec, $e) + : (); +} + +sub _max +{ + my($a,$b,$c) = @_; + $a > $b + ? $a > $c + ? $a + : $c + : $b > $c + ? $b + : $c; +} + +sub select +{ + shift + if defined $_[0] && !ref($_[0]); + + my($r,$w,$e,$t) = @_; + my @result = (); + + my $rb = defined $r ? $r->[0] : undef; + my $wb = defined $w ? $e->[0] : undef; + my $eb = defined $e ? $w->[0] : undef; + + if(select($rb,$wb,$eb,$t) > 0) + { + my @r = (); + my @w = (); + my @e = (); + my $i = _max(defined $r ? scalar(@$r) : 0, + defined $w ? scalar(@$w) : 0, + defined $e ? scalar(@$e) : 0); + + for( ; $i > 0 ; $i--) + { + my $j = $i - 1; + push(@r, $r->[$i]) + if defined $r->[$i] && vec($rb, $j, 1); + push(@w, $w->[$i]) + if defined $w->[$i] && vec($wb, $j, 1); + push(@e, $e->[$i]) + if defined $e->[$i] && vec($eb, $j, 1); + } + + @result = (\@r, \@w, \@e); + } + @result; +} + +sub _handles +{ + my $vec = shift; + my $bits = shift; + my @h = (); + my $i; + + for($i = scalar(@$vec) - 1 ; $i > 0 ; $i--) + { + next unless defined $vec->[$i]; + push(@h, $vec->[$i]) + if vec($bits,$i - 1,1); + } + + @h; +} + +1; diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm new file mode 100644 index 0000000..be81d9a --- /dev/null +++ b/ext/IO/lib/IO/Socket.pm @@ -0,0 +1,563 @@ +# + +package IO::Socket; + +=head1 NAME + +IO::Socket - supply object methods for sockets + +=head1 SYNOPSIS + + use IO::Socket; + +=head1 DESCRIPTION + +C provides an object interface to creating and using sockets. It +is built upon the L interface and inherits all the methods defined +by L. + +C only defines methods for those operations which are common to all +types of socket. Operations which are specified to a socket in a particular +domain have methods defined in sub classes of C + +See L for complete descriptions of each of the following +supported C methods, which are just front ends for the +corresponding built-in functions: + + socket + socketpair + bind + listen + accept + send + recv + peername (getpeername) + sockname (getsockname) + +Some methods take slightly different arguments to those defined in L +in attempt to make the interface more flexible. These are + +=item accept([PKG]) + +perform the system call C on the socket and return a new object. The +new object will be created in the same class as the listen socket, unless +C is specified. This object can be used to communicate with the client +that was trying to connect. In a scalar context the new socket is returned, +or undef upon failure. In an array context a two-element array is returned +containing the new socket and the peer address, the list will +be empty upon failure. + +Additional methods that are provided are + +=item timeout([VAL]) + +Set or get the timeout value associated with this socket. If called without +any arguments then the current setting is returned. If called with an argument +the current setting is changed and the previous value returned. + +=item sockopt(OPT [, VAL]) + +Unified method to both set and get options in the SOL_SOCKET level. If called +with one argument then getsockopt is called, otherwise setsockopt is called + +=cut + + +require 5.000; + +use Config; +use IO::Handle; +use Socket 1.3; +use Carp; +use strict; +use vars qw(@ISA @EXPORT_OK $VERSION); +use Exporter; + +@ISA = qw(IO::Handle); + +# This one will turn 1.2 => 1.02 and 1.2.3 => 1.0203 and so on ... +$VERSION = do{my @r=(q$Revision: 1.8$=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r}; + +sub import { + my $pkg = shift; + my $callpkg = caller; + Exporter::export 'Socket', $callpkg, @_; +} + +sub new { + my($class,%arg) = @_; + my $fh = $class->SUPER::new(); + + ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout}; + + return scalar(%arg) ? $fh->configure(\%arg) + : $fh; +} + +sub configure { + croak 'IO::Socket: Cannot configure a generic socket'; +} + +sub socket { + @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)'; + my($fh,$domain,$type,$protocol) = @_; + + socket($fh,$domain,$type,$protocol) or + return undef; + + ${*$fh}{'io_socket_type'} = $type; + $fh; +} + +sub socketpair { + @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)'; + my($class,$domain,$type,$protocol) = @_; + my $fh1 = $class->new(); + my $fh2 = $class->new(); + + socketpair($fh1,$fh1,$domain,$type,$protocol) or + return (); + + ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type; + + ($fh1,$fh2); +} + +sub connect { + @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)'; + my $fh = shift; + my $addr = @_ == 1 ? shift : sockaddr_in(@_); + my $timeout = ${*$fh}{'io_socket_timeout'}; + local($SIG{ALRM}) = $timeout ? sub { undef $fh; } + : $SIG{ALRM} || 'DEFAULT'; + + eval { + croak 'connect: Bad address' + if(@_ == 2 && !defined $_[1]); + + if($timeout) { + defined $Config{d_alarm} && defined alarm($timeout) or + $timeout = 0; + } + + my $ok = eval { connect($fh, $addr) }; + + alarm(0) + if($timeout); + + croak "connect: timeout" + unless defined $fh; + + undef $fh unless $ok; + + }; + $fh; +} + +sub bind { + @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)'; + my $fh = shift; + my $addr = @_ == 1 ? shift : sockaddr_in(@_); + + return bind($fh, $addr) ? $fh + : undef; +} + +sub listen { + @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])'; + my($fh,$queue) = @_; + $queue = 5 + unless $queue && $queue > 0; + + return listen($fh, $queue) ? $fh + : undef; +} + +sub accept { + @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])'; + my $fh = shift; + my $pkg = shift || $fh; + my $timeout = ${*$fh}{'io_socket_timeout'}; + my $new = $pkg->new(Timeout => $timeout); + my $peer = undef; + + eval { + if($timeout) { + my $fdset = ""; + vec($fdset, $fh->fileno,1) = 1; + croak "accept: timeout" + unless select($fdset,undef,undef,$timeout); + } + $peer = accept($new,$fh); + }; + + return wantarray ? defined $peer ? ($new, $peer) + : () + : defined $peer ? $new + : undef; +} + +sub sockname { + @_ == 1 or croak 'usage: $fh->sockname()'; + getsockname($_[0]); +} + +sub peername { + @_ == 1 or croak 'usage: $fh->peername()'; + my($fh) = @_; + getpeername($fh) + || ${*$fh}{'io_socket_peername'} + || undef; +} + +sub send { + @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])'; + my $fh = $_[0]; + my $flags = $_[2] || 0; + my $peer = $_[3] || $fh->peername; + + croak 'send: Cannot determine peer address' + unless($peer); + + my $r = send($fh, $_[1], $flags, $peer); + + # remember who we send to, if it was sucessful + ${*$fh}{'io_socket_peername'} = $peer + if(@_ == 4 && defined $r); + + $r; +} + +sub recv { + @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])'; + my $sock = $_[0]; + my $len = $_[2]; + my $flags = $_[3] || 0; + + # remember who we recv'd from + ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags); +} + + +sub setsockopt { + @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)'; + setsockopt($_[0],$_[1],$_[2],$_[3]); +} + +my $intsize = length(pack("i",0)); + +sub getsockopt { + @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)'; + my $r = getsockopt($_[0],$_[1],$_[2]); + # Just a guess + $r = unpack("i", $r) + if(defined $r && length($r) == $intsize); + $r; +} + +sub sockopt { + my $fh = shift; + @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_) + : $fh->setsockopt(SOL_SOCKET,@_); +} + +sub timeout { + @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])'; + my($fh,$val) = @_; + my $r = ${*$fh}{'io_socket_timeout'} || undef; + + ${*$fh}{'io_socket_timeout'} = 0 + $val + if(@_ == 2); + + $r; +} + +sub socktype { + @_ == 1 or croak '$fh->socktype()'; + ${*{$_[0]}}{'io_socket_type'} || undef; +} + +=head1 SUB-CLASSES + +=cut + +## +## AF_INET +## + +package IO::Socket::INET; + +use strict; +use vars qw(@ISA $VERSION); +use Socket; +use Carp; +use Exporter; + +@ISA = qw(IO::Socket); + +my %socket_type = ( tcp => SOCK_STREAM, + udp => SOCK_DGRAM, + ); + +=head2 IO::Socket::INET + +C provides a constructor to create an AF_INET domain socket +and some related methods. The constructor can take the following options + + PeerAddr Remote host address + PeerPort Remote port or service + LocalPort Local host bind port + LocalAddr Local host bind address + Proto Protocol name (eg tcp udp etc) + Type Socket type (SOCK_STREAM etc) + Listen Queue size for listen + Timeout Timeout value for various operations + +If Listen is defined then a listen socket is created, else if the socket +type, which is derived from the protocol, is SOCK_STREAM then a connect +is called + +Only one of C or C needs to be specified, one will be assumed +from the other. + +=head2 METHODS + +=item sockaddr() + +Return the address part of the sockaddr structure for the socket + +=item sockport() + +Return the port number that the socket is using on the local host + +=item sockhost() + +Return the address part of the sockaddr structure for the socket in a +text form xx.xx.xx.xx + +=item peeraddr(), peerport(), peerhost() + +Same as for the sock* functions, but returns the data about the peer +host instead of the local host. + +=cut + + +sub _sock_info { + my($addr,$port,$proto) = @_; + my @proto = (); + my @serv = (); + + $port = $1 + if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,); + + if(defined $proto) { + @proto = $proto =~ m,\D, ? getprotobyname($proto) + : getprotobynumber($proto); + + $proto = $proto[2] || undef; + } + + if(defined $port) { + $port =~ s,\((\d+)\)$,,; + + my $defport = $1 || undef; + my $pnum = ($port =~ m,^(\d+)$,)[0]; + + @serv= getservbyname($port, $proto[0] || "") + if($port =~ m,\D,); + + $port = $pnum || $serv[2] || $defport || undef; + + $proto = (getprotobyname($serv[3]))[2] || undef + if @serv && !$proto; + } + + return ($addr || undef, + $port || undef, + $proto || undef + ); +} + +sub configure { + my($fh,$arg) = @_; + my($lport,$rport,$laddr,$raddr,$proto,$type); + + + ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr}, + $arg->{LocalPort}, + $arg->{Proto}); + + $laddr = defined $laddr ? inet_aton($laddr) + : INADDR_ANY; + + unless(exists $arg->{Listen}) { + ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr}, + $arg->{PeerPort}, + $proto); + } + + croak 'IO::Socket: Cannot determine protocol' + unless($proto); + + my $pname = (getprotobynumber($proto))[0]; + $type = $arg->{Type} || $socket_type{$pname}; + + $fh->socket(AF_INET, $type, $proto) or + return undef; + + $fh->bind($lport || 0, $laddr) or + return undef; + + if(exists $arg->{Listen}) { + $fh->listen($arg->{Listen} || 5) or + return undef; + } + else { + croak "IO::Socket: Cannot determine remote port" + unless($rport || $type == SOCK_DGRAM); + + if($type == SOCK_STREAM || defined $raddr) { + croak "IO::Socket: Bad peer address" + unless defined $raddr; + + $fh->connect($rport,inet_aton($raddr)) or + return undef; + } + } + + $fh; +} + +sub sockaddr { + @_ == 1 or croak 'usage: $fh->sockaddr()'; + my($fh) = @_; + (sockaddr_in($fh->sockname))[1]; +} + +sub sockport { + @_ == 1 or croak 'usage: $fh->sockport()'; + my($fh) = @_; + (sockaddr_in($fh->sockname))[0]; +} + +sub sockhost { + @_ == 1 or croak 'usage: $fh->sockhost()'; + my($fh) = @_; + inet_ntoa($fh->sockaddr); +} + +sub peeraddr { + @_ == 1 or croak 'usage: $fh->peeraddr()'; + my($fh) = @_; + (sockaddr_in($fh->peername))[1]; +} + +sub peerport { + @_ == 1 or croak 'usage: $fh->peerport()'; + my($fh) = @_; + (sockaddr_in($fh->peername))[0]; +} + +sub peerhost { + @_ == 1 or croak 'usage: $fh->peerhost()'; + my($fh) = @_; + inet_ntoa($fh->peeraddr); +} + +## +## AF_UNIX +## + +package IO::Socket::UNIX; + +use strict; +use vars qw(@ISA $VERSION); +use Socket; +use Carp; +use Exporter; + +@ISA = qw(IO::Socket); + +=head2 IO::Socket::UNIX + +C provides a constructor to create an AF_UNIX domain socket +and some related methods. The constructor can take the following options + + Type Type of socket (eg SOCK_STREAM or SOCK_DGRAM) + Local Path to local fifo + Peer Path to peer fifo + Listen Create a listen socket + +=head2 METHODS + +=item hostpath() + +Returns the pathname to the fifo at the local end + +=item peerpath() + +Returns the pathanme to the fifo at the peer end + +=cut + +sub configure { + my($fh,$arg) = @_; + my($bport,$cport); + + my $type = $arg->{Type} || SOCK_STREAM; + + $fh->socket(AF_UNIX, $type, 0) or + return undef; + + if(exists $arg->{Local}) { + my $addr = sockaddr_un($arg->{Local}); + $fh->bind($addr) or + return undef; + } + if(exists $arg->{Listen}) { + $fh->listen($arg->{Listen} || 5) or + return undef; + } + elsif(exists $arg->{Peer}) { + my $addr = sockaddr_un($arg->{Peer}); + $fh->connect($addr) or + return undef; + } + + $fh; +} + +sub hostpath { + @_ == 1 or croak 'usage: $fh->hostpath()'; + (sockaddr_un($_[0]->hostname))[0]; +} + +sub peerpath { + @_ == 1 or croak 'usage: $fh->peerpath()'; + (sockaddr_un($_[0]->peername))[0]; +} + +=head1 AUTHOR + +Graham Barr + +=head1 REVISION + +$Revision: 1.8 $ + +The VERSION is derived from the revision turning each number after the +first dot into a 2 digit number so + + Revision 1.8 => VERSION 1.08 + Revision 1.2.3 => VERSION 1.0203 + +=head1 COPYRIGHT + +Copyright (c) 1995 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 + +1; # Keep require happy