diff options
Diffstat (limited to 'contrib/perl5/ext/IO')
-rw-r--r-- | contrib/perl5/ext/IO/IO.pm | 36 | ||||
-rw-r--r-- | contrib/perl5/ext/IO/IO.xs | 292 | ||||
-rw-r--r-- | contrib/perl5/ext/IO/Makefile.PL | 8 | ||||
-rw-r--r-- | contrib/perl5/ext/IO/README | 4 | ||||
-rw-r--r-- | contrib/perl5/ext/IO/lib/IO/File.pm | 167 | ||||
-rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Handle.pm | 539 | ||||
-rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Pipe.pm | 239 | ||||
-rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Seekable.pm | 68 | ||||
-rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Select.pm | 371 | ||||
-rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Socket.pm | 728 |
10 files changed, 2452 insertions, 0 deletions
diff --git a/contrib/perl5/ext/IO/IO.pm b/contrib/perl5/ext/IO/IO.pm new file mode 100644 index 0000000..4d4c81c --- /dev/null +++ b/contrib/perl5/ext/IO/IO.pm @@ -0,0 +1,36 @@ +# + +package IO; + +=head1 NAME + +IO - load various IO modules + +=head1 SYNOPSIS + + use IO; + +=head1 DESCRIPTION + +C<IO> provides a simple mechanism to load some of the IO modules at one go. +Currently this includes: + + IO::Handle + IO::Seekable + IO::File + IO::Pipe + IO::Socket + +For more information on any of these modules, please see its respective +documentation. + +=cut + +use IO::Handle; +use IO::Seekable; +use IO::File; +use IO::Pipe; +use IO::Socket; + +1; + diff --git a/contrib/perl5/ext/IO/IO.xs b/contrib/perl5/ext/IO/IO.xs new file mode 100644 index 0000000..a434cca --- /dev/null +++ b/contrib/perl5/ext/IO/IO.xs @@ -0,0 +1,292 @@ +#include "EXTERN.h" +#define PERLIO_NOT_STDIO 1 +#include "perl.h" +#include "XSUB.h" + +#ifdef I_UNISTD +# include <unistd.h> +#endif +#ifdef I_FCNTL +#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) +#define _NO_OLDNAMES +#endif +# include <fcntl.h> +#if defined(__GNUC__) && defined(__cplusplus) && defined(WIN32) +#undef _NO_OLDNAMES +#endif + +#endif + +#ifdef PerlIO +typedef int SysRet; +typedef PerlIO * InputStream; +typedef PerlIO * OutputStream; +#else +#define PERLIO_IS_STDIO 1 +typedef int SysRet; +typedef FILE * InputStream; +typedef FILE * OutputStream; +#endif + +static int +not_here(char *s) +{ + croak("%s not implemented on this architecture", s); + return -1; +} + +static bool +constant(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 + break; + } + + return FALSE; +} + + +MODULE = IO PACKAGE = IO::Seekable PREFIX = f + +SV * +fgetpos(handle) + InputStream handle + CODE: + if (handle) { + Fpos_t pos; +#ifdef PerlIO + PerlIO_getpos(handle, &pos); +#else + fgetpos(handle, &pos); +#endif + ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t))); + } + else { + ST(0) = &PL_sv_undef; + errno = EINVAL; + } + +SysRet +fsetpos(handle, pos) + InputStream handle + SV * pos + CODE: + char *p; + if (handle && (p = SvPVx(pos, PL_na)) && PL_na == sizeof(Fpos_t)) +#ifdef PerlIO + RETVAL = PerlIO_setpos(handle, (Fpos_t*)p); +#else + RETVAL = fsetpos(handle, (Fpos_t*)p); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +MODULE = IO PACKAGE = IO::File PREFIX = f + +SV * +new_tmpfile(packname = "IO::File") + char * packname + PREINIT: + OutputStream fp; + GV *gv; + CODE: +#ifdef PerlIO + fp = PerlIO_tmpfile(); +#else + fp = tmpfile(); +#endif + gv = (GV*)SvREFCNT_inc(newGVgen(packname)); + hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD); + if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) { + ST(0) = sv_2mortal(newRV((SV*)gv)); + sv_bless(ST(0), gv_stashpv(packname, TRUE)); + SvREFCNT_dec(gv); /* undo increment in newRV() */ + } + else { + ST(0) = &PL_sv_undef; + SvREFCNT_dec(gv); + } + +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) = &PL_sv_undef; + +int +ungetc(handle, c) + InputStream handle + int c + CODE: + if (handle) +#ifdef PerlIO + RETVAL = PerlIO_ungetc(handle, c); +#else + RETVAL = ungetc(c, handle); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +int +ferror(handle) + InputStream handle + CODE: + if (handle) +#ifdef PerlIO + RETVAL = PerlIO_error(handle); +#else + RETVAL = ferror(handle); +#endif + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +int +clearerr(handle) + InputStream handle + CODE: + if (handle) { +#ifdef PerlIO + PerlIO_clearerr(handle); +#else + clearerr(handle); +#endif + RETVAL = 0; + } + else { + RETVAL = -1; + errno = EINVAL; + } + OUTPUT: + RETVAL + +int +untaint(handle) + SV * handle + CODE: +#ifdef IOf_UNTAINT + IO * io; + io = sv_2io(handle); + if (io) { + IoFLAGS(io) |= IOf_UNTAINT; + RETVAL = 0; + } + else { +#endif + RETVAL = -1; + errno = EINVAL; +#ifdef IOf_UNTAINT + } +#endif + OUTPUT: + RETVAL + +SysRet +fflush(handle) + OutputStream handle + CODE: + if (handle) +#ifdef PerlIO + RETVAL = PerlIO_flush(handle); +#else + RETVAL = Fflush(handle); +#endif + 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) +#ifdef PERLIO_IS_STDIO + setbuf(handle, buf); +#else + not_here("IO::Handle::setbuf"); +#endif + +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: +/* Should check HAS_SETVBUF once Configure tests for that */ +#if defined(PERLIO_IS_STDIO) && defined(_IOFBF) + if (!handle) /* Try input stream. */ + handle = IoIFP(sv_2io(ST(0))); + if (handle) + RETVAL = setvbuf(handle, buf, type, size); + else { + RETVAL = -1; + errno = EINVAL; + } +#else + RETVAL = (SysRet) not_here("IO::Handle::setvbuf"); +#endif + OUTPUT: + RETVAL + + diff --git a/contrib/perl5/ext/IO/Makefile.PL b/contrib/perl5/ext/IO/Makefile.PL new file mode 100644 index 0000000..4a34be6 --- /dev/null +++ b/contrib/perl5/ext/IO/Makefile.PL @@ -0,0 +1,8 @@ +use ExtUtils::MakeMaker; +WriteMakefile( + NAME => 'IO', + 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/contrib/perl5/ext/IO/README b/contrib/perl5/ext/IO/README new file mode 100644 index 0000000..e855afa --- /dev/null +++ b/contrib/perl5/ext/IO/README @@ -0,0 +1,4 @@ +This directory contains files from the IO distribution maintained by +Graham Barr <bodg@tiuk.ti.com>. If you find that you have to modify +any files in this directory then please forward him a patch for only +the files in this directory. diff --git a/contrib/perl5/ext/IO/lib/IO/File.pm b/contrib/perl5/ext/IO/lib/IO/File.pm new file mode 100644 index 0000000..de7fabc --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/File.pm @@ -0,0 +1,167 @@ +# + +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 "> file"; + 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"; + + $pos = $fh->getpos; + $fh->setpos($pos); + + undef $fh; # automatically closes the file + } + + autoflush STDOUT 1; + +=head1 DESCRIPTION + +C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends +these classes with methods that are specific to file handles. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ([ ARGS ] ) + +Creates a C<IO::File>. If it receives any parameters, they are passed to +the method C<open>; if the open fails, the object is destroyed. Otherwise, +it is returned to the caller. + +=item new_tmpfile + +Creates an C<IO::File> opened for read/write on a newly created temporary +file. On systems where this is possible, the temporary file is anonymous +(i.e. it is unlinked after creation, but held open). If the temporary +file cannot be created or opened, the C<IO::File> object is destroyed. +Otherwise, it is returned to the caller. + +=back + +=head1 METHODS + +=over 4 + +=item open( FILENAME [,MODE [,PERMS]] ) + +C<open> accepts one, two or three parameters. With one parameter, +it is just a front end for the built-in C<open> 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, optionally followed by a file permission value. + +If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.) +or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C<open> operator. + +If C<IO::File::open> is given a numeric mode, it passes that mode +and the optional permissions value to the Perl C<sysopen> operator. +For convenience, C<IO::File::import> tries to import the O_XXX +constants from the Fcntl module. If dynamic loading is not available, +this may fail, but the rest of IO::File will still work. + +=back + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::Handle> +L<IO::Seekable> + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>. + +=cut + +require 5.000; +use strict; +use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA); +use Carp; +use Symbol; +use SelectSaver; +use IO::Seekable; + +require Exporter; +require DynaLoader; + +@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); + +$VERSION = "1.06021"; + +@EXPORT = @IO::Seekable::EXPORT; + +eval { + # Make all Fcntl O_XXX constants available for importing + require Fcntl; + my @O = grep /^O_/, @Fcntl::EXPORT; + Fcntl->import(@O); # first we import what we want to export + push(@EXPORT, @O); +}; + + +################################################ +## Constructor +## + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::File"; + @_ >= 0 && @_ <= 3 + or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]"; + 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 if $file =~ m{\A[^\\/\w]}; + $file = IO::Handle::_open_mode_string($mode) . " $file\0"; + } + open($fh, $file); +} + +1; diff --git a/contrib/perl5/ext/IO/lib/IO/Handle.pm b/contrib/perl5/ext/IO/lib/IO/Handle.pm new file mode 100644 index 0000000..7927641 --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Handle.pm @@ -0,0 +1,539 @@ + +package IO::Handle; + +=head1 NAME + +IO::Handle - supply object methods for I/O handles + +=head1 SYNOPSIS + + use IO::Handle; + + $fh = new IO::Handle; + if ($fh->fdopen(fileno(STDIN),"r")) { + print $fh->getline; + $fh->close; + } + + $fh = new IO::Handle; + if ($fh->fdopen(fileno(STDOUT),"w")) { + $fh->print("Some text\n"); + } + + use IO::Handle '_IOLBF'; + $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. 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 + +=over 4 + +=item new () + +Creates a new C<IO::Handle> object. + +=item new_from_fd ( FD, MODE ) + +Creates a C<IO::Handle> like C<new> does. +It requires two parameters, which are passed to the method C<fdopen>; +if the fdopen fails, the object is destroyed. Otherwise, it is returned +to the caller. + +=back + +=head1 METHODS + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Handle> methods, which are just front ends for the +corresponding built-in functions: + + close + fileno + getc + eof + read + truncate + stat + print + printf + sysread + syswrite + +See L<perlvar> for complete descriptions of each of the following +supported C<IO::Handle> 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->fdopen ( FD, MODE ) + +C<fdopen> is like an ordinary C<open> except that its first parameter +is not a filename but rather a file handle name, a IO::Handle object, +or a file descriptor number. + +=item $fh->opened + +Returns true if the object is currently a valid file descriptor. + +=item $fh->getline + +This works like <$fh> described in L<perlop/"I/O Operators"> +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. + +=item $fh->ungetc ( ORD ) + +Pushes a character with the given ordinal value back onto the given +handle's input stream. + +=item $fh->write ( BUF, LEN [, OFFSET }\] ) + +This C<write> is like C<write> found in C, that is it is the +opposite of read. The wrapper for the perl C<write> function is +called C<format_write>. + +=item $fh->flush + +Flush the given handle's buffer. + +=item $fh->error + +Returns a true value if the given handle has experienced any errors +since it was opened or since the last call to C<clearerr>. + +=item $fh->clearerr + +Clear the given handle's error indicator. + +=back + +If the C functions setbuf() and/or setvbuf() are available, then +C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering +policy for an IO::Handle. The calling sequences for the Perl functions +are the same as their C counterparts--including the constants C<_IOFBF>, +C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter +specifies a scalar variable to use as a buffer. WARNING: A variable +used as a buffer by C<setbuf> or C<setvbuf> must not be modified in any +way until the IO::Handle is closed or C<setbuf> or C<setvbuf> is called +again, or memory corruption may result! Note that you need to import +the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. + +Lastly, there is a special method for working under B<-T> and setuid/gid +scripts: + +=over + +=item $fh->untaint + +Marks the object as taint-clean, and as such data read from it will also +be considered taint-clean. Note that this is a very trusting action to +take, and appropriate consideration for the data source and potential +vulnerability should be kept in mind. + +=back + +=head1 NOTE + +A C<IO::Handle> object is a GLOB reference. Some modules that +inherit from C<IO::Handle> 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<timeout> variable in 'io_socket_timeout'. + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::File> + +=head1 BUGS + +Due to backwards compatibility, all filehandles resemble objects +of class C<IO::Handle>, or actually classes derived from that class. +They actually aren't. Which means you can't derive your own +class from C<IO::Handle> and inherit those methods. + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> + +=cut + +require 5.000; +use strict; +use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA); +use Carp; +use Symbol; +use SelectSaver; + +require Exporter; +@ISA = qw(Exporter); + +$VERSION = "1.1505"; +$XS_VERSION = "1.15"; + +@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 +); + + +################################################ +## Interaction with the XS. +## + +require DynaLoader; +@IO::ISA = qw(DynaLoader); +bootstrap IO $XS_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"; + no strict 'refs'; + *$AUTOLOAD = sub { $val }; + goto &$AUTOLOAD; +} + + +################################################ +## Constructors, destructors. +## + +sub new { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 1 or croak "usage: new $class"; + my $fh = gensym; + bless $fh, $class; +} + +sub new_from_fd { + my $class = ref($_[0]) || $_[0] || "IO::Handle"; + @_ == 3 or croak "usage: new_from_fd $class FD, MODE"; + my $fh = gensym; + shift; + IO::Handle::fdopen($fh, @_) + or return undef; + bless $fh, $class; +} + +# +# There is no need for DESTROY to do anything, because when the +# last reference to an IO object is gone, Perl automatically +# closes its associated files (if any). However, to avoid any +# attempts to autoload DESTROY, we here define it to do nothing. +# +sub DESTROY {} + + +################################################ +## Open and close. +## + +sub _open_mode_string { + my ($mode) = @_; + $mode =~ /^\+?(<|>>?)$/ + or $mode =~ s/^r(\+?)$/$1</ + or $mode =~ s/^w(\+?)$/$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) = @_; + + close($fh); +} + +################################################ +## Normal I/O functions. +## + +# flock +# select + +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 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>; +} + +*gets = \&getline; # deprecated + +sub getlines { + @_ == 1 or croak 'usage: $fh->getline()'; + wantarray or + croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline'; + my $this = shift; + 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 sysread { + @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])'; + sysread($_[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 syswrite { + @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])'; + syswrite($_[0], $_[1], $_[2], $_[3] || 0); +} + +sub stat { + @_ == 1 or croak 'usage: $fh->stat()'; + stat($_[0]); +} + +################################################ +## State modification functions. +## + +sub autoflush { + my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $|; + $| = @_ > 1 ? $_[1] : 1; + $prev; +} + +sub output_field_separator { + my $prev = $,; + $, = $_[1] if @_ > 1; + $prev; +} + +sub output_record_separator { + my $prev = $\; + $\ = $_[1] if @_ > 1; + $prev; +} + +sub input_record_separator { + my $prev = $/; + $/ = $_[1] if @_ > 1; + $prev; +} + +sub input_line_number { + # localizing $. doesn't work as advertised. grrrrrr. + my $prev = $.; + $. = $_[1] if @_ > 1; + $prev; +} + +sub format_page_number { + my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $%; + $% = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_per_page { + my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $=; + $= = $_[1] if @_ > 1; + $prev; +} + +sub format_lines_left { + my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $-; + $- = $_[1] if @_ > 1; + $prev; +} + +sub format_name { + my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $~; + $~ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_top_name { + my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $prev = $^; + $^ = qualify($_[1], caller) if @_ > 1; + $prev; +} + +sub format_line_break_characters { + my $prev = $:; + $: = $_[1] if @_ > 1; + $prev; +} + +sub format_formfeed { + 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); + CORE::write($fh); + $fh->format_name($oldfmt); + } else { + CORE::write($_[0]); + } +} + +sub fcntl { + @_ == 3 || croak 'usage: $fh->fcntl( OP, VALUE );'; + my ($fh, $op, $val) = @_; + my $r = fcntl($fh, $op, $val); + defined $r && $r eq "0 but true" ? 0 : $r; +} + +sub ioctl { + @_ == 3 || croak 'usage: $fh->ioctl( OP, VALUE );'; + my ($fh, $op, $val) = @_; + my $r = ioctl($fh, $op, $val); + defined $r && $r eq "0 but true" ? 0 : $r; +} + +1; diff --git a/contrib/perl5/ext/IO/lib/IO/Pipe.pm b/contrib/perl5/ext/IO/lib/IO/Pipe.pm new file mode 100644 index 0000000..ae6d9a5 --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Pipe.pm @@ -0,0 +1,239 @@ +# 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.0901"; + +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); + $fh->close; + + 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 + +=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<IO::Pipe> provides an interface to createing pipes between +processes. + +=head1 CONSTRCUTOR + +=over 4 + +=item new ( [READER, WRITER] ) + +Creates a C<IO::Pipe>, which is a reference to a newly created symbol +(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two +arguments, which should be objects blessed into C<IO::Handle>, or a +subclass thereof. These two objects will be used for the system call +to C<pipe>. If no arguments are given then method C<handles> is called +on the new C<IO::Pipe> object. + +These two handles are held in the array part of the GLOB until either +C<reader> or C<writer> is called. + +=back + +=head1 METHODS + +=over 4 + +=item reader ([ARGS]) + +The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a +handle at the reading end of the pipe. If C<ARGS> are given then C<fork> +is called and C<ARGS> are passed to exec. + +=item writer ([ARGS]) + +The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a +handle at the writing end of the pipe. If C<ARGS> are given then C<fork> +is called and C<ARGS> are passed to exec. + +=item handles () + +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::Pipe::End>, or a subclass thereof. + +=back + +=head1 SEE ALSO + +L<IO::Handle> + +=head1 AUTHOR + +Graham Barr <bodg@tiuk.ti.com> + +=head1 COPYRIGHT + +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 diff --git a/contrib/perl5/ext/IO/lib/IO/Seekable.pm b/contrib/perl5/ext/IO/lib/IO/Seekable.pm new file mode 100644 index 0000000..91c381a --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Seekable.pm @@ -0,0 +1,68 @@ +# + +package IO::Seekable; + +=head1 NAME + +IO::Seekable - supply seek based methods for I/O objects + +=head1 SYNOPSIS + + use IO::Seekable; + package IO::Something; + @ISA = qw(IO::Seekable); + +=head1 DESCRIPTION + +C<IO::Seekable> does not have a constuctor of its own as is intended to +be inherited by other C<IO::Handle> based objects. It provides methods +which allow seeking of the file descriptors. + +If the C functions fgetpos() and fsetpos() are available, then +C<IO::File::getpos> returns an opaque value that represents the +current position of the IO::File, and C<IO::File::setpos> uses +that value to return to a previously visited position. + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Seekable> methods, which are just front ends for the +corresponding built-in functions: + + seek + tell + +=head1 SEE ALSO + +L<perlfunc>, +L<perlop/"I/O Operators">, +L<IO::Handle> +L<IO::File> + +=head1 HISTORY + +Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt> + +=cut + +require 5.000; +use Carp; +use strict; +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 = "1.06"; + +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/contrib/perl5/ext/IO/lib/IO/Select.pm b/contrib/perl5/ext/IO/lib/IO/Select.pm new file mode 100644 index 0000000..dea684a --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Select.pm @@ -0,0 +1,371 @@ +# IO::Select.pm +# +# 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. + +package IO::Select; + +=head1 NAME + +IO::Select - OO interface to the select system call + +=head1 SYNOPSIS + + 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<IO::Select> package implements an object approach to the system C<select> +function call. It allows the user to see what IO handles, see L<IO::Handle>, +are ready for reading, writing or have an error condition pending. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ HANDLES ] ) + +The constructor creates a new object and optionally initialises it with a set +of handles. + +=back + +=head1 METHODS + +=over 4 + +=item add ( HANDLES ) + +Add the list of handles to the C<IO::Select> object. It is these values that +will be returned when an event occurs. C<IO::Select> keeps these values in a +cache which is indexed by the C<fileno> of the handle, so if more than one +handle with the same C<fileno> is specified then only the last one is cached. + +Each handle can be an C<IO::Handle> object, an integer or an array +reference where the first element is a C<IO::Handle> or an integer. + +=item remove ( HANDLES ) + +Remove all the given handles from the object. This method also works +by the C<fileno> of the handles. So the exact handles that were added +need not be passed, just handles that have an equivalent C<fileno> + +=item exists ( HANDLE ) + +Returns a true value (actually the handle itself) if it is present. +Returns undef otherwise. + +=item handles + +Return an array of all registered handles. + +=item can_read ( [ TIMEOUT ] ) + +Return an array of handles that are ready for reading. C<TIMEOUT> is +the maximum amount of time to wait before returning an empty list. If +C<TIMEOUT> is not given and any handles are registered then the call +will block. + +=item can_write ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that can be written to. + +=item has_error ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that have an error +condition, for example EOF. + +=item count () + +Returns the number of handles that the object will check for when +one of the C<can_> methods is called or the object is passed to +the C<select> static method. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item bits() + +Return the bit string suitable as argument to the core select() call. + +=item select ( READ, WRITE, ERROR [, TIMEOUT ] ) + +C<select> is a static method, that is you call it with the package +name like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef> +or C<IO::Select> objects. C<TIMEOUT> is optional and has the same +effect as for the core select call. + +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<IO::Select> 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 E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> + +=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 = "1.10"; + +@ISA = qw(Exporter); # This is only so we can do version checking + +sub VEC_BITS () {0} +sub FD_COUNT () {1} +sub FIRST_FD () {2} + +sub new +{ + my $self = shift; + my $type = ref($self) || $self; + + my $vec = bless [undef,0], $type; + + $vec->add(@_) + if @_; + + $vec; +} + +sub add +{ + shift->_update('add', @_); +} + + +sub remove +{ + shift->_update('remove', @_); +} + + +sub exists +{ + my $vec = shift; + $vec->[$vec->_fileno(shift) + FIRST_FD]; +} + + +sub _fileno +{ + my($self, $f) = @_; + $f = $f->[0] if ref($f) eq 'ARRAY'; + ($f =~ /^\d+$/) ? $f : fileno($f); +} + +sub _update +{ + my $vec = shift; + my $add = shift eq 'add'; + + my $bits = $vec->[VEC_BITS]; + $bits = '' unless defined $bits; + + my $count = 0; + my $f; + foreach $f (@_) + { + my $fn = $vec->_fileno($f); + next unless defined $fn; + my $i = $fn + FIRST_FD; + if ($add) { + if (defined $vec->[$i]) { + $vec->[$i] = $f; # if array rest might be different, so we update + next; + } + $vec->[FD_COUNT]++; + vec($bits, $fn, 1) = 1; + $vec->[$i] = $f; + } else { # remove + next unless defined $vec->[$i]; + $vec->[FD_COUNT]--; + vec($bits, $fn, 1) = 0; + $vec->[$i] = undef; + } + $count++; + } + $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef; + $count; +} + +sub can_read +{ + my $vec = shift; + my $timeout = shift; + my $r = $vec->[VEC_BITS]; + + defined($r) && (select($r,undef,undef,$timeout) > 0) + ? handles($vec, $r) + : (); +} + +sub can_write +{ + my $vec = shift; + my $timeout = shift; + my $w = $vec->[VEC_BITS]; + + defined($w) && (select(undef,$w,undef,$timeout) > 0) + ? handles($vec, $w) + : (); +} + +sub has_error +{ + my $vec = shift; + my $timeout = shift; + my $e = $vec->[VEC_BITS]; + + defined($e) && (select(undef,undef,$e,$timeout) > 0) + ? handles($vec, $e) + : (); +} + +sub count +{ + my $vec = shift; + $vec->[FD_COUNT]; +} + +sub bits +{ + my $vec = shift; + $vec->[VEC_BITS]; +} + +sub as_string # for debugging +{ + my $vec = shift; + my $str = ref($vec) . ": "; + my $bits = $vec->bits; + my $count = $vec->count; + $str .= defined($bits) ? unpack("b*", $bits) : "undef"; + $str .= " $count"; + my @handles = @$vec; + splice(@handles, 0, FIRST_FD); + for (@handles) { + $str .= " " . (defined($_) ? "$_" : "-"); + } + $str; +} + +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->[VEC_BITS] : undef; + my $wb = defined $w ? $w->[VEC_BITS] : undef; + my $eb = defined $e ? $e->[VEC_BITS] : undef; + + if(select($rb,$wb,$eb,$t) > 0) + { + my @r = (); + my @w = (); + my @e = (); + my $i = _max(defined $r ? scalar(@$r)-1 : 0, + defined $w ? scalar(@$w)-1 : 0, + defined $e ? scalar(@$e)-1 : 0); + + for( ; $i >= FIRST_FD ; $i--) + { + my $j = $i - FIRST_FD; + push(@r, $r->[$i]) + if defined $rb && defined $r->[$i] && vec($rb, $j, 1); + push(@w, $w->[$i]) + if defined $wb && defined $w->[$i] && vec($wb, $j, 1); + push(@e, $e->[$i]) + if defined $eb && defined $e->[$i] && vec($eb, $j, 1); + } + + @result = (\@r, \@w, \@e); + } + @result; +} + + +sub handles +{ + my $vec = shift; + my $bits = shift; + my @h = (); + my $i; + my $max = scalar(@$vec) - 1; + + for ($i = FIRST_FD; $i <= $max; $i++) + { + next unless defined $vec->[$i]; + push(@h, $vec->[$i]) + if !defined($bits) || vec($bits, $i - FIRST_FD, 1); + } + + @h; +} + +1; diff --git a/contrib/perl5/ext/IO/lib/IO/Socket.pm b/contrib/perl5/ext/IO/lib/IO/Socket.pm new file mode 100644 index 0000000..406f74d --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Socket.pm @@ -0,0 +1,728 @@ +# 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; + +=head1 NAME + +IO::Socket - Object interface to socket communications + +=head1 SYNOPSIS + + use IO::Socket; + +=head1 DESCRIPTION + +C<IO::Socket> provides an object interface to creating and using sockets. It +is built upon the L<IO::Handle> interface and inherits all the methods defined +by L<IO::Handle>. + +C<IO::Socket> 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<IO::Socket> + +C<IO::Socket> will export all functions (and constants) defined by L<Socket>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Socket>, which is a reference to a +newly created symbol (see the C<Symbol> package). C<new> +optionally takes arguments, these arguments are in key-value pairs. +C<new> only looks for one key C<Domain> which tells new which domain +the socket will be in. All other arguments will be passed to the +configuration method of the package for that domain, See below. + +C<IO::Socket>s will be in autoflush mode after creation. Note that +versions of IO::Socket prior to 1.1603 (as shipped with Perl 5.004_04) +did not do this. So if you need backward compatibility, you should +set autoflush explicitly. + +=back + +=head1 METHODS + +See L<perlfunc> for complete descriptions of each of the following +supported C<IO::Socket> 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<perlfunc> +in attempt to make the interface more flexible. These are + +=over 4 + +=item accept([PKG]) + +perform the system call C<accept> on the socket and return a new object. The +new object will be created in the same class as the listen socket, unless +C<PKG> 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. + +=item sockdomain + +Returns the numerical number for the socket domain type. For example, for +a AF_INET socket the value of &AF_INET will be returned. + +=item socktype + +Returns the numerical number for the socket type. For example, for +a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. + +=item protocol + +Returns the numerical number for the protocol being used on the socket, if +known. If the protocol is unknown, as with an AF_UNIX socket, zero +is returned. + +=back + +=cut + + +require 5.000; + +use Config; +use IO::Handle; +use Socket 1.3; +use Carp; +use strict; +use vars qw(@ISA $VERSION); +use Exporter; + +@ISA = qw(IO::Handle); + +$VERSION = "1.1603"; + +sub import { + my $pkg = shift; + my $callpkg = caller; + Exporter::export 'Socket', $callpkg, @_; +} + +sub new { + my($class,%arg) = @_; + my $fh = $class->SUPER::new(); + $fh->autoflush; + + ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout}; + + return scalar(%arg) ? $fh->configure(\%arg) + : $fh; +} + +my @domain2pkg = (); + +sub register_domain { + my($p,$d) = @_; + $domain2pkg[$d] = $p; +} + +sub configure { + my($fh,$arg) = @_; + my $domain = delete $arg->{Domain}; + + croak 'IO::Socket: Cannot configure a generic socket' + unless defined $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, $domain2pkg[$domain]); + $fh->configure($arg); +} + +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_domain'} = $domain; + ${*$fh}{'io_socket_type'} = $type; + ${*$fh}{'io_socket_proto'} = $protocol; + + $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,$fh2,$domain,$type,$protocol) or + return (); + + ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type; + ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol; + + ($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 = 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 = defined(getpeername($fh)) + ? send($fh, $_[1], $flags) + : 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 sockdomain { + @_ == 1 or croak 'usage: $fh->sockdomain()'; + my $fh = shift; + ${*$fh}{'io_socket_domain'}; +} + +sub socktype { + @_ == 1 or croak 'usage: $fh->socktype()'; + my $fh = shift; + ${*$fh}{'io_socket_type'} +} + +sub protocol { + @_ == 1 or croak 'usage: $fh->protocol()'; + my($fh) = @_; + ${*$fh}{'io_socket_protocol'}; +} + +=head1 SUB-CLASSES + +=cut + +## +## AF_INET +## + +package IO::Socket::INET; + +use strict; +use vars qw(@ISA); +use Socket; +use Carp; +use Exporter; + +@ISA = qw(IO::Socket); + +IO::Socket::INET->register_domain( AF_INET ); + +my %socket_type = ( tcp => SOCK_STREAM, + udp => SOCK_DGRAM, + icmp => SOCK_RAW, + ); + +=head2 IO::Socket::INET + +C<IO::Socket::INET> 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 <hostname>[:<port>] + PeerPort Remote port or service <service>[(<no>)] | <no> + LocalAddr Local host bind address hostname[:port] + LocalPort Local host bind port <service>[(<no>)] | <no> + Proto Protocol name (or number) "tcp" | "udp" | ... + Type Socket type SOCK_STREAM | SOCK_DGRAM | ... + Listen Queue size for listen + Reuse Set SO_REUSEADDR before binding + Timeout Timeout value for various operations + + +If C<Listen> is defined then a listen socket is created, else if the +socket type, which is derived from the protocol, is SOCK_STREAM then +connect() is called. + +The C<PeerAddr> can be a hostname or the IP-address on the +"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic +service name. The service name might be followed by a number in +parenthesis which is used if the service is not known by the system. +The C<PeerPort> specification can also be embedded in the C<PeerAddr> +by preceding it with a ":". + +If C<Proto> is not given and you specify a symbolic C<PeerPort> port, +then the constructor will try to derive C<Proto> from the service +name. As a last resort C<Proto> "tcp" is assumed. The C<Type> +parameter will be deduced from C<Proto> if not specified. + +If the constructor is only passed a single argument, it is assumed to +be a C<PeerAddr> specification. + +Examples: + + $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', + PeerPort => 'http(80)', + Proto => 'tcp'); + + $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)'); + + $sock = IO::Socket::INET->new(Listen => 5, + LocalAddr => 'localhost', + LocalPort => 9000, + Proto => 'tcp'); + + $sock = IO::Socket::INET->new('127.0.0.1:25'); + + +=head2 METHODS + +=over 4 + +=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 () + +Return the address part of the sockaddr structure for the socket on +the peer host + +=item peerport () + +Return the port number for the socket on the peer host. + +=item peerhost () + +Return the address part of the sockaddr structure for the socket on the +peer host in a text form xx.xx.xx.xx + +=back + +=cut + +sub new +{ + my $class = shift; + unshift(@_, "PeerAddr") if @_ == 1; + return $class->SUPER::new(@_); +} + +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 _error { + my $fh = shift; + $@ = join("",ref($fh),": ",@_); + carp $@ if $^W; + close($fh) + if(defined fileno($fh)); + return 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; + + return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'") + unless(defined $laddr); + + unless(exists $arg->{Listen}) { + ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr}, + $arg->{PeerPort}, + $proto); + } + + if(defined $raddr) { + $raddr = inet_aton($raddr); + return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'") + unless(defined $raddr); + } + + $proto ||= (getprotobyname "tcp")[2]; + return _error($fh,'Cannot determine protocol') + unless($proto); + + my $pname = (getprotobynumber($proto))[0]; + $type = $arg->{Type} || $socket_type{$pname}; + + $fh->socket(AF_INET, $type, $proto) or + return _error($fh,"$!"); + + if ($arg->{Reuse}) { + $fh->sockopt(SO_REUSEADDR,1) or + return _error($fh); + } + + $fh->bind($lport || 0, $laddr) or + return _error($fh,"$!"); + + if(exists $arg->{Listen}) { + $fh->listen($arg->{Listen} || 5) or + return _error($fh,"$!"); + } + else { + return _error($fh,'Cannot determine remote port') + unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW); + + if($type == SOCK_STREAM || defined $raddr) { + return _error($fh,'Bad peer address') + unless(defined $raddr); + + $fh->connect($rport,$raddr) or + return _error($fh,"$!"); + } + } + + $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); + +IO::Socket::UNIX->register_domain( AF_UNIX ); + +=head2 IO::Socket::UNIX + +C<IO::Socket::UNIX> 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 + +=over 4 + +=item hostpath() + +Returns the pathname to the fifo at the local end + +=item peerpath() + +Returns the pathanme to the fifo at the peer end + +=back + +=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()'; + my $n = $_[0]->sockname || return undef; + (sockaddr_un($n))[0]; +} + +sub peerpath { + @_ == 1 or croak 'usage: $fh->peerpath()'; + my $n = $_[0]->peername || return undef; + (sockaddr_un($n))[0]; +} + +=head1 SEE ALSO + +L<Socket>, L<IO::Handle> + +=head1 AUTHOR + +Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> + +=head1 COPYRIGHT + +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 + +1; # Keep require happy |