----------------
+Version 5.003_16
+----------------
+
+This patch is all bug fixes, library updates, and documentation
+updates. We'll get to 5.004 RSN, I promise. :-)
+
+ CORE LANGUAGE CHANGES
+
+ Title: "Fix closures that are not in subroutines"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: op.c
+
+ CORE PORTABILITY
+
+ Title: "_13: patches for unicos/unicosmk"
+ From: Dean Roehrich <roehrich@cray.com>
+ Msg-ID: <199612202038.OAA22805@poplar.cray.com>
+ Date: Fri, 20 Dec 1996 14:38:50 -0600
+ Files: Configure MANIFEST hints/unicos.sh hints/unicosmk.sh
+
+ OTHER CORE CHANGES
+
+ Title: "Fix 'foreach(@ARGV) { while (<>) { push @p,$_ } }'"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: cop.h pp_hot.c scope.c
+
+ Title: "Eliminate warnings from C< undef $x; $x OP= "foo" >"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: doop.c pp.c pp.h pp_hot.c
+
+ Title: "Try again to improve method caching"
+ From: Ilya Zakharevich <ilya@math.ohio-state.edu>
+ Msg-ID: <199612240113.UAA09487@monk.mps.ohio-state.edu>
+ Date: Mon, 23 Dec 1996 20:13:56 -0500 (EST)
+ Files: gv.c sv.c
+
+ Title: "Be more careful about 'o' magic memory management"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: mg.c sv.c
+
+ Title: "Fix bad pointer refs when localized object loses magic"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: scope.c
+
+ LIBRARY AND EXTENSIONS
+
+ Title: "Refresh CPAN to 1.09"
+ From: Andreas Koenig
+ Files: lib/CPAN.pm
+
+ Title: "Refresh Net::Ping to 2.02"
+ From: Russell Mosemann <mose@ccsn.edu>
+ Files: lib/Net/Ping.pm
+
+ Title: "Refresh IO to 1.14"
+ From: Graham Barr
+ Files: MANIFEST ext/IO/IO.xs ext/IO/README ext/IO/lib/IO/File.pm
+ ext/IO/lib/IO/Handle.pm ext/IO/lib/IO/Pipe.pm
+ ext/IO/lib/IO/Seekable.pm ext/IO/lib/IO/Select.pm
+ ext/IO/lib/IO/Socket.pm t/lib/io_dup.t t/lib/io_pipe.t
+ t/lib/io_sel.t t/lib/io_sock.t t/lib/io_tell.t
+ t/lib/io_udp.t t/lib/io_xs.t
+
+ BUILD PROCESS AND UTILITIES
+
+ Title: "Don't recurse into subdirs twice on 'make realclean'"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: Makefile.SH
+
+ Title: "Use root EXTERN.h when compiling x2p/malloc.c."
+ From: Paul Marquess
+ Files: x2p/Makefile.SH
+
+ Title: "Fix compilation errors when malloc.c used for x2p"
+ From: Robin Barker <rmb@cise.npl.co.uk>
+ Files: malloc.c
+
+ DOCUMENTATION
+
+ Title: "Edit INSTALL to describe new binary compat setup"
+ From: Chip Salzenberg <chip@atlantic.net>
+ Files: INSTALL
+
+ Title: "Update to perllocale.pod"
+ From: Jarkko Hietaniemi <jhi@cc.hut.fi>
+ Files: pod/perllocale.pod
+
+
+----------------
Version 5.003_15
----------------
$test -f /dnix && osname=dnix
$test -f /lynx.os && osname=lynxos
$test -f /unicos && osname=unicos && osvers=`$uname -r`
+ $test -f /unicosmk.ar && osname=unicosmk && osvers=`$uname -r`
$test -f /bin/mips && /bin/mips && osname=mips
$test -d /NextApps && set X `hostinfo | grep 'NeXT Mach.*:' | \
$sed -e 's/://' -e 's/\./_/'` && osname=next && osvers=$4
ext/IO/IO.pm Top-level interface to IO::* classes
ext/IO/IO.xs IO extension external subroutines
ext/IO/Makefile.PL IO extension makefile writer
+ext/IO/README IO extension maintenance notice
ext/IO/lib/IO/File.pm IO::File extension Perl module
ext/IO/lib/IO/Handle.pm IO::Handle extension Perl module
ext/IO/lib/IO/Pipe.pm IO::Pipe extension Perl module
hints/ultrix_4.sh Hints for named architecture
hints/umips.sh Hints for named architecture
hints/unicos.sh Hints for named architecture
+hints/unicosmk.sh Hints for named architecture
hints/unisysdynix.sh Hints for named architecture
hints/utekv.sh Hints for named architecture
hints/uts.sh Hints for named architecture
t/lib/hostname.t See if Sys::Hostname works
t/lib/io_dup.t See if dup()-related methods from IO work
t/lib/io_pipe.t See if pipe()-related methods from IO work
+t/lib/io_sel.t See if select()-related methods from IO work
t/lib/io_sock.t See if INET socket-related methods from IO work
t/lib/io_taint.t See if the untaint method from IO works
t/lib/io_tell.t See if seek()/tell()-related methods from IO work
cx->blk_loop.next_op = cLOOP->op_nextop; \
cx->blk_loop.last_op = cLOOP->op_lastop; \
cx->blk_loop.iterlval = Nullsv; \
- cx->blk_loop.itervar = ivar; \
- if (ivar) \
- cx->blk_loop.itersave = *cx->blk_loop.itervar;
+ if (cx->blk_loop.itervar = (ivar)) \
+ cx->blk_loop.itersave = SvREFCNT_inc(*cx->blk_loop.itervar);
#define POPLOOP(cx) \
newsp = stack_base + cx->blk_loop.resetsp; \
- SvREFCNT_dec(cx->blk_loop.iterlval)
+ SvREFCNT_dec(cx->blk_loop.iterlval); \
+ if (cx->blk_loop.itervar) { \
+ SvREFCNT_dec(*cx->blk_loop.itervar); \
+ *cx->blk_loop.itervar = cx->blk_loop.itersave; \
+ }
/* context common to subroutines, evals and loops */
struct block {
register char *dc;
STRLEN leftlen;
STRLEN rightlen;
- register char *lc = SvPV(left, leftlen);
- register char *rc = SvPV(right, rightlen);
+ register char *lc;
+ register char *rc;
register I32 len;
I32 lensave;
- char *lsave = lc;
- char *rsave = rc;
+ char *lsave;
+ char *rsave;
+ if (sv == left && !SvOK(sv) && !SvGMAGICAL(sv) && SvTYPE(sv) <= SVt_PVMG)
+ sv_setpvn(sv, "", 0); /* avoid warning on &= etc. */
+ lsave = lc = SvPV(left, leftlen);
+ rsave = rc = SvPV(right, rightlen);
len = leftlen < rightlen ? leftlen : rightlen;
lensave = len;
- if (SvOK(sv)) {
+ if (SvOK(sv) || SvTYPE(sv) > SVt_PVMG) {
dc = SvPV_force(sv, na);
if (SvCUR(sv) < len) {
dc = SvGROW(sv, len + 1);
untaint(handle)
SV * handle
CODE:
+#ifdef IOf_UNTAINT
IO * io;
io = sv_2io(handle);
if (io) {
RETVAL = 0;
}
else {
+#endif
RETVAL = -1;
errno = EINVAL;
+#ifdef IOf_UNTAINT
}
+#endif
OUTPUT:
RETVAL
--- /dev/null
+This directory contains files from the IO distribution maintained by
+Graham Barr <bodg@tiuk.ti.com>. If you find that you have to modify
+any files in this directory then please forward him a patch for only
+the files in this directory.
+#
+
package IO::File;
=head1 NAME
Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>.
-=head1 REVISION
-
-$Revision: 1.5 $
-
=cut
require 5.000;
-use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD);
+use strict;
+use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA);
use Carp;
use Symbol;
use SelectSaver;
@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "1.06";
@EXPORT = @IO::Seekable::EXPORT;
Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
-Version 1.1201 specialized from 1.12 for inclusion in Perl distribution
-
=cut
require 5.000;
-use vars qw($RCS $VERSION @EXPORT_OK $AUTOLOAD);
+use strict;
+use vars qw($VERSION @EXPORT_OK $AUTOLOAD @ISA);
use Carp;
use Symbol;
use SelectSaver;
require Exporter;
@ISA = qw(Exporter);
-$VERSION = "1.1201";
-$RCS = sprintf("%s", q$Revision: 1.15 $ =~ /([\d\.]+)/);
+$VERSION = "1.14";
@EXPORT_OK = qw(
autoflush
$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;
}
bless $fh, $class;
}
-#
-# That an IO::Handle is being destroyed does not necessarily mean
-# that the associated filehandle should be closed. This is because
-# *FOO{FILEHANDLE} may by a synonym for *BAR{FILEHANDLE}.
-#
-# If this IO::Handle really does have the final reference to the
-# given FILEHANDLE, then Perl will close it for us automatically.
-#
-
sub DESTROY {
+ my ($fh) = @_;
+
+ # During global object destruction, this function may be called
+ # on FILEHANDLEs as well as on the GLOBs that contains them.
+ # Thus the following trickery. If only the CORE file operators
+ # could deal with FILEHANDLEs, it wouldn't be necessary...
+
+ if ($fh =~ /=FILEHANDLE\(/) {
+ local *TMP = $fh;
+ close(TMP)
+ if defined fileno(TMP);
+ }
+ else {
+ close($fh)
+ if defined fileno($fh);
+ }
}
################################################
=head1 NAME
-IO::Pipe - supply object methods for pipes
+IO::pipe - supply object methods for pipes
=head1 SYNOPSIS
=head1 AUTHOR
-Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
-
-=head1 REVISION
-
-$Revision: 1.7 $
+Graham Barr <bodg@tiuk.ti.com>
=head1 COPYRIGHT
=cut
require 5.000;
+use strict;
use vars qw($VERSION);
use Carp;
use Symbol;
require IO::Handle;
-$VERSION = sprintf("%d.%02d", q$Revision: 1.7 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "1.08";
sub new {
my $type = shift;
my $pid = $me->_doit(0,@_)
if(@_);
+ close(${*$me}[1]);
bless $me, ref($fh);
- *{*$me} = *{*$fh}; # Alias self to handle
- bless $fh; # Really wan't un-bless here
+ *{*$me} = *{*$fh}; # Alias self to handle
+ bless $fh, 'IO::Pipe::DeadEnd'; # Really wan't un-bless here
${*$me}{'io_pipe_pid'} = $pid
if defined $pid;
my $pid = $me->_doit(1,@_)
if(@_);
+ close(${*$me}[0]);
bless $me, ref($fh);
- *{*$me} = *{*$fh}; # Alias self to handle
- bless $fh; # Really wan't un-bless here
+ *{*$me} = *{*$fh}; # Alias self to handle
+ bless $fh, 'IO::Pipe::DeadEnd'; # Really wan't un-bless here
${*$me}{'io_pipe_pid'} = $pid
if defined $pid;
Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt>
-=head1 REVISION
-
-$Revision: 1.5 $
-
=cut
require 5.000;
use Carp;
+use strict;
use vars qw($VERSION @EXPORT @ISA);
use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
require Exporter;
@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
@ISA = qw(Exporter);
-$VERSION = sprintf("%d.%02d", q$Revision: 1.5 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "1.06";
sub clearerr {
@_ == 1 or croak 'usage: $fh->clearerr()';
# IO::Select.pm
+#
+# Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+# software; you can redistribute it and/or modify it under the same terms
+# as Perl itself.
package IO::Select;
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 then the call will block.
+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 ] )
=item has_error ( [ TIMEOUT ] )
-Same as C<can_read> except check for handles that have an error condition, for
-example EOF.
+Same as C<can_read> except check for handles that have an error
+condition, for example EOF.
=item count ()
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
-before.
+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
Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
-=head1 REVISION
-
-$Revision: 1.9 $
-
=head1 COPYRIGHT
Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
use vars qw($VERSION @ISA);
require Exporter;
-$VERSION = sprintf("%d.%02d", q$Revision: 1.9 $ =~ /(\d+)\.(\d+)/);
+$VERSION = "1.10";
@ISA = qw(Exporter); # This is only so we can do version checking
-sub VEC_BITS {0}
-sub FD_COUNT {1}
-sub FIRST_FD {2}
+sub VEC_BITS () {0}
+sub FD_COUNT () {1}
+sub FIRST_FD () {2}
sub new
{
sub add
{
+ shift->_update('add', @_);
+}
+
+
+sub remove
+{
+ shift->_update('remove', @_);
+}
+
+
+sub exists
+{
my $vec = shift;
- my $f;
+ $vec->[$vec->_fileno(shift) + FIRST_FD];
+}
- $vec->[VEC_BITS] = '' unless defined $vec->[VEC_BITS];
- foreach $f (@_)
- {
- my $fn = $f =~ /^\d+$/ ? $f : fileno($f);
- next
- unless defined $fn;
- vec($vec->[VEC_BITS],$fn,1) = 1;
- $vec->[FD_COUNT] += 1
- unless defined $vec->[$fn+FIRST_FD];
- $vec->[$fn+FIRST_FD] = $f;
- }
- $vec->[VEC_BITS] = undef unless $vec->count;
+sub _fileno
+{
+ my($self, $f) = @_;
+ $f = $f->[0] if ref($f) eq 'ARRAY';
+ ($f =~ /^\d+$/) ? $f : fileno($f);
}
-sub remove
+sub _update
{
my $vec = shift;
- my $f;
+ my $add = shift eq 'add';
+ my $bits = $vec->[VEC_BITS];
+ $bits = '' unless defined $bits;
+
+ my $count = 0;
+ my $f;
foreach $f (@_)
{
- my $fn = $f =~ /^\d+$/ ? $f : fileno($f);
- next
- unless defined $fn;
- vec($vec->[VEC_BITS],$fn,1) = 0;
- $vec->[$fn+FIRST_FD] = undef;
- $vec->[FD_COUNT] -= 1;
+ my $fn = $vec->_fileno($f);
+ next unless defined $fn;
+ my $i = $fn + FIRST_FD;
+ if ($add) {
+ if (defined $vec->[$i]) {
+ $vec->[$i] = $f; # if array rest might be different, so we update
+ next;
+ }
+ $vec->[FD_COUNT]++;
+ vec($bits, $fn, 1) = 1;
+ $vec->[$i] = $f;
+ } else { # remove
+ next unless defined $vec->[$i];
+ $vec->[FD_COUNT]--;
+ vec($bits, $fn, 1) = 0;
+ $vec->[$i] = undef;
+ }
+ $count++;
}
- $vec->[VEC_BITS] = undef unless $vec->count;
+ $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef;
+ $count;
}
sub can_read
my $r = $vec->[VEC_BITS];
defined($r) && (select($r,undef,undef,$timeout) > 0)
- ? _handles($vec, $r)
+ ? handles($vec, $r)
: ();
}
my $w = $vec->[VEC_BITS];
defined($w) && (select(undef,$w,undef,$timeout) > 0)
- ? _handles($vec, $w)
+ ? handles($vec, $w)
: ();
}
my $e = $vec->[VEC_BITS];
defined($e) && (select(undef,undef,$e,$timeout) > 0)
- ? _handles($vec, $e)
+ ? handles($vec, $e)
: ();
}
$vec->[FD_COUNT];
}
+sub bits
+{
+ my $vec = shift;
+ $vec->[VEC_BITS];
+}
+
+sub as_string # for debugging
+{
+ my $vec = shift;
+ my $str = ref($vec) . ": ";
+ my $bits = $vec->bits;
+ my $count = $vec->count;
+ $str .= defined($bits) ? unpack("b*", $bits) : "undef";
+ $str .= " $count";
+ my @handles = @$vec;
+ splice(@handles, 0, FIRST_FD);
+ for (@handles) {
+ $str .= " " . (defined($_) ? "$_" : "-");
+ }
+ $str;
+}
+
sub _max
{
my($a,$b,$c) = @_;
my @result = ();
my $rb = defined $r ? $r->[VEC_BITS] : undef;
- my $wb = defined $w ? $e->[VEC_BITS] : undef;
- my $eb = defined $e ? $w->[VEC_BITS] : undef;
+ my $wb = defined $w ? $w->[VEC_BITS] : undef;
+ my $eb = defined $e ? $e->[VEC_BITS] : undef;
if(select($rb,$wb,$eb,$t) > 0)
{
@result;
}
-sub _handles
+
+sub handles
{
my $vec = shift;
my $bits = shift;
my @h = ();
my $i;
+ my $max = scalar(@$vec) - 1;
- for($i = scalar(@$vec) - 1 ; $i >= FIRST_FD ; $i--)
+ for ($i = FIRST_FD; $i <= $max; $i++)
{
next unless defined $vec->[$i];
push(@h, $vec->[$i])
- if vec($bits,$i - FIRST_FD,1);
+ if !defined($bits) || vec($bits, $i - FIRST_FD, 1);
}
@h;
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 a C<IO::Pipe>, which is a reference to a
+Creates a 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
=item sockdomain
-Returns the numerical number for the socket domain type. For example, fir
+Returns the numerical number for the socket domain type. For example, for
a AF_INET socket the value of &AF_INET will be returned.
=item socktype
-Returns the numerical number for the socket type. For example, fir
+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
use Socket 1.3;
use Carp;
use strict;
-use vars qw(@ISA @EXPORT_OK $VERSION);
+use vars qw(@ISA $VERSION);
use Exporter;
@ISA = qw(IO::Handle);
-# This one will turn 1.2 => 1.02 and 1.2.3 => 1.0203 and so on ...
-
-$VERSION = do{my @r=(q$Revision: 1.13 $=~/(\d+)/g);sprintf "%d."."%02d"x$#r,@r};
+$VERSION = "1.15";
sub import {
my $pkg = shift;
croak 'IO::Socket: Cannot configure a generic socket'
unless defined $domain;
- my $sub = ref(_domain2pkg($domain)) . "::configure";
+ my $class = ref(_domain2pkg($domain));
- goto &{$sub}
- if(defined &{$sub});
+ croak "IO::Socket: Cannot configure socket in domain '$domain'"
+ unless ref($fh) eq "IO::Socket";
- croak "IO::Socket: Cannot configure socket in domain '$domain' $sub";
+ bless($fh, $class);
+ $fh->configure;
}
sub socket {
${*$fh}{'io_socket_protocol'};
}
-sub _addmethod {
- my $self = shift;
- my $name;
-
- foreach $name (@_) {
- my $n = $name;
-
- no strict qw(refs);
-
- *{$n} = sub {
- my $pkg = ref(${*{$_[0]}}{'io_socket_domain'});
- my $sub = "${pkg}::${n}";
- goto &{$sub} if defined &{$sub};
- croak qq{Can't locate object method "$n" via package "$pkg"};
- }
- unless defined &{$n};
- }
-
-}
-
-
=head1 SUB-CLASSES
=cut
package IO::Socket::INET;
use strict;
-use vars qw(@ISA $VERSION);
+use vars qw(@ISA);
use Socket;
use Carp;
use Exporter;
@ISA = qw(IO::Socket);
-IO::Socket::INET->_addmethod( qw(sockaddr sockport sockhost peeraddr peerport peerhost));
IO::Socket::INET->register_domain( AF_INET );
my %socket_type = ( tcp => SOCK_STREAM,
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
- PeerPort Remote port or service
- LocalPort Local host bind port
- LocalAddr Local host bind address
- Proto Protocol name (eg tcp udp etc)
- Type Socket type (SOCK_STREAM etc)
+ 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 "tcp" | "udp" | ...
+ Type Socket type SOCK_STREAM | SOCK_DGRAM | ...
Listen Queue size for listen
+ Reuse Set SO_REUSEADDR before binding
Timeout Timeout value for various operations
-If Listen is defined then a listen socket is created, else if the socket
-type, which is derived from the protocol, is SOCK_STREAM then a connect
-is called.
+If C<Listen> is defined then a listen socket is created, else if the
+socket type, which is derived from the protocol, is SOCK_STREAM then
+connect() is called.
+
+The C<PeerAddr> can be a hostname or the IP-address on the
+"xx.xx.xx.xx" form. The C<PeerPort> can be a number or a symbolic
+service name. The service name might be followed by a number in
+parenthesis which is used if the service is not known by the system.
+The C<PeerPort> specification can also be embedded in the C<PeerAddr>
+by preceding it with a ":".
+
+Only one of C<Type> or C<Proto> needs to be specified, one will be
+assumed from the other. If you specify a symbolic C<PeerPort> port,
+then the constructor will try to derive C<Type> and C<Proto> from
+the service name.
-Only one of C<Type> or C<Proto> needs to be specified, one will be assumed
-from the other.
+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');
=head2 METHODS
=cut
-
sub _sock_info {
my($addr,$port,$proto) = @_;
my @proto = ();
sub _error {
my $fh = shift;
- carp join("",ref($fh),": ",@_) if @_;
+ $@ = join("",ref($fh),": ",@_);
+ carp $@ if $^W;
close($fh)
if(defined fileno($fh));
return undef;
${*$fh}{'io_socket_domain'} = bless \$domain;
$fh->socket(AF_INET, $type, $proto) or
- return _error($fh);
+ return _error($fh,"$!");
+
+ if ($arg->{Reuse}) {
+ $fh->sockopt(SO_REUSEADDR,1) or
+ return _error($fh);
+ }
$fh->bind($lport || 0, $laddr) or
- return _error($fh);
+ return _error($fh,"$!");
if(exists $arg->{Listen}) {
$fh->listen($arg->{Listen} || 5) or
- return _error($fh);
+ return _error($fh,"$!");
}
else {
return _error($fh,'Cannot determine remote port')
unless(defined $raddr);
$fh->connect($rport,$raddr) or
- return _error($fh);
+ return _error($fh,"$!");
}
}
@ISA = qw(IO::Socket);
-IO::Socket::UNIX->_addmethod(qw(hostpath peerpath));
IO::Socket::UNIX->register_domain( AF_UNIX );
=head2 IO::Socket::UNIX
=item hostpath()
-Returns the pathname to the fifo at the local end.
+Returns the pathname to the fifo at the local end
=item peerpath()
-Returns the pathanme to the fifo at the peer end.
+Returns the pathanme to the fifo at the peer end
=back
sub hostpath {
@_ == 1 or croak 'usage: $fh->hostpath()';
my $n = $_[0]->sockname || return undef;
-warn length($n);
(sockaddr_un($n))[0];
}
sub peerpath {
@_ == 1 or croak 'usage: $fh->peerpath()';
my $n = $_[0]->peername || return undef;
-warn length($n);
-my @n = sockaddr_un($n);
-warn join(",",@n);
(sockaddr_un($n))[0];
}
-=head1 AUTHOR
-
-Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
+=head1 SEE ALSO
-=head1 REVISION
+L<Socket>, L<IO::Handle>
-$Revision: 1.13 $
-
-The VERSION is derived from the revision turning each number after the
-first dot into a 2 digit number so
+=head1 AUTHOR
- Revision 1.8 => VERSION 1.08
- Revision 1.2.3 => VERSION 1.0203
+Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
=head1 COPYRIGHT
if (SvTYPE(topgv) != SVt_PVGV)
gv_init(topgv, stash, name, len, TRUE);
- if (cv=GvCV(topgv)) {
- if (GvCVGEN(topgv) >= sub_generation)
- return topgv; /* valid cached inheritance */
- if (!GvCVGEN(topgv)) { /* not an inheritance cache */
- return topgv;
- }
- else {
- /* stale cached entry, just junk it */
- GvCV(topgv) = cv = 0;
- GvCVGEN(topgv) = 0;
+ if (cv = GvCV(topgv)) {
+ if (CvXSUB(cv) || CvROOT(cv) || CvGV(cv)) { /* Not deleted, possibly autoloaded. */
+ if (GvCVGEN(topgv) >= sub_generation)
+ return topgv; /* valid cached inheritance */
+ if (!GvCVGEN(topgv)) { /* not an inheritance cache */
+ return topgv;
+ }
}
+ /* stale cached entry, just junk it */
+ SvREFCNT_dec(cv);
+ GvCV(topgv) = cv = 0;
+ GvCVGEN(topgv) = 0;
}
- /* if cv is still set, we have to free it if we find something to cache */
+ /* Now cv = 0, and there is no cv in topgv. */
gvp = (GV**)hv_fetch(stash,"ISA",3,FALSE);
if (gvp && (gv = *gvp) != (GV*)&sv_undef && (av = GvAV(gv))) {
}
gv = gv_fetchmeth(basestash, name, len, level + 1);
if (gv) {
- if (cv) { /* junk old undef */
- assert(SvREFCNT(topgv) > 1);
- SvREFCNT_dec(topgv);
- SvREFCNT_dec(cv);
- }
GvCV(topgv) = GvCV(gv); /* cache the CV */
GvCVGEN(topgv) = sub_generation; /* valid for now */
+ SvREFCNT_inc(GvCV(gv));
return gv;
}
}
if (!level) {
if (lastchance = gv_stashpvn("UNIVERSAL", 9, FALSE)) {
if (gv = gv_fetchmeth(lastchance, name, len, level + 1)) {
- if (cv) { /* junk old undef */
- assert(SvREFCNT(topgv) > 1);
- SvREFCNT_dec(topgv);
- SvREFCNT_dec(cv);
- }
GvCV(topgv) = GvCV(gv); /* cache the CV */
GvCVGEN(topgv) = sub_generation; /* valid for now */
+ SvREFCNT_inc(GvCV(gv));
return gv;
}
}
case `uname -r` in
6.1*) shellflags="-m+65536" ;;
esac
-ccflags="$ccflags -DHZ=__hertz"
optimize="-O1"
-libswanted=m
d_setregid='undef'
d_setreuid='undef'
--- /dev/null
+optimize="-O1"
+d_setregid='undef'
+d_setreuid='undef'
{
if (!hent)
return;
- if (SvTYPE(HeVAL(hent)) == SVt_PVGV)
+ if (SvTYPE(HeVAL(hent)) == SVt_PVGV && GvCV(HeVAL(hent)))
sub_generation++; /* May be deletion of method? */
SvREFCNT_dec(HeVAL(hent));
if (HeKLEN(hent) == HEf_SVKEY) {
sub bits {
my $bits = 0;
+ my $sememe;
foreach $sememe (@_) {
- $bits |= 0x00000002 if $sememe eq 'refs';
- $bits |= 0x00000200 if $sememe eq 'subs';
- $bits |= 0x00000400 if $sememe eq 'vars';
+ $bits |= 0x00000002, next if $sememe eq 'refs';
+ $bits |= 0x00000200, next if $sememe eq 'subs';
+ $bits |= 0x00000400, next if $sememe eq 'vars';
}
$bits;
}
return 0;
}
+#ifdef USE_LOCALE_COLLATE
int
magic_setcollxfrm(sv,mg)
SV* sv;
* René Descartes said "I think not."
* and vanished with a faint plop.
*/
- sv_unmagic(sv, 'o');
+ if (mg->mg_ptr) {
+ Safefree(mg->mg_ptr);
+ mg->mg_ptr = NULL;
+ mg->mg_len = -1;
+ }
return 0;
}
+#endif /* USE_LOCALE_COLLATE */
int
magic_set(sv,mg)
#define PATCHLEVEL 3
-#define SUBVERSION 15
+#define SUBVERSION 16
/*
local_patches -- list of locally applied less-than-subversion patches.
User/grent.pm Object-oriented wrapper around CORE::getgr*
User/pwent.pm Object-oriented wrapper around CORE::getpw*
+ lib/Tie/RefHash.pm Base class for tied hashes with references as keys
+
UNIVERSAL.pm Base class for *ALL* classes
=head2 IO
from innumerable contributors, with kibitzing by more than a few Perl
porters.
-Last update:
-Wed Dec 18 16:18:27 EST 1996
+Last update: Tue Dec 24 16:45:14 EST 1996
{
dSP; dATARGET; tryAMAGICbin(pow,opASSIGN);
{
- dPOPTOPnnrl;
+ dPOPTOPnnrl_ul;
SETn( pow( left, right) );
RETURN;
}
{
dSP; dATARGET; tryAMAGICbin(mult,opASSIGN);
{
- dPOPTOPnnrl;
+ dPOPTOPnnrl_ul;
SETn( left * right );
RETURN;
}
{
dSP; dATARGET; tryAMAGICbin(div,opASSIGN);
{
- dPOPnv;
- if (value == 0.0)
+ dPOPPOPnnrl_ul;
+ double value;
+ if (right == 0.0)
DIE("Illegal division by zero");
#ifdef SLOPPYDIVIDE
/* insure that 20./5. == 4. */
{
- double x;
- I32 k;
- x = POPn;
- if ((double)I_32(x) == x &&
- (double)I_32(value) == value &&
- (k = I_32(x)/I_32(value))*I_32(value) == I_32(x)) {
+ IV k;
+ if ((double)I_V(left) == left &&
+ (double)I_V(right) == right &&
+ (k = I_V(left)/I_V(right))*I_V(right) == I_V(left)) {
value = k;
} else {
- value = x/value;
+ value = left / right;
}
}
#else
- value = POPn / value;
+ value = left / right;
#endif
PUSHn( value );
RETURN;
SETi( left % right );
}
else {
- register double left = TOPn;
+ register double left = USE_LEFT(TOPs) ? SvNV(TOPs) : 0.0;
if (left < 0.0)
SETu( (right - (U_V(-left) - 1) % right) - 1 );
else
if (SvROK(tmpstr))
sv_unref(tmpstr);
}
- SvSetSV(TARG, tmpstr);
- SvPV_force(TARG, len);
- if (count >= 1) {
- SvGROW(TARG, (count * len) + 1);
- if (count > 1)
- repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
- SvCUR(TARG) *= count;
- *SvEND(TARG) = '\0';
+ if (USE_LEFT(tmpstr) || SvTYPE(tmpstr) > SVt_PVMG) {
+ SvSetSV(TARG, tmpstr);
+ SvPV_force(TARG, len);
+ if (count != 1) {
+ if (count < 1)
+ SvCUR_set(TARG, 0);
+ else {
+ SvGROW(TARG, (count * len) + 1);
+ repeatcpy(SvPVX(TARG) + len, SvPVX(TARG), len, count - 1);
+ SvCUR(TARG) *= count;
+ }
+ *SvEND(TARG) = '\0';
+ }
(void)SvPOK_only(TARG);
}
else
{
dSP; dATARGET; tryAMAGICbin(subtr,opASSIGN);
{
- dPOPTOPnnrl;
+ dPOPTOPnnrl_ul;
SETn( left - right );
RETURN;
}
#define dTOPuv UV value = TOPu
#define dPOPuv UV value = POPu
-#define dPOPPOPssrl SV *right = POPs; SV *left = POPs
-#define dPOPPOPnnrl double right = POPn; double left = POPn
-#define dPOPPOPiirl IV right = POPi; IV left = POPi
-
-#define dPOPTOPssrl SV *right = POPs; SV *left = TOPs
-#define dPOPTOPnnrl double right = POPn; double left = TOPn
-#define dPOPTOPiirl IV right = POPi; IV left = TOPi
+#define dPOPXssrl(X) SV *right = POPs; SV *left = CAT2(X,s)
+#define dPOPXnnrl(X) double right = POPn; double left = CAT2(X,n)
+#define dPOPXiirl(X) IV right = POPi; IV left = CAT2(X,i)
+
+#define USE_LEFT(sv) \
+ (SvOK(sv) || SvGMAGICAL(sv) || !(op->op_flags & OPf_STACKED))
+#define dPOPXnnrl_ul(X) \
+ double right = POPn; \
+ SV *leftsv = CAT2(X,s); \
+ double left = USE_LEFT(leftsv) ? SvNV(leftsv) : 0.0
+#define dPOPXiirl_ul(X) \
+ IV right = POPi; \
+ SV *leftsv = CAT2(X,s); \
+ IV left = USE_LEFT(leftsv) ? SvIV(leftsv) : 0
+
+#define dPOPPOPssrl dPOPXssrl(POP)
+#define dPOPPOPnnrl dPOPXnnrl(POP)
+#define dPOPPOPnnrl_ul dPOPXnnrl_ul(POP)
+#define dPOPPOPiirl dPOPXiirl(POP)
+#define dPOPPOPiirl_ul dPOPXiirl_ul(POP)
+
+#define dPOPTOPssrl dPOPXssrl(TOP)
+#define dPOPTOPnnrl dPOPXnnrl(TOP)
+#define dPOPTOPnnrl_ul dPOPXnnrl_ul(TOP)
+#define dPOPTOPiirl dPOPXiirl(TOP)
+#define dPOPTOPiirl_ul dPOPXiirl_ul(TOP)
#define RETPUSHYES RETURNX(PUSHs(&sv_yes))
#define RETPUSHNO RETURNX(PUSHs(&sv_no))
}
else if (SvGMAGICAL(TARG))
mg_get(TARG);
- else if (!SvOK(TARG)) {
- s = SvPV_force(TARG, len);
+ else if (!SvOK(TARG) && SvTYPE(TARG) <= SVt_PVMG) {
sv_setpv(TARG, ""); /* Suppress warning. */
+ s = SvPV_force(TARG, len);
}
s = SvPV(right,len);
sv_catpvn(TARG,s,len);
{
dSP; dATARGET; tryAMAGICbin(add,opASSIGN);
{
- dPOPTOPnnrl;
+ dPOPTOPnnrl_ul;
SETn( left + right );
RETURN;
}
if (cx->blk_loop.iterix >= (av == curstack ? cx->blk_oldsp : AvFILL(av)))
RETPUSHNO;
+ SvREFCNT_dec(*cx->blk_loop.itervar);
+
if (sv = AvARRAY(av)[++cx->blk_loop.iterix])
SvTEMP_off(sv);
else
LvTARGLEN(lv) = 1;
sv = (SV*)lv;
}
- *cx->blk_loop.itervar = sv;
+
+ *cx->blk_loop.itervar = SvREFCNT_inc(sv);
RETPUSHYES;
}
#endif
I32 debstack _((void));
void deprecate _((char* s));
-OP* die _((const char* pat,...))
- __attribute__((format(printf,1,2),noreturn));
+OP* die _((const char* pat,...)) __attribute__((format(printf,1,2)));
OP* die_where _((char* message));
void dounwind _((I32 cxix));
bool do_aexec _((SV* really, SV** mark, SV** sp));
}
}
-SV *
-save_scalar(gv)
-GV *gv;
+static SV *
+save_scalar_at(sptr)
+SV **sptr;
{
register SV *sv;
- SV *osv = GvSV(gv);
-
- SSCHECK(3);
- SSPUSHPTR(gv);
- SSPUSHPTR(osv);
- SSPUSHINT(SAVEt_SV);
+ SV *osv = *sptr;
- sv = GvSV(gv) = NEWSV(0,0);
+ sv = *sptr = NEWSV(0,0);
if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
sv_upgrade(sv, SvTYPE(osv));
if (SvGMAGICAL(osv)) {
return sv;
}
+SV *
+save_scalar(gv)
+GV *gv;
+{
+ SSCHECK(3);
+ SSPUSHPTR(gv);
+ SSPUSHPTR(GvSV(gv));
+ SSPUSHINT(SAVEt_SV);
+ return save_scalar_at(&GvSV(gv));
+}
+
+SV*
+save_svref(sptr)
+SV **sptr;
+{
+ SSCHECK(3);
+ SSPUSHPTR(sptr);
+ SSPUSHPTR(*sptr);
+ SSPUSHINT(SAVEt_SVREF);
+ return save_scalar_at(sptr);
+}
+
void
save_gp(gv, empty)
GV *gv;
}
}
-SV*
-save_svref(sptr)
-SV **sptr;
-{
- register SV *sv;
- SV *osv = *sptr;
-
- SSCHECK(3);
- SSPUSHPTR(*sptr);
- SSPUSHPTR(sptr);
- SSPUSHINT(SAVEt_SVREF);
-
- sv = *sptr = NEWSV(0,0);
- if (SvTYPE(osv) >= SVt_PVMG && SvMAGIC(osv) && SvTYPE(osv) != SVt_PVGV) {
- sv_upgrade(sv, SvTYPE(osv));
- if (SvGMAGICAL(osv)) {
- MAGIC* mg;
- bool oldtainted = tainted;
- mg_get(osv);
- if (tainting && tainted && (mg = mg_find(osv, 't'))) {
- SAVESPTR(mg->mg_obj);
- mg->mg_obj = osv;
- }
- SvFLAGS(osv) |= (SvFLAGS(osv) &
- (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
- tainted = oldtainted;
- }
- SvMAGIC(sv) = SvMAGIC(osv);
- SvFLAGS(sv) |= SvMAGICAL(osv);
- localizing = 1;
- SvSETMAGIC(sv);
- localizing = 0;
- }
- return sv;
-}
-
AV *
save_ary(gv)
GV *gv;
case SAVEt_SV: /* scalar reference */
value = (SV*)SSPOPPTR;
gv = (GV*)SSPOPPTR;
- sv = GvSV(gv);
- if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
- SvTYPE(sv) != SVt_PVGV)
- {
- (void)SvUPGRADE(value, SvTYPE(sv));
- SvMAGIC(value) = SvMAGIC(sv);
- SvFLAGS(value) |= SvMAGICAL(sv);
- SvMAGICAL_off(sv);
- SvMAGIC(sv) = 0;
- }
- SvREFCNT_dec(sv);
- GvSV(gv) = value;
- localizing = 2;
- SvSETMAGIC(value);
- localizing = 0;
- break;
+ ptr = &GvSV(gv);
+ goto restore_sv;
case SAVEt_SVREF: /* scalar reference */
+ value = (SV*)SSPOPPTR;
ptr = SSPOPPTR;
+ restore_sv:
sv = *(SV**)ptr;
- value = (SV*)SSPOPPTR;
if (SvTYPE(sv) >= SVt_PVMG && SvMAGIC(sv) &&
SvTYPE(sv) != SVt_PVGV)
{
SvMAGICAL_off(sv);
SvMAGIC(sv) = 0;
}
+ else if (SvTYPE(value) >= SVt_PVMG && SvMAGIC(value) &&
+ SvTYPE(value) != SVt_PVGV)
+ {
+ SvFLAGS(value) |= (SvFLAGS(value) &
+ (SVp_IOK|SVp_NOK|SVp_POK)) >> PRIVSHIFT;
+ SvMAGICAL_off(value);
+ SvMAGIC(value) = 0;
+ }
SvREFCNT_dec(sv);
*(SV**)ptr = value;
localizing = 2;
if (cx->blk_loop.itervar)
PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERSAVE = 0x%lx\n",
(long)cx->blk_loop.itersave);
+ PerlIO_printf(Perl_debug_log, "BLK_LOOP.ITERLVAL = 0x%lx\n",
+ (long)cx->blk_loop.iterlval);
break;
case CXt_SUBST:
(CvROOT(cv) || CvXSUB(cv)) )
warn("Subroutine %s redefined",
GvENAME((GV*)dstr));
- SvFAKE_on(cv);
+ if (SvREFCNT(cv) == 1)
+ SvFAKE_on(cv);
}
}
+ sub_generation++;
if (GvCV(dstr) != (CV*)sref) {
GvCV(dstr) = (CV*)sref;
+ GvCVGEN(dstr) = 0; /* Switch off cacheness. */
GvASSUMECV_on(dstr);
}
if (curcop->cop_stash != GvSTASH(dstr))
}
#ifdef USE_LOCALE_COLLATE
-
+/*
+ * Any scalar variable may carry an 'o' magic that contains the
+ * scalar data of the variable transformed to such a format that
+ * a normal memory comparison can be used to compare the data
+ * according to the locale settings.
+ */
char *
sv_collxfrm(sv, nxp)
SV *sv;
STRLEN *nxp;
{
- /* Any scalar variable may carry an 'o' magic that contains the
- * scalar data of the variable transformed to such a format that
- * a normal memory comparison can be used to compare the data
- * according to the locale settings. */
+ MAGIC *mg;
- MAGIC *mg = NULL;
-
- if (SvMAGICAL(sv)) {
- mg = mg_find(sv, 'o');
- if (mg && *(U32*)mg->mg_ptr != collation_ix)
- mg = NULL;
- }
-
- if (! mg) {
+ mg = SvMAGICAL(sv) ? mg_find(sv, 'o') : NULL;
+ if (!mg || !mg->mg_ptr || *(U32*)mg->mg_ptr != collation_ix) {
char *s, *xf;
STRLEN len, xlen;
+ if (mg)
+ Safefree(mg->mg_ptr);
s = SvPV(sv, len);
if ((xf = mem_collxfrm(s, len, &xlen))) {
- sv_magic(sv, 0, 'o', 0, 0);
- if ((mg = mg_find(sv, 'o'))) {
- mg->mg_ptr = xf;
- mg->mg_len = xlen;
+ if (! mg) {
+ sv_magic(sv, 0, 'o', 0, 0);
+ mg = mg_find(sv, 'o');
+ assert(mg);
}
+ mg->mg_ptr = xf;
+ mg->mg_len = xlen;
+ }
+ else {
+ mg->mg_ptr = NULL;
+ mg->mg_len = -1;
}
}
-
- if (mg) {
+ if (mg && mg->mg_ptr) {
*nxp = mg->mg_len;
return mg->mg_ptr + sizeof(collation_ix);
}
#!./perl
BEGIN {
- @INC = '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
- print "1..0\n";
- exit 0;
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
}
}
#!./perl
+
BEGIN {
- @INC = '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
- print "1..0\n";
- exit 0;
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
}
}
}
else
{
- die "# error = $!";
+ die;
}
$pipe = new IO::Pipe;
+#!./perl
+
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+select(STDERR); $| = 1;
+select(STDOUT); $| = 1;
+
+print "1..21\n";
+
+use IO::Select 1.09;
+
+my $sel = new IO::Select(\*STDIN);
+$sel->add(4, 5) == 2 or print "not ";
+print "ok 1\n";
+
+$sel->add([\*STDOUT, 'foo']) == 1 or print "not ";
+print "ok 2\n";
+
+@handles = $sel->handles;
+print "not " unless $sel->count == 4 && @handles == 4;
+print "ok 3\n";
+#print $sel->as_string, "\n";
+
+$sel->remove(\*STDIN) == 1 or print "not ";
+print "ok 4\n",
+;
+$sel->remove(\*STDIN, 5, 6) == 1 # two of there are not present
+ or print "not ";
+print "ok 5\n";
+
+print "not " unless $sel->count == 2;
+print "ok 6\n";
+#print $sel->as_string, "\n";
+
+$sel->remove(1, 4);
+print "not " unless $sel->count == 0 && !defined($sel->bits);
+print "ok 7\n";
+
+$sel = new IO::Select;
+print "not " unless $sel->count == 0 && !defined($sel->bits);
+print "ok 8\n";
+
+$sel->remove([\*STDOUT, 5]);
+print "not " unless $sel->count == 0 && !defined($sel->bits);
+print "ok 9\n";
+
+@a = $sel->can_read(); # should return imediately
+print "not " unless @a == 0;
+print "ok 10\n";
+
+# we assume that we can write to STDOUT :-)
+$sel->add([\*STDOUT, "ok 12\n"]);
+
+@a = $sel->can_write;
+print "not " unless @a == 1;
+print "ok 11\n";
+
+my($fd, $msg) = @{shift @a};
+print $fd $msg;
+
+$sel->add(\*STDOUT); # update
+
+@a = IO::Select::select(undef, $sel, undef, 1);
+print "not " unless @a == 3;
+print "ok 13\n";
+
+($r, $w, $e) = @a;
+
+print "not " unless @$r == 0 && @$w == 1 && @$e == 0;
+print "ok 14\n";
+
+$fd = $w->[0];
+print $fd "ok 15\n";
+
+# Test new exists() method
+$sel->exists(\*STDIN) and print "not ";
+print "ok 16\n";
+
+($sel->exists(0) || $sel->exists([\*STDERR])) and print "not ";
+print "ok 17\n";
+
+$fd = $sel->exists(\*STDOUT);
+if ($fd) {
+ print $fd "ok 18\n";
+} else {
+ print "not ok 18\n";
+}
+
+$fd = $sel->exists([1, 'foo']);
+if ($fd) {
+ print $fd "ok 19\n";
+} else {
+ print "not ok 19\n";
+}
+
+# Try self clearing
+$sel->add(5,6,7,8,9,10);
+print "not " unless $sel->count == 7;
+print "ok 20\n";
+
+$sel->remove($sel->handles);
+print "not " unless $sel->count == 0 && !defined($sel->bits);
+print "ok 21\n";
#!./perl
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib' if -d '../lib';
- require Config; import Config;
- if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
- $Config{'extensions'} !~ /\bIO\b/) &&
- !(($^O eq 'VMS') && $Config{d_socket})) {
- print "1..0\n";
- exit 0;
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
+ $Config{'extensions'} !~ /\bIO\b/) &&
+ !(($^O eq 'VMS') && $Config{d_socket})) {
+ print "1..0\n";
+ exit 0;
+ }
}
}
use IO::Socket;
-srand(time);
-$port = 4002 + int(rand 0xff);
-print "# using port $port.\n";
-$SIG{ALRM} = sub {};
-
-$pid = fork();
-
-if($pid) {
+$listen = IO::Socket::INET->new(Listen => 2,
+ Proto => 'tcp',
+ ) or die "$!";
- $listen = IO::Socket::INET->new(Listen => 2,
- Proto => 'tcp',
- LocalPort => $port
- ) or die "$!";
+print "ok 1\n";
- print "ok 1\n";
+$port = $listen->sockport;
- # Wake out child
- kill(ALRM => $pid);
+if($pid = fork()) {
$sock = $listen->accept();
print "ok 2\n";
waitpid($pid,0);
print "ok 5\n";
-} elsif(defined $pid) {
-
- # Wait for a small pause, so that we can ensure the listen socket is setup
- # the parent will awake us with a SIGALRM
- sleep(10);
+} elsif(defined $pid) {
$sock = IO::Socket::INET->new(PeerPort => $port,
Proto => 'tcp',
) or die "$!";
$sock->autoflush(1);
+
print $sock "ok 3\n";
+
print $sock->getline();
+
$sock->close;
+
exit;
} else {
die;
#!./perl
-# $RCSfile: tell.t,v $$Revision: 1.1 $$Date: 1996/05/01 10:52:47 $
+BEGIN {
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ $tell_file = "TEST";
+ }
+ else {
+ $tell_file = "Makefile";
+ }
+}
+
+use Config;
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib' if -d '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bIO\b/ && !($^O eq 'VMS')) {
- print "1..0\n";
- exit 0;
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
}
}
use IO::File;
-$tst = IO::File->new("TEST","r") || die("Can't open TEST");
+$tst = IO::File->new("$tell_file","r") || die("Can't open $tell_file");
if ($tst->eof) { print "not ok 1\n"; } else { print "ok 1\n"; }
#!./perl
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib' if -d '../lib';
- require Config; import Config;
- if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
- $Config{'extensions'} !~ /\bIO\b/ ||
- $^O eq 'os2') &&
- !(($^O eq 'VMS') && $Config{d_socket})) {
- print "1..0\n";
- exit 0;
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ( ($Config{'extensions'} !~ /\bSocket\b/ ||
+ $Config{'extensions'} !~ /\bIO\b/ ||
+ $^O eq 'os2') &&
+ !(($^O eq 'VMS') && $Config{d_socket})) {
+ print "1..0\n";
+ exit 0;
+ }
}
}
print "ok 1\n";
$udpa->send("ok 2\n",0,$udpb->sockname);
-$rem = $udpb->recv($buf="",5);
+$udpb->recv($buf="",5);
print $buf;
$udpb->send("ok 3\n");
$udpa->recv($buf="",5);
#!./perl
-$| = 1;
BEGIN {
- chdir 't' if -d 't';
- @INC = '../lib' if -d '../lib';
- require Config; import Config;
- if ($Config{'extensions'} !~ /\bIO\b/ && !($^O eq 'VMS')) {
- print "1..0\n";
- exit 0;
+ unless(grep /blib/, @INC) {
+ chdir 't' if -d 't';
+ @INC = '../lib' if -d '../lib';
+ }
+}
+
+use Config;
+
+BEGIN {
+ if(-d "lib" && -f "TEST") {
+ if ($Config{'extensions'} !~ /\bIO\b/ && $^O ne 'VMS') {
+ print "1..0\n";
+ exit 0;
+ }
}
}
projects / platform / upstream / perl.git / commitdiff