diff options
Diffstat (limited to 'contrib/perl5/ext/IO/lib')
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Dir.pm | 239 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/File.pm | 32 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Handle.pm | 311 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Pipe.pm | 41 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Poll.pm | 205 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Seekable.pm | 31 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Select.pm | 315 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Socket.pm | 748 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Socket/INET.pm | 406 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm | 143 |
10 files changed, 1626 insertions, 845 deletions
diff --git a/contrib/perl5/ext/IO/lib/IO/Dir.pm b/contrib/perl5/ext/IO/lib/IO/Dir.pm new file mode 100644 index 0000000..1fa07ed --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Dir.pm @@ -0,0 +1,239 @@ +# IO::Dir.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.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::Dir; + +use 5.003_26; + +use strict; +use Carp; +use Symbol; +use Exporter; +use IO::File; +our(@ISA, $VERSION, @EXPORT_OK); +use Tie::Hash; +use File::stat; + +@ISA = qw(Tie::Hash Exporter); +$VERSION = "1.03"; +@EXPORT_OK = qw(DIR_UNLINK); + +sub DIR_UNLINK () { 1 } + +sub new { + @_ >= 1 && @_ <= 2 or croak 'usage: new IO::Dir [DIRNAME]'; + my $class = shift; + my $dh = gensym; + if (@_) { + IO::Dir::open($dh, $_[0]) + or return undef; + } + bless $dh, $class; +} + +sub DESTROY { + my ($dh) = @_; + closedir($dh); +} + +sub open { + @_ == 2 or croak 'usage: $dh->open(DIRNAME)'; + my ($dh, $dirname) = @_; + return undef + unless opendir($dh, $dirname); + ${*$dh}{io_dir_path} = $dirname; + 1; +} + +sub close { + @_ == 1 or croak 'usage: $dh->close()'; + my ($dh) = @_; + closedir($dh); +} + +sub read { + @_ == 1 or croak 'usage: $dh->read()'; + my ($dh) = @_; + readdir($dh); +} + +sub seek { + @_ == 2 or croak 'usage: $dh->seek(POS)'; + my ($dh,$pos) = @_; + seekdir($dh,$pos); +} + +sub tell { + @_ == 1 or croak 'usage: $dh->tell()'; + my ($dh) = @_; + telldir($dh); +} + +sub rewind { + @_ == 1 or croak 'usage: $dh->rewind()'; + my ($dh) = @_; + rewinddir($dh); +} + +sub TIEHASH { + my($class,$dir,$options) = @_; + + my $dh = $class->new($dir) + or return undef; + + $options ||= 0; + + ${*$dh}{io_dir_unlink} = $options & DIR_UNLINK; + $dh; +} + +sub FIRSTKEY { + my($dh) = @_; + $dh->rewind; + scalar $dh->read; +} + +sub NEXTKEY { + my($dh) = @_; + scalar $dh->read; +} + +sub EXISTS { + my($dh,$key) = @_; + -e ${*$dh}{io_dir_path} . "/" . $key; +} + +sub FETCH { + my($dh,$key) = @_; + &lstat(${*$dh}{io_dir_path} . "/" . $key); +} + +sub STORE { + my($dh,$key,$data) = @_; + my($atime,$mtime) = ref($data) ? @$data : ($data,$data); + my $file = ${*$dh}{io_dir_path} . "/" . $key; + unless(-e $file) { + my $io = IO::File->new($file,O_CREAT | O_RDWR); + $io->close if $io; + } + utime($atime,$mtime, $file); +} + +sub DELETE { + my($dh,$key) = @_; + # Only unlink if unlink-ing is enabled + my $file = ${*$dh}{io_dir_path} . "/" . $key; + + return 0 + unless ${*$dh}{io_dir_unlink}; + + -d $file + ? rmdir($file) + : unlink($file); +} + +1; + +__END__ + +=head1 NAME + +IO::Dir - supply object methods for directory handles + +=head1 SYNOPSIS + + use IO::Dir; + $d = new IO::Dir "."; + if (defined $d) { + while (defined($_ = $d->read)) { something($_); } + $d->rewind; + while (defined($_ = $d->read)) { something_else($_); } + undef $d; + } + + tie %dir, IO::Dir, "."; + foreach (keys %dir) { + print $_, " " , $dir{$_}->size,"\n"; + } + +=head1 DESCRIPTION + +The C<IO::Dir> package provides two interfaces to perl's directory reading +routines. + +The first interface is an object approach. C<IO::Dir> provides an object +constructor and methods, which are just wrappers around perl's built in +directory reading routines. + +=over 4 + +=item new ( [ DIRNAME ] ) + +C<new> is the constuctor for C<IO::Dir> objects. It accepts one optional +argument which, if given, C<new> will pass to C<open> + +=back + +The following methods are wrappers for the directory related functions built +into perl (the trailing `dir' has been removed from the names). See L<perlfunc> +for details of these functions. + +=over 4 + +=item open ( DIRNAME ) + +=item read () + +=item seek ( POS ) + +=item tell () + +=item rewind () + +=item close () + +=back + +C<IO::Dir> also provides a interface to reading directories via a tied +HASH. The tied HASH extends the interface beyond just the directory +reading routines by the use of C<lstat>, from the C<File::stat> package, +C<unlink>, C<rmdir> and C<utime>. + +=over 4 + +=item tie %hash, IO::Dir, DIRNAME [, OPTIONS ] + +=back + +The keys of the HASH will be the names of the entries in the directory. +Reading a value from the hash will be the result of calling +C<File::stat::lstat>. Deleting an element from the hash will call C<unlink> +providing that C<DIR_UNLINK> is passed in the C<OPTIONS>. + +Assigning to an entry in the HASH will cause the time stamps of the file +to be modified. If the file does not exist then it will be created. Assigning +a single integer to a HASH element will cause both the access and +modification times to be changed to that value. Alternatively a reference to +an array of two values can be passed. The first array element will be used to +set the access time and the second element will be used to set the modification +time. + +=head1 SEE ALSO + +L<File::stat> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. 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/File.pm b/contrib/perl5/ext/IO/lib/IO/File.pm index de7fabc..569c280 100644 --- a/contrib/perl5/ext/IO/lib/IO/File.pm +++ b/contrib/perl5/ext/IO/lib/IO/File.pm @@ -49,7 +49,7 @@ these classes with methods that are specific to file handles. =over 4 -=item new ([ ARGS ] ) +=item new ( FILENAME [,MODE [,PERMS]] ) 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, @@ -72,20 +72,21 @@ Otherwise, it is returned to the caller. =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 +it is just a front end for the built-in C<open> function. With two or three 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. +or a ANSI C fopen() mode string ("w", "r+", etc.), it uses the basic +Perl C<open> operator (but protects any special characters). 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. +The permissions default to 0666. + +For convenience, C<IO::File> exports the O_XXX constants from the +Fcntl module, if this module is available. =back @@ -98,24 +99,24 @@ L<IO::Seekable> =head1 HISTORY -Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>. +Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt>. =cut -require 5.000; +require 5.005_64; use strict; -use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA); +our($VERSION, @EXPORT, @EXPORT_OK, @ISA); use Carp; use Symbol; use SelectSaver; use IO::Seekable; +use File::Spec; require Exporter; -require DynaLoader; -@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader); +@ISA = qw(IO::Handle IO::Seekable Exporter); -$VERSION = "1.06021"; +$VERSION = "1.08"; @EXPORT = @IO::Seekable::EXPORT; @@ -127,7 +128,6 @@ eval { push(@EXPORT, @O); }; - ################################################ ## Constructor ## @@ -158,7 +158,9 @@ sub open { defined $perms or $perms = 0666; return sysopen($fh, $file, $mode, $perms); } - $file = './' . $file if $file =~ m{\A[^\\/\w]}; + if (! File::Spec->file_name_is_absolute($file)) { + $file = File::Spec->catfile(File::Spec->curdir(),$file); + } $file = IO::Handle::_open_mode_string($mode) . " $file\0"; } open($fh, $file); diff --git a/contrib/perl5/ext/IO/lib/IO/Handle.pm b/contrib/perl5/ext/IO/lib/IO/Handle.pm index 7927641..930df55 100644 --- a/contrib/perl5/ext/IO/lib/IO/Handle.pm +++ b/contrib/perl5/ext/IO/lib/IO/Handle.pm @@ -9,21 +9,21 @@ IO::Handle - supply object methods for I/O handles use IO::Handle; - $fh = new IO::Handle; - if ($fh->fdopen(fileno(STDIN),"r")) { - print $fh->getline; - $fh->close; + $io = new IO::Handle; + if ($io->fdopen(fileno(STDIN),"r")) { + print $io->getline; + $io->close; } - $fh = new IO::Handle; - if ($fh->fdopen(fileno(STDOUT),"w")) { - $fh->print("Some text\n"); + $io = new IO::Handle; + if ($io->fdopen(fileno(STDOUT),"w")) { + $io->print("Some text\n"); } use IO::Handle '_IOLBF'; - $fh->setvbuf($buffer_var, _IOLBF, 1024); + $io->setvbuf($buffer_var, _IOLBF, 1024); - undef $fh; # automatically closes the file if it's open + undef $io; # automatically closes the file if it's open autoflush STDOUT 1; @@ -36,9 +36,7 @@ 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) +for C<IO::File> too. =head1 CONSTRUCTOR @@ -63,87 +61,123 @@ 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 + $io->close + $io->eof + $io->fileno + $io->format_write( [FORMAT_NAME] ) + $io->getc + $io->read ( BUF, LEN, [OFFSET] ) + $io->print ( ARGS ) + $io->printf ( FMT, [ARGS] ) + $io->stat + $io->sysread ( BUF, LEN, [OFFSET] ) + $io->syswrite ( BUF, LEN, [OFFSET] ) + $io->truncate ( LEN ) See L<perlvar> for complete descriptions of each of the following -supported C<IO::Handle> methods: +supported C<IO::Handle> methods. All of them return the previous +value of the attribute and takes an optional single argument that when +given will set the value. If no argument is given the previous value +is unchanged (except for $io->autoflush will actually turn ON +autoflush by default). - 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 + $io->autoflush ( [BOOL] ) $| + $io->format_page_number( [NUM] ) $% + $io->format_lines_per_page( [NUM] ) $= + $io->format_lines_left( [NUM] ) $- + $io->format_name( [STR] ) $~ + $io->format_top_name( [STR] ) $^ + $io->input_line_number( [NUM]) $. + +The following methods are not supported on a per-filehandle basis. + + IO::Handle->format_line_break_characters( [STR] ) $: + IO::Handle->format_formfeed( [STR]) $^L + IO::Handle->output_field_separator( [STR] ) $, + IO::Handle->output_record_separator( [STR] ) $\ + + IO::Handle->input_record_separator( [STR] ) $/ Furthermore, for doing normal I/O you might need these: =over -=item $fh->fdopen ( FD, MODE ) +=item $io->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 +=item $io->opened Returns true if the object is currently a valid file descriptor. -=item $fh->getline +=item $io->getline -This works like <$fh> described in L<perlop/"I/O Operators"> +This works like <$io> 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 +=item $io->getlines -This works like <$fh> when called in an array context to +This works like <$io> 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 ) +=item $io->ungetc ( ORD ) Pushes a character with the given ordinal value back onto the given -handle's input stream. +handle's input stream. Only one character of pushback per handle is +guaranteed. -=item $fh->write ( BUF, LEN [, OFFSET }\] ) +=item $io->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 +=item $io->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 +=item $io->clearerr Clear the given handle's error indicator. +=item $io->sync + +C<sync> synchronizes a file's in-memory state with that on the +physical medium. C<sync> does not operate at the perlio api level, but +operates on the file descriptor, this means that any data held at the +perlio api level will not be synchronized. To synchronize data that is +buffered at the perlio api level you must use the flush method. C<sync> +is not implemented on all platforms. See L<fsync(3c)>. + +=item $io->flush + +C<flush> causes perl to flush any buffered data at the perlio api level. +Any unread data in the buffer will be discarded, and any unwritten data +will be written to the underlying file descriptor. + +=item $io->printflush ( ARGS ) + +Turns on autoflush, print ARGS and then restores the autoflush status of the +C<IO::Handle> object. + +=item $io->blocking ( [ BOOL ] ) + +If called with an argument C<blocking> will turn on non-blocking IO if +C<BOOL> is false, and turn it off if C<BOOL> is true. + +C<blocking> will return the value of the previous setting, or the +current setting if C<BOOL> is not given. + +If an error occurs C<blocking> will return undef and C<$!> will be set. + =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 @@ -152,7 +186,7 @@ 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 +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 @@ -160,7 +194,7 @@ scripts: =over -=item $fh->untaint +=item $io->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 @@ -171,7 +205,8 @@ vulnerability should be kept in mind. =head1 NOTE -A C<IO::Handle> object is a GLOB reference. Some modules that +A C<IO::Handle> object is a reference to a symbol/GLOB reference (see +the C<Symbol> package). 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 @@ -193,22 +228,22 @@ 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> +Derived from FileHandle.pm by Graham Barr E<lt>F<gbarr@pobox.com>E<gt> =cut -require 5.000; +require 5.005_64; use strict; -use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA); +our($VERSION, @EXPORT_OK, @ISA); use Carp; use Symbol; use SelectSaver; +use IO (); # Load the XS module require Exporter; @ISA = qw(Exporter); -$VERSION = "1.1505"; -$XS_VERSION = "1.15"; +$VERSION = "1.21"; @EXPORT_OK = qw( autoflush @@ -230,6 +265,9 @@ $XS_VERSION = "1.15"; getline getlines + printflush + flush + SEEK_SET SEEK_CUR SEEK_END @@ -238,30 +276,6 @@ $XS_VERSION = "1.15"; _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. ## @@ -269,18 +283,18 @@ sub AUTOLOAD { sub new { my $class = ref($_[0]) || $_[0] || "IO::Handle"; @_ == 1 or croak "usage: new $class"; - my $fh = gensym; - bless $fh, $class; + my $io = gensym; + bless $io, $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; + my $io = gensym; shift; - IO::Handle::fdopen($fh, @_) + IO::Handle::fdopen($io, @_) or return undef; - bless $fh, $class; + bless $io, $class; } # @@ -307,8 +321,8 @@ sub _open_mode_string { } sub fdopen { - @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)'; - my ($fh, $fd, $mode) = @_; + @_ == 3 or croak 'usage: $io->fdopen(FD, MODE)'; + my ($io, $fd, $mode) = @_; local(*GLOB); if (ref($fd) && "".$fd =~ /GLOB\(/o) { @@ -321,15 +335,15 @@ sub fdopen { $fd = "=$fd"; } - open($fh, _open_mode_string($mode) . '&' . $fd) - ? $fh : undef; + open($io, _open_mode_string($mode) . '&' . $fd) + ? $io : undef; } sub close { - @_ == 1 or croak 'usage: $fh->close()'; - my($fh) = @_; + @_ == 1 or croak 'usage: $io->close()'; + my($io) = @_; - close($fh); + close($io); } ################################################ @@ -340,39 +354,39 @@ sub close { # select sub opened { - @_ == 1 or croak 'usage: $fh->opened()'; + @_ == 1 or croak 'usage: $io->opened()'; defined fileno($_[0]); } sub fileno { - @_ == 1 or croak 'usage: $fh->fileno()'; + @_ == 1 or croak 'usage: $io->fileno()'; fileno($_[0]); } sub getc { - @_ == 1 or croak 'usage: $fh->getc()'; + @_ == 1 or croak 'usage: $io->getc()'; getc($_[0]); } sub eof { - @_ == 1 or croak 'usage: $fh->eof()'; + @_ == 1 or croak 'usage: $io->eof()'; eof($_[0]); } sub print { - @_ or croak 'usage: $fh->print([ARGS])'; + @_ or croak 'usage: $io->print(ARGS)'; my $this = shift; print $this @_; } sub printf { - @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])'; + @_ >= 2 or croak 'usage: $io->printf(FMT,[ARGS])'; my $this = shift; printf $this @_; } sub getline { - @_ == 1 or croak 'usage: $fh->getline'; + @_ == 1 or croak 'usage: $io->getline()'; my $this = shift; return scalar <$this>; } @@ -380,41 +394,43 @@ sub getline { *gets = \&getline; # deprecated sub getlines { - @_ == 1 or croak 'usage: $fh->getline()'; + @_ == 1 or croak 'usage: $io->getlines()'; wantarray or - croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline'; + croak 'Can\'t call $io->getlines in a scalar context, use $io->getline'; my $this = shift; return <$this>; } sub truncate { - @_ == 2 or croak 'usage: $fh->truncate(LEN)'; + @_ == 2 or croak 'usage: $io->truncate(LEN)'; truncate($_[0], $_[1]); } sub read { - @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])'; + @_ == 3 || @_ == 4 or croak 'usage: $io->read(BUF, LEN [, OFFSET])'; read($_[0], $_[1], $_[2], $_[3] || 0); } sub sysread { - @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])'; + @_ == 3 || @_ == 4 or croak 'usage: $io->sysread(BUF, LEN [, OFFSET])'; sysread($_[0], $_[1], $_[2], $_[3] || 0); } sub write { - @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])'; + @_ >= 2 && @_ <= 4 or croak 'usage: $io->write(BUF [, LEN [, OFFSET]])'; local($\) = ""; + $_[2] = length($_[1]) unless defined $_[2]; print { $_[0] } substr($_[1], $_[3] || 0, $_[2]); } sub syswrite { - @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])'; + @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])'; + $_[2] = length($_[1]) unless defined $_[2]; syswrite($_[0], $_[1], $_[2], $_[3] || 0); } sub stat { - @_ == 1 or croak 'usage: $fh->stat()'; + @_ == 1 or croak 'usage: $io->stat()'; stat($_[0]); } @@ -423,32 +439,39 @@ sub stat { ## sub autoflush { - my $old = new SelectSaver qualify($_[0], caller) if ref($_[0]); + my $old = new SelectSaver qualify($_[0], caller); my $prev = $|; $| = @_ > 1 ? $_[1] : 1; $prev; } sub output_field_separator { + carp "output_field_separator is not supported on a per-handle basis" + if ref($_[0]); my $prev = $,; $, = $_[1] if @_ > 1; $prev; } sub output_record_separator { + carp "output_record_separator is not supported on a per-handle basis" + if ref($_[0]); my $prev = $\; $\ = $_[1] if @_ > 1; $prev; } sub input_record_separator { + carp "input_record_separator is not supported on a per-handle basis" + if ref($_[0]); my $prev = $/; $/ = $_[1] if @_ > 1; $prev; } sub input_line_number { - # localizing $. doesn't work as advertised. grrrrrr. + local $.; + my $tell = tell qualify($_[0], caller) if ref($_[0]); my $prev = $.; $. = $_[1] if @_ > 1; $prev; @@ -490,50 +513,82 @@ sub format_top_name { } sub format_line_break_characters { + carp "format_line_break_characters is not supported on a per-handle basis" + if ref($_[0]); my $prev = $:; $: = $_[1] if @_ > 1; $prev; } sub format_formfeed { + carp "format_formfeed is not supported on a per-handle basis" + if ref($_[0]); my $prev = $^L; $^L = $_[1] if @_ > 1; $prev; } sub formline { - my $fh = shift; + my $io = shift; my $picture = shift; local($^A) = $^A; local($\) = ""; formline($picture, @_); - print $fh $^A; + print $io $^A; } sub format_write { - @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )'; + @_ < 3 || croak 'usage: $io->write( [FORMAT_NAME] )'; if (@_ == 2) { - my ($fh, $fmt) = @_; - my $oldfmt = $fh->format_name($fmt); - CORE::write($fh); - $fh->format_name($oldfmt); + my ($io, $fmt) = @_; + my $oldfmt = $io->format_name($fmt); + CORE::write($io); + $io->format_name($oldfmt); } else { CORE::write($_[0]); } } +# XXX undocumented 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; + @_ == 3 || croak 'usage: $io->fcntl( OP, VALUE );'; + my ($io, $op) = @_; + return fcntl($io, $op, $_[2]); } +# XXX undocumented 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; + @_ == 3 || croak 'usage: $io->ioctl( OP, VALUE );'; + my ($io, $op) = @_; + return ioctl($io, $op, $_[2]); +} + +# this sub is for compatability with older releases of IO that used +# a sub called constant to detemine if a constant existed -- GMB +# +# The SEEK_* and _IO?BF constants were the only constants at that time +# any new code should just chech defined(&CONSTANT_NAME) + +sub constant { + no strict 'refs'; + my $name = shift; + (($name =~ /^(SEEK_(SET|CUR|END)|_IO[FLN]BF)$/) && defined &{$name}) + ? &{$name}() : undef; +} + + +# so that flush.pl can be depriciated + +sub printflush { + my $io = shift; + my $old = new SelectSaver qualify($io, caller) if ref($io); + local $| = 1; + if(ref($io)) { + print $io @_; + } + else { + print @_; + } } 1; diff --git a/contrib/perl5/ext/IO/lib/IO/Pipe.pm b/contrib/perl5/ext/IO/lib/IO/Pipe.pm index 23c51b0..27b5ad0 100644 --- a/contrib/perl5/ext/IO/lib/IO/Pipe.pm +++ b/contrib/perl5/ext/IO/lib/IO/Pipe.pm @@ -1,20 +1,20 @@ # 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 +# Copyright (c) 1996-8 Graham Barr <gbarr@pobox.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; +require 5.005_64; use IO::Handle; use strict; -use vars qw($VERSION); +our($VERSION); use Carp; use Symbol; -$VERSION = "1.0902"; +$VERSION = "1.121"; sub new { my $type = shift; @@ -65,7 +65,7 @@ sub _doit { } bless $io, "IO::Handle"; $io->fdopen($fh, $mode); - $fh->close; + $fh->close; if ($do_spawn) { $pid = eval { system 1, @_ }; # 1 == P_NOWAIT @@ -88,8 +88,12 @@ sub _doit { } sub reader { - @_ >= 1 or croak 'usage: $pipe->reader()'; + @_ >= 1 or croak 'usage: $pipe->reader( [SUB_COMMAND_ARGS] )'; my $me = shift; + + return undef + unless(ref($me) || ref($me = $me->new)); + my $fh = ${*$me}[0]; my $pid = $me->_doit(0, $fh, @_) if(@_); @@ -97,6 +101,8 @@ sub reader { close ${*$me}[1]; bless $me, ref($fh); *$me = *$fh; # Alias self to handle + $me->fdopen($fh->fileno,"r") + unless defined($me->fileno); bless $fh; # Really wan't un-bless here ${*$me}{'io_pipe_pid'} = $pid if defined $pid; @@ -105,8 +111,12 @@ sub reader { } sub writer { - @_ >= 1 or croak 'usage: $pipe->writer()'; + @_ >= 1 or croak 'usage: $pipe->writer( [SUB_COMMAND_ARGS] )'; my $me = shift; + + return undef + unless(ref($me) || ref($me = $me->new)); + my $fh = ${*$me}[1]; my $pid = $me->_doit(1, $fh, @_) if(@_); @@ -114,6 +124,8 @@ sub writer { close ${*$me}[0]; bless $me, ref($fh); *$me = *$fh; # Alias self to handle + $me->fdopen($fh->fileno,"w") + unless defined($me->fileno); bless $fh; # Really wan't un-bless here ${*$me}{'io_pipe_pid'} = $pid if defined $pid; @@ -123,7 +135,7 @@ sub writer { package IO::Pipe::End; -use vars qw(@ISA); +our(@ISA); @ISA = qw(IO::Handle); @@ -143,7 +155,7 @@ __END__ =head1 NAME -IO::pipe - supply object methods for pipes +IO::Pipe - supply object methods for pipes =head1 SYNOPSIS @@ -228,12 +240,13 @@ L<IO::Handle> =head1 AUTHOR -Graham Barr <bodg@tiuk.ti.com> +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. =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. +Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. 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/Poll.pm b/contrib/perl5/ext/IO/lib/IO/Poll.pm new file mode 100644 index 0000000..687664b --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Poll.pm @@ -0,0 +1,205 @@ +# IO::Poll.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.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::Poll; + +use strict; +use IO::Handle; +use Exporter (); +our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); + +@ISA = qw(Exporter); +$VERSION = "0.01"; + +@EXPORT = qw(poll); + +@EXPORT_OK = qw( + POLLIN + POLLPRI + POLLOUT + POLLRDNORM + POLLWRNORM + POLLRDBAND + POLLWRBAND + POLLNORM + POLLERR + POLLHUP + POLLNVAL +); + +sub new { + my $class = shift; + + my $self = bless [{},{}], $class; + + $self; +} + +sub mask { + my $self = shift; + my $io = shift; + my $fd = fileno($io); + if(@_) { + my $mask = shift; + $self->[0]{$fd} ||= {}; + if($mask) { + $self->[0]{$fd}{$io} = $mask; + } + else { + delete $self->[0]{$fd}{$io}; + } + } + elsif(exists $self->[0]{$fd}{$io}) { + return $self->[0]{$fd}{$io}; + } + return; +} + + +sub poll { + my($self,$timeout) = @_; + + $self->[1] = {}; + + my($fd,$ref); + my @poll = (); + + while(($fd,$ref) = each %{$self->[0]}) { + my $events = 0; + map { $events |= $_ } values %{$ref}; + push(@poll,$fd, $events); + } + + my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0; + + return $ret + unless $ret > 0; + + while(@poll) { + my($fd,$got) = splice(@poll,0,2); + $self->[1]{$fd} = $got + if $got; + } + + return $ret; +} + +sub events { + my $self = shift; + my $io = shift; + my $fd = fileno($io); + + exists $self->[1]{$fd} && exists $self->[0]{$fd}{$io} + ? $self->[1]{$fd} & $self->[0]{$fd}{$io} + : 0; +} + +sub remove { + my $self = shift; + my $io = shift; + $self->mask($io,0); +} + +sub handles { + my $self = shift; + + return map { keys %$_ } values %{$self->[0]} + unless(@_); + + my $events = shift || 0; + my($fd,$ev,$io,$mask); + my @handles = (); + + while(($fd,$ev) = each %{$self->[1]}) { + if($ev & $events) { + while(($io,$mask) = each %{$self->[0][$fd]}) { + push(@handles, $io) + if $events & $mask; + } + } + } + return @handles; +} + +1; + +__END__ + +=head1 NAME + +IO::Poll - Object interface to system poll call + +=head1 SYNOPSIS + + use IO::Poll qw(POLLRDNORM POLLWRNORM POLLIN POLLHUP); + + $poll = new IO::Poll; + + $poll->mask($input_handle => POLLRDNORM | POLLIN | POLLHUP); + $poll->mask($output_handle => POLLWRNORM); + + $poll->poll($timeout); + + $ev = $poll->events($input); + +=head1 DESCRIPTION + +C<IO::Poll> is a simple interface to the system level poll routine. + +=head1 METHODS + +=over 4 + +=item mask ( IO [, EVENT_MASK ] ) + +If EVENT_MASK is given, then, if EVENT_MASK is non-zero, IO is added to the +list of file descriptors and the next call to poll will check for +any event specified in EVENT_MASK. If EVENT_MASK is zero then IO will be +removed from the list of file descriptors. + +If EVENT_MASK is not given then the return value will be the current +event mask value for IO. + +=item poll ( [ TIMEOUT ] ) + +Call the system level poll routine. If TIMEOUT is not specified then the +call will block. Returns the number of handles which had events +happen, or -1 on error. + +=item events ( IO ) + +Returns the event mask which represents the events that happend on IO +during the last call to C<poll>. + +=item remove ( IO ) + +Remove IO from the list of file descriptors for the next poll. + +=item handles( [ EVENT_MASK ] ) + +Returns a list of handles. If EVENT_MASK is not given then a list of all +handles known will be returned. If EVENT_MASK is given then a list +of handles will be returned which had one of the events specified by +EVENT_MASK happen during the last call ti C<poll> + +=back + +=head1 SEE ALSO + +L<poll(2)>, L<IO::Handle>, L<IO::Select> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. 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 index 86154c5..e09d48b 100644 --- a/contrib/perl5/ext/IO/lib/IO/Seekable.pm +++ b/contrib/perl5/ext/IO/lib/IO/Seekable.pm @@ -19,16 +19,17 @@ 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 +C<$io-E<lt>getpos> returns an opaque value that represents the +current position of the IO::File, and C<$io-E<gt>setpos(POS)> 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 + $io->seek( POS, WHENCE ) + $io->sysseek( POS, WHENCE ) + $io->tell =head1 SEE ALSO @@ -39,29 +40,37 @@ L<IO::File> =head1 HISTORY -Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt> +Derived from FileHandle.pm by Graham Barr E<lt>gbarr@pobox.comE<gt> =cut -require 5.000; +require 5.005_64; use Carp; use strict; -use vars qw($VERSION @EXPORT @ISA); -use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END); +our($VERSION, @EXPORT, @ISA); +use IO::Handle (); +# XXX we can't get these from IO::Handle or we'll get prototype +# mismatch warnings on C<use POSIX; use IO::File;> :-( +use Fcntl qw(SEEK_SET SEEK_CUR SEEK_END); require Exporter; @EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END); @ISA = qw(Exporter); -$VERSION = "1.06"; +$VERSION = "1.08"; sub seek { - @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)'; + @_ == 3 or croak 'usage: $io->seek(POS, WHENCE)'; seek($_[0], $_[1], $_[2]); } +sub sysseek { + @_ == 3 or croak 'usage: $io->sysseek(POS, WHENCE)'; + sysseek($_[0], $_[1], $_[2]); +} + sub tell { - @_ == 1 or croak 'usage: $fh->tell()'; + @_ == 1 or croak 'usage: $io->tell()'; tell($_[0]); } diff --git a/contrib/perl5/ext/IO/lib/IO/Select.pm b/contrib/perl5/ext/IO/lib/IO/Select.pm index dea684a..df92b04 100644 --- a/contrib/perl5/ext/IO/lib/IO/Select.pm +++ b/contrib/perl5/ext/IO/lib/IO/Select.pm @@ -1,163 +1,17 @@ # 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. +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.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::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 warnings::register; use vars qw($VERSION @ISA); require Exporter; -$VERSION = "1.10"; +$VERSION = "1.14"; @ISA = qw(Exporter); # This is only so we can do version checking @@ -193,7 +47,9 @@ sub remove sub exists { my $vec = shift; - $vec->[$vec->_fileno(shift) + FIRST_FD]; + my $fno = $vec->_fileno(shift); + return undef unless defined $fno; + $vec->[$fno + FIRST_FD]; } @@ -261,7 +117,7 @@ sub can_write : (); } -sub has_error +sub has_exception { my $vec = shift; my $timeout = shift; @@ -272,6 +128,13 @@ sub has_error : (); } +sub has_error +{ + warnings::warn("Call to depreciated method 'has_error', use 'has_exception'") + if warnings::enabled(); + goto &has_exception; +} + sub count { my $vec = shift; @@ -369,3 +232,149 @@ sub handles } 1; +__END__ + +=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_exception ( [ TIMEOUT ] ) + +Same as C<can_read> except check for handles that have an exception +condition, for example pending out-of-band data. + +=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 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. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. 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/Socket.pm b/contrib/perl5/ext/IO/lib/IO/Socket.pm index 2b4bc49..6884f02 100644 --- a/contrib/perl5/ext/IO/lib/IO/Socket.pm +++ b/contrib/perl5/ext/IO/lib/IO/Socket.pm @@ -1,129 +1,29 @@ # 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 +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.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 +require 5.005_64; -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); +our(@ISA, $VERSION); use Exporter; +use Errno; + +# legacy + +require IO::Socket::INET; +require IO::Socket::UNIX if ($^O ne 'epoc'); @ISA = qw(IO::Handle); -$VERSION = "1.1603"; +$VERSION = "1.26"; sub import { my $pkg = shift; @@ -133,16 +33,17 @@ sub import { sub new { my($class,%arg) = @_; - my $fh = $class->SUPER::new(); - $fh->autoflush; + my $sock = $class->SUPER::new(); - ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout}; + $sock->autoflush(1); - return scalar(%arg) ? $fh->configure(\%arg) - : $fh; + ${*$sock}{'io_socket_timeout'} = delete $arg{Timeout}; + + return scalar(%arg) ? $sock->configure(\%arg) + : $sock; } -my @domain2pkg = (); +my @domain2pkg; sub register_domain { my($p,$d) = @_; @@ -150,7 +51,7 @@ sub register_domain { } sub configure { - my($fh,$arg) = @_; + my($sock,$arg) = @_; my $domain = delete $arg->{Domain}; croak 'IO::Socket: Cannot configure a generic socket' @@ -160,150 +61,167 @@ sub configure { unless defined $domain2pkg[$domain]; croak "IO::Socket: Cannot configure socket in domain '$domain'" - unless ref($fh) eq "IO::Socket"; + unless ref($sock) eq "IO::Socket"; - bless($fh, $domain2pkg[$domain]); - $fh->configure($arg); + bless($sock, $domain2pkg[$domain]); + $sock->configure($arg); } sub socket { - @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)'; - my($fh,$domain,$type,$protocol) = @_; + @_ == 4 or croak 'usage: $sock->socket(DOMAIN, TYPE, PROTOCOL)'; + my($sock,$domain,$type,$protocol) = @_; - socket($fh,$domain,$type,$protocol) or + socket($sock,$domain,$type,$protocol) or return undef; - ${*$fh}{'io_socket_domain'} = $domain; - ${*$fh}{'io_socket_type'} = $type; - ${*$fh}{'io_socket_proto'} = $protocol; + ${*$sock}{'io_socket_domain'} = $domain; + ${*$sock}{'io_socket_type'} = $type; + ${*$sock}{'io_socket_proto'} = $protocol; - $fh; + $sock; } sub socketpair { - @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)'; + @_ == 4 || croak 'usage: IO::Socket->socketpair(DOMAIN, TYPE, PROTOCOL)'; my($class,$domain,$type,$protocol) = @_; - my $fh1 = $class->new(); - my $fh2 = $class->new(); + my $sock1 = $class->new(); + my $sock2 = $class->new(); - socketpair($fh1,$fh2,$domain,$type,$protocol) or + socketpair($sock1,$sock2,$domain,$type,$protocol) or return (); - ${*$fh1}{'io_socket_type'} = ${*$fh2}{'io_socket_type'} = $type; - ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol; + ${*$sock1}{'io_socket_type'} = ${*$sock2}{'io_socket_type'} = $type; + ${*$sock1}{'io_socket_proto'} = ${*$sock2}{'io_socket_proto'} = $protocol; - ($fh1,$fh2); + ($sock1,$sock2); } 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); + @_ == 2 or croak 'usage: $sock->connect(NAME)'; + my $sock = shift; + my $addr = shift; + my $timeout = ${*$sock}{'io_socket_timeout'}; + my $err; + my $blocking; + $blocking = $sock->blocking(0) if $timeout; + + if (!connect($sock, $addr)) { + if ($timeout && $!{EINPROGRESS}) { + require IO::Select; + + my $sel = new IO::Select $sock; + + if (!$sel->can_write($timeout)) { + $err = $! || (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); + $@ = "connect: timeout"; + } + elsif(!connect($sock,$addr) && not $!{EISCONN}) { + # Some systems refuse to re-connect() to + # an already open socket and set errno to EISCONN. + $err = $!; + $@ = "connect: $!"; + } + } + else { + $err = $!; + $@ = "connect: $!"; + } + } - croak "connect: timeout" - unless defined $fh; + $sock->blocking(1) if $blocking; - undef $fh unless $ok; - }; + $! = $err if $err; - $fh; + $err ? undef : $sock; } sub bind { - @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)'; - my $fh = shift; - my $addr = @_ == 1 ? shift : sockaddr_in(@_); + @_ == 2 or croak 'usage: $sock->bind(NAME)'; + my $sock = shift; + my $addr = shift; - return bind($fh, $addr) ? $fh - : undef; + return bind($sock, $addr) ? $sock + : undef; } sub listen { - @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])'; - my($fh,$queue) = @_; + @_ >= 1 && @_ <= 2 or croak 'usage: $sock->listen([QUEUE])'; + my($sock,$queue) = @_; $queue = 5 unless $queue && $queue > 0; - return listen($fh, $queue) ? $fh - : undef; + return listen($sock, $queue) ? $sock + : undef; } sub accept { - @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])'; - my $fh = shift; - my $pkg = shift || $fh; - my $timeout = ${*$fh}{'io_socket_timeout'}; + @_ == 1 || @_ == 2 or croak 'usage $sock->accept([PKG])'; + my $sock = shift; + my $pkg = shift || $sock; + my $timeout = ${*$sock}{'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; + if($timeout) { + require IO::Select; + + my $sel = new IO::Select $sock; + + unless ($sel->can_read($timeout)) { + $@ = 'accept: timeout'; + $! = (exists &Errno::ETIMEDOUT ? &Errno::ETIMEDOUT : 1); + return; + } + } + + $peer = accept($new,$sock) + or return; + + return wantarray ? ($new, $peer) + : $new; } sub sockname { - @_ == 1 or croak 'usage: $fh->sockname()'; + @_ == 1 or croak 'usage: $sock->sockname()'; getsockname($_[0]); } sub peername { - @_ == 1 or croak 'usage: $fh->peername()'; - my($fh) = @_; - getpeername($fh) - || ${*$fh}{'io_socket_peername'} + @_ == 1 or croak 'usage: $sock->peername()'; + my($sock) = @_; + getpeername($sock) + || ${*$sock}{'io_socket_peername'} || undef; } +sub connected { + @_ == 1 or croak 'usage: $sock->connected()'; + my($sock) = @_; + getpeername($sock); +} + sub send { - @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])'; - my $fh = $_[0]; + @_ >= 2 && @_ <= 4 or croak 'usage: $sock->send(BUF, [FLAGS, [TO]])'; + my $sock = $_[0]; my $flags = $_[2] || 0; - my $peer = $_[3] || $fh->peername; + my $peer = $_[3] || $sock->peername; croak 'send: Cannot determine peer address' unless($peer); - my $r = defined(getpeername($fh)) - ? send($fh, $_[1], $flags) - : send($fh, $_[1], $flags, $peer); + my $r = defined(getpeername($sock)) + ? send($sock, $_[1], $flags) + : send($sock, $_[1], $flags, $peer); # remember who we send to, if it was sucessful - ${*$fh}{'io_socket_peername'} = $peer + ${*$sock}{'io_socket_peername'} = $peer if(@_ == 4 && defined $r); $r; } sub recv { - @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])'; + @_ == 3 || @_ == 4 or croak 'usage: $sock->recv(BUF, LEN [, FLAGS])'; my $sock = $_[0]; my $len = $_[2]; my $flags = $_[3] || 0; @@ -312,16 +230,21 @@ sub recv { ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags); } +sub shutdown { + @_ == 2 or croak 'usage: $sock->shutdown(HOW)'; + my($sock, $how) = @_; + shutdown($sock, $how); +} sub setsockopt { - @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)'; + @_ == 4 or croak '$sock->setsockopt(LEVEL, OPTNAME)'; setsockopt($_[0],$_[1],$_[2],$_[3]); } my $intsize = length(pack("i",0)); sub getsockopt { - @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)'; + @_ == 3 or croak '$sock->getsockopt(LEVEL, OPTNAME)'; my $r = getsockopt($_[0],$_[1],$_[2]); # Just a guess $r = unpack("i", $r) @@ -330,399 +253,176 @@ sub getsockopt { } sub sockopt { - my $fh = shift; - @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_) - : $fh->setsockopt(SOL_SOCKET,@_); + my $sock = shift; + @_ == 1 ? $sock->getsockopt(SOL_SOCKET,@_) + : $sock->setsockopt(SOL_SOCKET,@_); } sub timeout { - @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])'; - my($fh,$val) = @_; - my $r = ${*$fh}{'io_socket_timeout'} || undef; + @_ == 1 || @_ == 2 or croak 'usage: $sock->timeout([VALUE])'; + my($sock,$val) = @_; + my $r = ${*$sock}{'io_socket_timeout'} || undef; - ${*$fh}{'io_socket_timeout'} = 0 + $val + ${*$sock}{'io_socket_timeout'} = 0 + $val if(@_ == 2); $r; } sub sockdomain { - @_ == 1 or croak 'usage: $fh->sockdomain()'; - my $fh = shift; - ${*$fh}{'io_socket_domain'}; + @_ == 1 or croak 'usage: $sock->sockdomain()'; + my $sock = shift; + ${*$sock}{'io_socket_domain'}; } sub socktype { - @_ == 1 or croak 'usage: $fh->socktype()'; - my $fh = shift; - ${*$fh}{'io_socket_type'} + @_ == 1 or croak 'usage: $sock->socktype()'; + my $sock = shift; + ${*$sock}{'io_socket_type'} } sub protocol { - @_ == 1 or croak 'usage: $fh->protocol()'; - my($fh) = @_; - ${*$fh}{'io_socket_protocol'}; + @_ == 1 or croak 'usage: $sock->protocol()'; + my($sock) = @_; + ${*$sock}{'io_socket_proto'}; } -=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 - +1; -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. +__END__ -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. +=head1 NAME -If the constructor is only passed a single argument, it is assumed to -be a C<PeerAddr> specification. +IO::Socket - Object interface to socket communications -Examples: +=head1 SYNOPSIS - $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org', - PeerPort => 'http(80)', - Proto => 'tcp'); + use IO::Socket; - $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)'); +=head1 DESCRIPTION - $sock = IO::Socket::INET->new(Listen => 5, - LocalAddr => 'localhost', - LocalPort => 9000, - Proto => 'tcp'); +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>. - $sock = IO::Socket::INET->new('127.0.0.1:25'); +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>. -=head2 METHODS +=head1 CONSTRUCTOR =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 new ( [ARGS] ) -=item peerport () +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. -Return the port number for the socket on the peer host. + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE -=item peerhost () +As of VERSION 1.18 all IO::Socket objects have autoflush turned on +by default. This was not the case with earlier releases. -Return the address part of the sockaddr structure for the socket on the -peer host in a text form xx.xx.xx.xx + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE =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]; -} +=head1 METHODS -sub peerhost { - @_ == 1 or croak 'usage: $fh->peerhost()'; - my($fh) = @_; - inet_ntoa($fh->peeraddr); -} +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: -## -## AF_UNIX -## + socket + socketpair + bind + listen + accept + send + recv + peername (getpeername) + sockname (getsockname) + shutdown -package IO::Socket::UNIX; +Some methods take slightly different arguments to those defined in L<perlfunc> +in attempt to make the interface more flexible. These are -use strict; -use vars qw(@ISA $VERSION); -use Socket; -use Carp; -use Exporter; +=over 4 -@ISA = qw(IO::Socket); +=item accept([PKG]) -IO::Socket::UNIX->register_domain( AF_UNIX ); +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. -=head2 IO::Socket::UNIX +=item socketpair(DOMAIN, TYPE, PROTOCOL) -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 +Call C<socketpair> and return a list of two sockets created, or an +empty list on failure. - 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 +=back -=head2 METHODS +Additional methods that are provided are: =over 4 -=item hostpath() +=item timeout([VAL]) -Returns the pathname to the fifo at the local end +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 peerpath() +=item sockopt(OPT [, VAL]) -Returns the pathname to the fifo at the peer end +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. -=back +=item sockdomain -=cut +Returns the numerical number for the socket domain type. For example, for +a AF_INET socket the value of &AF_INET will be returned. -sub configure { - my($fh,$arg) = @_; - my($bport,$cport); +=item socktype - my $type = $arg->{Type} || SOCK_STREAM; +Returns the numerical number for the socket type. For example, for +a SOCK_STREAM socket the value of &SOCK_STREAM will be returned. - $fh->socket(AF_UNIX, $type, 0) or - return undef; +=item protocol - 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; - } +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. - $fh; -} +=item connected -sub hostpath { - @_ == 1 or croak 'usage: $fh->hostpath()'; - my $n = $_[0]->sockname || return undef; - (sockaddr_un($n))[0]; -} +If the socket is in a connected state the the peer address is returned. +If the socket is not in a connected state then undef will be returned. -sub peerpath { - @_ == 1 or croak 'usage: $fh->peerpath()'; - my $n = $_[0]->peername || return undef; - (sockaddr_un($n))[0]; -} +=back =head1 SEE ALSO -L<Socket>, L<IO::Handle> +L<Socket>, L<IO::Handle>, L<IO::Socket::INET>, L<IO::Socket::UNIX> =head1 AUTHOR -Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt> +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. =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. +Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. 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 diff --git a/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm b/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm new file mode 100644 index 0000000..27a3d4d --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm @@ -0,0 +1,406 @@ +# IO::Socket::INET.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.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::INET; + +use strict; +our(@ISA, $VERSION); +use IO::Socket; +use Socket; +use Carp; +use Exporter; +use Errno; + +@ISA = qw(IO::Socket); +$VERSION = "1.25"; + +my $EINVAL = exists(&Errno::EINVAL) ? Errno::EINVAL() : 1; + +IO::Socket::INET->register_domain( AF_INET ); + +my %socket_type = ( tcp => SOCK_STREAM, + udp => SOCK_DGRAM, + icmp => SOCK_RAW + ); + +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) { + if (@proto = ( $proto =~ m,\D, + ? getprotobyname($proto) + : getprotobynumber($proto)) + ) { + $proto = $proto[2] || undef; + } + else { + $@ = "Bad protocol '$proto'"; + return; + } + } + + if(defined $port) { + $port =~ s,\((\d+)\)$,,; + + my $defport = $1 || undef; + my $pnum = ($port =~ m,^(\d+)$,)[0]; + + if ($port =~ m,\D,) { + unless (@serv = getservbyname($port, $proto[0] || "")) { + $@ = "Bad service '$port'"; + return; + } + } + + $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 $sock = shift; + my $err = shift; + { + local($!); + $@ = join("",ref($sock),": ",@_); + close($sock) + if(defined fileno($sock)); + } + $! = $err; + return undef; +} + +sub _get_addr { + my($sock,$addr_str, $multi) = @_; + my @addr; + if ($multi && $addr_str !~ /^\d+(?:\.\d+){3}$/) { + (undef, undef, undef, undef, @addr) = gethostbyname($addr_str); + } else { + my $h = inet_aton($addr_str); + push(@addr, $h) if defined $h; + } + @addr; +} + +sub configure { + my($sock,$arg) = @_; + my($lport,$rport,$laddr,$raddr,$proto,$type); + + + $arg->{LocalAddr} = $arg->{LocalHost} + if exists $arg->{LocalHost} && !exists $arg->{LocalAddr}; + + ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr}, + $arg->{LocalPort}, + $arg->{Proto}) + or return _error($sock, $!, $@); + + $laddr = defined $laddr ? inet_aton($laddr) + : INADDR_ANY; + + return _error($sock, $EINVAL, "Bad hostname '",$arg->{LocalAddr},"'") + unless(defined $laddr); + + $arg->{PeerAddr} = $arg->{PeerHost} + if exists $arg->{PeerHost} && !exists $arg->{PeerAddr}; + + unless(exists $arg->{Listen}) { + ($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr}, + $arg->{PeerPort}, + $proto) + or return _error($sock, $!, $@); + } + + $proto ||= (getprotobyname('tcp'))[2]; + + my $pname = (getprotobynumber($proto))[0]; + $type = $arg->{Type} || $socket_type{$pname}; + + my @raddr = (); + + if(defined $raddr) { + @raddr = $sock->_get_addr($raddr, $arg->{MultiHomed}); + return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'") + unless @raddr; + } + + while(1) { + + $sock->socket(AF_INET, $type, $proto) or + return _error($sock, $!, "$!"); + + if ($arg->{Reuse}) { + $sock->sockopt(SO_REUSEADDR,1) or + return _error($sock, $!, "$!"); + } + + if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) { + $sock->bind($lport || 0, $laddr) or + return _error($sock, $!, "$!"); + } + + if(exists $arg->{Listen}) { + $sock->listen($arg->{Listen} || 5) or + return _error($sock, $!, "$!"); + last; + } + + # don't try to connect unless we're given a PeerAddr + last unless exists($arg->{PeerAddr}); + + $raddr = shift @raddr; + + return _error($sock, $EINVAL, 'Cannot determine remote port') + unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW); + + last + unless($type == SOCK_STREAM || defined $raddr); + + return _error($sock, $EINVAL, "Bad hostname '",$arg->{PeerAddr},"'") + unless defined $raddr; + +# my $timeout = ${*$sock}{'io_socket_timeout'}; +# my $before = time() if $timeout; + + if ($sock->connect(pack_sockaddr_in($rport, $raddr))) { +# ${*$sock}{'io_socket_timeout'} = $timeout; + return $sock; + } + + return _error($sock, $!, "Timeout") + unless @raddr; + +# if ($timeout) { +# my $new_timeout = $timeout - (time() - $before); +# return _error($sock, +# (exists(&Errno::ETIMEDOUT) ? Errno::ETIMEDOUT() : $EINVAL), +# "Timeout") if $new_timeout <= 0; +# ${*$sock}{'io_socket_timeout'} = $new_timeout; +# } + + } + + $sock; +} + +sub connect { + @_ == 2 || @_ == 3 or + croak 'usage: $sock->connect(NAME) or $sock->connect(PORT, ADDR)'; + my $sock = shift; + return $sock->SUPER::connect(@_ == 1 ? shift : pack_sockaddr_in(@_)); +} + +sub bind { + @_ == 2 || @_ == 3 or + croak 'usage: $sock->bind(NAME) or $sock->bind(PORT, ADDR)'; + my $sock = shift; + return $sock->SUPER::bind(@_ == 1 ? shift : pack_sockaddr_in(@_)) +} + +sub sockaddr { + @_ == 1 or croak 'usage: $sock->sockaddr()'; + my($sock) = @_; + my $name = $sock->sockname; + $name ? (sockaddr_in($name))[1] : undef; +} + +sub sockport { + @_ == 1 or croak 'usage: $sock->sockport()'; + my($sock) = @_; + my $name = $sock->sockname; + $name ? (sockaddr_in($name))[0] : undef; +} + +sub sockhost { + @_ == 1 or croak 'usage: $sock->sockhost()'; + my($sock) = @_; + my $addr = $sock->sockaddr; + $addr ? inet_ntoa($addr) : undef; +} + +sub peeraddr { + @_ == 1 or croak 'usage: $sock->peeraddr()'; + my($sock) = @_; + my $name = $sock->peername; + $name ? (sockaddr_in($name))[1] : undef; +} + +sub peerport { + @_ == 1 or croak 'usage: $sock->peerport()'; + my($sock) = @_; + my $name = $sock->peername; + $name ? (sockaddr_in($name))[0] : undef; +} + +sub peerhost { + @_ == 1 or croak 'usage: $sock->peerhost()'; + my($sock) = @_; + my $addr = $sock->peeraddr; + $addr ? inet_ntoa($addr) : undef; +} + +1; + +__END__ + +=head1 NAME + +IO::Socket::INET - Object interface for AF_INET domain sockets + +=head1 SYNOPSIS + + use IO::Socket::INET; + +=head1 DESCRIPTION + +C<IO::Socket::INET> provides an object interface to creating and using sockets +in the AF_INET domain. It is built upon the L<IO::Socket> interface and +inherits all the methods defined by L<IO::Socket>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Socket::INET> object, 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. + +In addition to the key-value pairs accepted by L<IO::Socket>, +C<IO::Socket::INET> provides. + + + PeerAddr Remote host address <hostname>[:<port>] + PeerHost Synonym for PeerAddr + PeerPort Remote port or service <service>[(<no>)] | <no> + LocalAddr Local host bind address hostname[:port] + LocalHost Synonym for LocalAddr + 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 + MultiHomed Try all adresses for multi-homed hosts + + +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. + +Although it is not illegal, the use of C<MultiHomed> on a socket +which is in non-blocking mode is of little use. This is because the +first connect will never fail with a timeout as the connaect call +will not block. + +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'); + + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +As of VERSION 1.18 all IO::Socket objects have autoflush turned on +by default. This was not the case with earlier releases. + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +=back + +=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 + +=head1 SEE ALSO + +L<Socket>, L<IO::Socket> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. 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/Socket/UNIX.pm b/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm new file mode 100644 index 0000000..d083f48 --- /dev/null +++ b/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm @@ -0,0 +1,143 @@ +# IO::Socket::UNIX.pm +# +# Copyright (c) 1997-8 Graham Barr <gbarr@pobox.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::UNIX; + +use strict; +our(@ISA, $VERSION); +use IO::Socket; +use Socket; +use Carp; + +@ISA = qw(IO::Socket); +$VERSION = "1.20"; + +IO::Socket::UNIX->register_domain( AF_UNIX ); + +sub new { + my $class = shift; + unshift(@_, "Peer") if @_ == 1; + return $class->SUPER::new(@_); +} + +sub configure { + my($sock,$arg) = @_; + my($bport,$cport); + + my $type = $arg->{Type} || SOCK_STREAM; + + $sock->socket(AF_UNIX, $type, 0) or + return undef; + + if(exists $arg->{Local}) { + my $addr = sockaddr_un($arg->{Local}); + $sock->bind($addr) or + return undef; + } + if(exists $arg->{Listen}) { + $sock->listen($arg->{Listen} || 5) or + return undef; + } + elsif(exists $arg->{Peer}) { + my $addr = sockaddr_un($arg->{Peer}); + $sock->connect($addr) or + return undef; + } + + $sock; +} + +sub hostpath { + @_ == 1 or croak 'usage: $sock->hostpath()'; + my $n = $_[0]->sockname || return undef; + (sockaddr_un($n))[0]; +} + +sub peerpath { + @_ == 1 or croak 'usage: $sock->peerpath()'; + my $n = $_[0]->peername || return undef; + (sockaddr_un($n))[0]; +} + +1; # Keep require happy + +__END__ + +=head1 NAME + +IO::Socket::UNIX - Object interface for AF_UNIX domain sockets + +=head1 SYNOPSIS + + use IO::Socket::UNIX; + +=head1 DESCRIPTION + +C<IO::Socket::UNIX> provides an object interface to creating and using sockets +in the AF_UNIX domain. It is built upon the L<IO::Socket> interface and +inherits all the methods defined by L<IO::Socket>. + +=head1 CONSTRUCTOR + +=over 4 + +=item new ( [ARGS] ) + +Creates an C<IO::Socket::UNIX> object, 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. + +In addition to the key-value pairs accepted by L<IO::Socket>, +C<IO::Socket::UNIX> provides. + + 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 + +If the constructor is only passed a single argument, it is assumed to +be a C<Peer> specification. + + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +As of VERSION 1.18 all IO::Socket objects have autoflush turned on +by default. This was not the case with earlier releases. + + NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE NOTE + +=back + +=head1 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 + +=head1 SEE ALSO + +L<Socket>, L<IO::Socket> + +=head1 AUTHOR + +Graham Barr. Currently maintained by the Perl Porters. Please report all +bugs to <perl5-porters@perl.org>. + +=head1 COPYRIGHT + +Copyright (c) 1996-8 Graham Barr <gbarr@pobox.com>. All rights reserved. +This program is free software; you can redistribute it and/or +modify it under the same terms as Perl itself. + +=cut |
