diff options
Diffstat (limited to 'contrib/perl5/ext/IO/lib')
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Handle.pm | 62 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Poll.pm | 73 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Seekable.pm | 64 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Select.pm | 7 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Socket.pm | 2 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Socket/INET.pm | 24 | ||||
| -rw-r--r-- | contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm | 2 |
7 files changed, 155 insertions, 79 deletions
diff --git a/contrib/perl5/ext/IO/lib/IO/Handle.pm b/contrib/perl5/ext/IO/lib/IO/Handle.pm index 930df55..fb754a6 100644 --- a/contrib/perl5/ext/IO/lib/IO/Handle.pm +++ b/contrib/perl5/ext/IO/lib/IO/Handle.pm @@ -71,7 +71,7 @@ corresponding built-in functions: $io->printf ( FMT, [ARGS] ) $io->stat $io->sysread ( BUF, LEN, [OFFSET] ) - $io->syswrite ( BUF, LEN, [OFFSET] ) + $io->syswrite ( BUF, [LEN, [OFFSET]] ) $io->truncate ( LEN ) See L<perlvar> for complete descriptions of each of the following @@ -110,18 +110,19 @@ or a file descriptor number. =item $io->opened -Returns true if the object is currently a valid file descriptor. +Returns true if the object is currently a valid file descriptor, false +otherwise. =item $io->getline 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. +except that it's more readable and can be safely called in a +list context but still returns just one line. =item $io->getlines -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. +This works like <$io> when called in a list 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 $io->ungetc ( ORD ) @@ -139,31 +140,37 @@ called C<format_write>. =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>. +since it was opened or since the last call to C<clearerr>, or if the +handle is invalid. It only returns false for a valid handle with no +outstanding errors. =item $io->clearerr -Clear the given handle's error indicator. +Clear the given handle's error indicator. Returns -1 if the handle is +invalid, 0 otherwise. =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)>. +operates on the file descriptor (similar to sysread, sysseek and +systell). 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. Returns "0 but true" on success, C<undef> on error, C<undef> +for an invalid handle. 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. +will be written to the underlying file descriptor. Returns "0 but true" +on success, C<undef> on error. =item $io->printflush ( ARGS ) Turns on autoflush, print ARGS and then restores the autoflush status of the -C<IO::Handle> object. +C<IO::Handle> object. Returns the return value from print. =item $io->blocking ( [ BOOL ] ) @@ -183,11 +190,18 @@ 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. +specifies a scalar variable to use as a buffer. You should only +change the buffer before any I/O, or immediately after calling flush. + +WARNING: A variable used as a buffer by C<setbuf> or C<setvbuf> B<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! Remember that +the order of global destruction is undefined, so even if your buffer +variable remains in scope until program termination, it may be undefined +before the file IO::Handle is closed. Note that you need to import the +constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly. Like C, setbuf +returns nothing. setvbuf returns "0 but true", on success, C<undef> on +failure. Lastly, there is a special method for working under B<-T> and setuid/gid scripts: @@ -199,7 +213,8 @@ scripts: 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. +vulnerability should be kept in mind. Returns 0 on success, -1 if setting +the taint-clean flag failed. (eg invalid handle) =back @@ -425,8 +440,11 @@ sub write { sub syswrite { @_ >= 2 && @_ <= 4 or croak 'usage: $io->syswrite(BUF [, LEN [, OFFSET]])'; - $_[2] = length($_[1]) unless defined $_[2]; - syswrite($_[0], $_[1], $_[2], $_[3] || 0); + if (defined($_[2])) { + syswrite($_[0], $_[1], $_[2], $_[3] || 0); + } else { + syswrite($_[0], $_[1]); + } } sub stat { diff --git a/contrib/perl5/ext/IO/lib/IO/Poll.pm b/contrib/perl5/ext/IO/lib/IO/Poll.pm index 687664b..70a3469 100644 --- a/contrib/perl5/ext/IO/lib/IO/Poll.pm +++ b/contrib/perl5/ext/IO/lib/IO/Poll.pm @@ -1,3 +1,4 @@ + # IO::Poll.pm # # Copyright (c) 1997-8 Graham Barr <gbarr@pobox.com>. All rights reserved. @@ -12,28 +13,31 @@ use Exporter (); our(@ISA, @EXPORT_OK, @EXPORT, $VERSION); @ISA = qw(Exporter); -$VERSION = "0.01"; +$VERSION = "0.05"; -@EXPORT = qw(poll); +@EXPORT = qw( POLLIN + POLLOUT + POLLERR + POLLHUP + POLLNVAL + ); @EXPORT_OK = qw( - POLLIN POLLPRI - POLLOUT POLLRDNORM POLLWRNORM POLLRDBAND POLLWRBAND POLLNORM - POLLERR - POLLHUP - POLLNVAL -); + ); +# [0] maps fd's to requested masks +# [1] maps fd's to returned masks +# [2] maps fd's to handles sub new { my $class = shift; - my $self = bless [{},{}], $class; + my $self = bless [{},{},{}], $class; $self; } @@ -42,20 +46,21 @@ sub mask { my $self = shift; my $io = shift; my $fd = fileno($io); - if(@_) { + if (@_) { my $mask = shift; - $self->[0]{$fd} ||= {}; if($mask) { - $self->[0]{$fd}{$io} = $mask; - } - else { + $self->[0]{$fd}{$io} = $mask; # the error events are always returned + $self->[1]{$fd} = 0; # output mask + $self->[2]{$io} = $io; # remember handle + } else { delete $self->[0]{$fd}{$io}; + delete $self->[1]{$fd} unless %{$self->[0]{$fd}}; + delete $self->[2]{$io}; } } - elsif(exists $self->[0]{$fd}{$io}) { + + return unless exists $self->[0]{$fd} and exists $self->[0]{$fd}{$io}; return $self->[0]{$fd}{$io}; - } - return; } @@ -64,13 +69,13 @@ sub poll { $self->[1] = {}; - my($fd,$ref); + my($fd,$mask,$iom); my @poll = (); - while(($fd,$ref) = each %{$self->[0]}) { - my $events = 0; - map { $events |= $_ } values %{$ref}; - push(@poll,$fd, $events); + while(($fd,$iom) = each %{$self->[0]}) { + $mask = 0; + $mask |= $_ for values(%$iom); + push(@poll,$fd => $mask); } my $ret = @poll ? _poll(defined($timeout) ? $timeout * 1000 : -1,@poll) : 0; @@ -80,8 +85,7 @@ sub poll { while(@poll) { my($fd,$got) = splice(@poll,0,2); - $self->[1]{$fd} = $got - if $got; + $self->[1]{$fd} = $got if $got; } return $ret; @@ -91,9 +95,8 @@ 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} + exists $self->[1]{$fd} and exists $self->[0]{$fd}{$io} + ? $self->[1]{$fd} & ($self->[0]{$fd}{$io}|POLLHUP|POLLERR|POLLNVAL) : 0; } @@ -105,20 +108,16 @@ sub remove { sub handles { my $self = shift; - - return map { keys %$_ } values %{$self->[0]} - unless(@_); + return values %{$self->[2]} 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; - } + while (($io,$mask) = each %{$self->[0]{$fd}}) { + $mask |= POLLHUP|POLLERR|POLLNVAL; # must allow these + push @handles,$self->[2]{$io} if ($ev & $mask) & $events; } } return @handles; @@ -138,8 +137,8 @@ IO::Poll - Object interface to system poll call $poll = new IO::Poll; - $poll->mask($input_handle => POLLRDNORM | POLLIN | POLLHUP); - $poll->mask($output_handle => POLLWRNORM); + $poll->mask($input_handle => POLLIN); + $poll->mask($output_handle => POLLOUT); $poll->poll($timeout); diff --git a/contrib/perl5/ext/IO/lib/IO/Seekable.pm b/contrib/perl5/ext/IO/lib/IO/Seekable.pm index e09d48b..243a971 100644 --- a/contrib/perl5/ext/IO/lib/IO/Seekable.pm +++ b/contrib/perl5/ext/IO/lib/IO/Seekable.pm @@ -18,19 +18,69 @@ C<IO::Seekable> does not have a constructor of its own as it 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-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. +=over 4 +=item $io->getpos + +Returns an opaque value that represents the current position of the +IO::File, or C<undef> if this is not possible (eg an unseekable stream such +as a terminal, pipe or socket). If the fgetpos() function is available in +your C library it is used to implements getpos, else perl emulates getpos +using C's ftell() function. + +=item $io->setpos + +Uses the value of a previous getpos call to return to a previously visited +position. Returns "0 but true" on success, C<undef> on failure. + +=back + 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: - $io->seek( POS, WHENCE ) - $io->sysseek( POS, WHENCE ) - $io->tell +=over 4 + +=item $io->setpos ( POS, WHENCE ) + +Seek the IO::File to position POS, relative to WHENCE: + +=over 8 + +=item WHENCE=0 (SEEK_SET) + +POS is absolute position. (Seek relative to the start of the file) + +=item WHENCE=1 (SEEK_CUR) + +POS is an offset from the current position. (Seek relative to current) + +=item WHENCE=1 (SEEK_END) + +POS is an offset from the end of the file. (Seek relative to end) + +=back + +The SEEK_* constants can be imported from the C<Fcntl> module if you +don't wish to use the numbers C<0> C<1> or C<2> in your code. + +Returns C<1> upon success, C<0> otherwise. + +=item $io->sysseek( POS, WHENCE ) + +Similar to $io->seek, but sets the IO::File's position using the system +call lseek(2) directly, so will confuse most perl IO operators except +sysread and syswrite (see L<perlfunc> for full details) + +Returns the new position, or C<undef> on failure. A position +of zero is returned as the string C<"0 but true"> + +=item $io->tell + +Returns the IO::File's current position, or -1 on error. +=back + =head1 SEE ALSO L<perlfunc>, diff --git a/contrib/perl5/ext/IO/lib/IO/Select.pm b/contrib/perl5/ext/IO/lib/IO/Select.pm index df92b04..1a3a26f 100644 --- a/contrib/perl5/ext/IO/lib/IO/Select.pm +++ b/contrib/perl5/ext/IO/lib/IO/Select.pm @@ -56,6 +56,7 @@ sub exists sub _fileno { my($self, $f) = @_; + return unless defined $f; $f = $f->[0] if ref($f) eq 'ARRAY'; ($f =~ /^\d+$/) ? $f : fileno($f); } @@ -300,9 +301,9 @@ 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. +the maximum amount of time to wait before returning an empty list, in +seconds, possibly fractional. If C<TIMEOUT> is not given and any +handles are registered then the call will block. =item can_write ( [ TIMEOUT ] ) diff --git a/contrib/perl5/ext/IO/lib/IO/Socket.pm b/contrib/perl5/ext/IO/lib/IO/Socket.pm index 6884f02..b8da092 100644 --- a/contrib/perl5/ext/IO/lib/IO/Socket.pm +++ b/contrib/perl5/ext/IO/lib/IO/Socket.pm @@ -361,7 +361,7 @@ 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 +or undef upon failure. In a list context a two-element array is returned containing the new socket and the peer address; the list will be empty upon failure. diff --git a/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm b/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm index 27a3d4d..d2cc488 100644 --- a/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm +++ b/contrib/perl5/ext/IO/lib/IO/Socket/INET.pm @@ -34,6 +34,7 @@ sub new { sub _sock_info { my($addr,$port,$proto) = @_; + my $origport = $port; my @proto = (); my @serv = (); @@ -59,14 +60,14 @@ sub _sock_info { my $defport = $1 || undef; my $pnum = ($port =~ m,^(\d+)$,)[0]; - if ($port =~ m,\D,) { - unless (@serv = getservbyname($port, $proto[0] || "")) { - $@ = "Bad service '$port'"; - return; - } - } + @serv = getservbyname($port, $proto[0] || "") + if ($port =~ m,\D,); $port = $pnum || $serv[2] || $defport || undef; + unless (defined $port) { + $@ = "Bad service '$origport'"; + return; + } $proto = (getprotobyname($serv[3]))[2] || undef if @serv && !$proto; @@ -150,11 +151,16 @@ sub configure { $sock->socket(AF_INET, $type, $proto) or return _error($sock, $!, "$!"); - if ($arg->{Reuse}) { + if ($arg->{Reuse} || $arg->{ReuseAddr}) { $sock->sockopt(SO_REUSEADDR,1) or return _error($sock, $!, "$!"); } + if ($arg->{ReusePort}) { + $sock->sockopt(SO_REUSEPORT,1) or + return _error($sock, $!, "$!"); + } + if($lport || ($laddr ne INADDR_ANY) || exists $arg->{Listen}) { $sock->bind($lport || 0, $laddr) or return _error($sock, $!, "$!"); @@ -301,7 +307,9 @@ C<IO::Socket::INET> provides. 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 + ReuseAddr Set SO_REUSEADDR before binding + Reuse Set SO_REUSEADDR before binding (deprecated, prefer ReuseAddr) + ReusePort Set SO_REUSEPORT before binding Timeout Timeout value for various operations MultiHomed Try all adresses for multi-homed hosts diff --git a/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm b/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm index d083f48..2a11752 100644 --- a/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm +++ b/contrib/perl5/ext/IO/lib/IO/Socket/UNIX.pm @@ -37,7 +37,7 @@ sub configure { $sock->bind($addr) or return undef; } - if(exists $arg->{Listen}) { + if(exists $arg->{Listen} && $type != SOCK_DGRAM) { $sock->listen($arg->{Listen} || 5) or return undef; } |
