diff options
author | Perl 5 Porters <perl5-porters@africa.nicoh.com> | 1997-01-25 15:58:00 +1200 |
---|---|---|
committer | Chip Salzenberg <chip@atlantic.net> | 1997-01-25 15:58:00 +1200 |
commit | 774d564bb7dd1ed64ca0d7e534aa67e93f991f02 (patch) | |
tree | 2e8fac95be59aed598a9217a2911632612d07854 /ext | |
parent | 9e3a2af888982d0a201149cbcdbf3feb6771acb4 (diff) | |
parent | bbad36071d5a6d4be3588f0f10c88247439076d8 (diff) | |
download | perl-774d564bb7dd1ed64ca0d7e534aa67e93f991f02.tar.gz |
[inseparable changes from patch from perl5.003_22 to perl5.003_23]perl-5.003_23
BUILD PROCESS
Subject: Make configure.gnu a copy of configure; make configure writea
From: Chip Salzenberg <chip@atlantic.net>
Files: MANIFEST configure.gnu
Subject: Regen Configure with metaconfig: +ARCHNAME, -FILE_filbuf
From: Chip Salzenberg <chip@perl.com>
Files: Configure config_H config_h.SH hints/lynxos.sh os2/diff.configure os2/os2ish.h plan9/config.plan9 sv.c utils/perlbug.PL vms/config.vms vms/fndvers.com
Subject: Compile with optimization when testing memory functions
From: Chip Salzenberg <chip@atlantic.net>
Files: Configure
CORE LANGUAGE CHANGES
Subject: Disallow changing $_[0] in __DIE__ handlers
From: Chip Salzenberg <chip@atlantic.net>
Files: pod/perlfunc.pod util.c
Subject: Fix overloading with inheritance and AUTOLOAD
Date: Mon, 20 Jan 1997 17:26:32 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: gv.c lib/diagnostics.pm lib/overload.pm pod/perldebug.pod pod/perldiag.pod pod/perlfunc.pod pod/perlop.pod pod/perlre.pod pod/perltoc.pod pod/perlxs.pod
Msg-ID: <199701202226.RAA05072@monk.mps.ohio-state.edu>
(applied based on p5p patch as commit e7ea3e70155d0bea30720ba41eb6bb6742aac0d1)
Subject: Nested here-docs
Date: Mon, 20 Jan 1997 15:13:42 -0800
From: Larry Wall <larry@wall.org>
Files: toke.c
Msg-ID: <199701202313.PAA11693@wall.org>
(applied based on p5p patch as commit fd2d0953290ddd46f0820dbd6c87245486b7ab28)
Subject: Revert $^X to old behavior (plus HP-UX bug fix)
From: Chip Salzenberg <chip@atlantic.net>
Files: hints/hpux.sh toke.c
Subject: Protect against '0' in 'stmt while <HANDLE>'
From: Chip Salzenberg <chip@atlantic.net>
Files: op.c
Subject: Don't warn when closure uses var at file scope
From: Chip Salzenberg <chip@atlantic.net>
Files: op.c
CORE PORTABILITY
Subject: VMS patches for _22
Date: Mon, 20 Jan 1997 22:50:21 -0500 (EST)
From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
Files: ext/POSIX/POSIX.xs lib/ExtUtils/MM_VMS.pm lib/ExtUtils/xsubpp lib/Test/Harness.pm toke.c vms/Makefile vms/descrip.mms vms/genconfig.pl vms/perly_c.vms vms/vmsish.h x2p/a2p.h vms/Makefile vms/config.vms vms/descrip.mms vms/perly_c.vms
private-msgid: <01IEGBJ2TMYS003PCL@hmivax.humgen.upenn.edu>
Subject: Plan9 update
From: Luther Huffman <lutherh@stratcom.com>
Files: plan9/config.plan9 plan9/mkfile
Subject: hints & Configure changes to build perl on DC/OSx
Date: Thu, 16 Jan 1997 16:43:52 -0800
From: Stephen Zander <stephen.zander@interlock.mckesson.com>
Files: Configure MANIFEST hints/dcosx.sh
Msg-ID: <199701170043.QAA25985@wsbip1.mckesson.com>
(applied based on p5p patch as commit 23f8769697279d7912be5943de9fdf93f6aa3013)
DOCUMENTATION
Subject: Additional docs for __DIE__ and __WARN__
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: pod/perlfunc.pod pod/perlrun.pod pod/perlvar.pod
Subject: Document #line directive
Date: Fri, 24 Jan 1997 04:08:44 -0500
From: Gurusamy Sarathy <gsar@engin.umich.edu>
Files: pod/perlsyn.pod pod/perltoc.pod
private-msgid: <199701240908.EAA23846@aatma.engin.umich.edu>
Subject: delta for perldelta
Date: Fri, 24 Jan 1997 07:57:43 -0800
From: Tom Christiansen <tchrist@mox.perl.com>
Files: pod/perlnews.pod pod/perltoc.pod
private-msgid: <804.854121463@jinete>
Subject: Updates to perldelta
Date: Mon, 20 Jan 1997 06:48:49 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: pod/perlnews.pod pod/perltoc.pod
private-msgid: <199701211610.LAA06227@monk.mps.ohio-state.edu>
Subject: perlnews.pod diff for the Fcntl
Date: Tue, 21 Jan 1997 18:00:56 +0200 (EET)
From: Jarkko Hietaniemi <jhi@cc.hut.fi>
Files: pod/perlnews.pod
private-msgid: <199701211600.SAA30117@alpha.hut.fi>
Subject: Rename perlnews -> perldelta per Tom's request
From: Chip Salzenberg <chip@atlantic.net>
Files: MANIFEST pod/Makefile pod/buildtoc pod/perl.pod pod/perldelta.pod pod/perltoc.pod pod/roffitall
LIBRARY AND EXTENSIONS
Subject: Refresh IO to 1.15 (plus DESTROY and new_tmpfile fixes)
From: Chip Salzenberg <chip@atlantic.net>
Files: 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/Socket.pm t/lib/io_pipe.t
Subject: Allow IO.xs to remain at 1.15 while $VERSION is 1.1501
From: Chip Salzenberg <chip@atlantic.net>
Files: XSUB.h ext/IO/Makefile.PL ext/IO/lib/IO/Handle.pm
Subject: Add E* and SA_* constants
Date: Wed, 22 Jan 1997 21:36:07 -0500
From: Roderick Schertler <roderick@gate.net>
Files: ext/POSIX/POSIX.pm ext/POSIX/POSIX.pod ext/POSIX/POSIX.xs
private-msgid: <23338.853986967@eeyore.ibcinc.com>
OTHER CORE CHANGES
Subject: Make PERL5LIB and -I work like C<use lib>
Date: Thu, 23 Jan 1997 15:23:27 +0000
From: Tim Bunce <Tim.Bunce@ig.co.uk>
Files: lib/lib.pm perl.c
private-msgid: <9701231523.AA26613@toad.ig.co.uk>
Subject: Fix /\G.a/
From: Chip Salzenberg <chip@atlantic.net>
Files: regcomp.c regcomp.h regexec.c regexp.h toke.c
Subject: Extend stack in pp_undef (!)
From: Chip Salzenberg <chip@atlantic.net>
Files: pp.c
Subject: Allow for sub to be redefined while executing
From: Chip Salzenberg <chip@atlantic.net>
Files: cop.h pp_hot.c t/op/misc.t
Subject: Eliminate redundant flag CVf_FORMAT
From: Chip Salzenberg <chip@atlantic.net>
Files: cv.h op.c perl.c perly.c perly.y proto.h sv.c toke.c
Subject: Generate IVs when possible in abs() and int()
From: Chip Salzenberg <chip@atlantic.net>
Files: pp.c
Subject: Efficiency patchlet for pp_aassign()
Date: Mon, 20 Jan 1997 22:05:39 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: pp_hot.c
Msg-ID: <199701210305.WAA05451@monk.mps.ohio-state.edu>
(applied based on p5p patch as commit 7e42bd57a6867e174bc3bc555c3268b485940a98)
Subject: Remove "suidperl security patch" message
From: Chip Salzenberg <chip@atlantic.net>
Files: perl.c
TESTS
Subject: Fix tests of $^X and $0 to work with QNX
From: Chip Salzenberg <chip@atlantic.net>
Files: t/lib/io_pipe.t t/lib/open2.t t/lib/open3.t t/op/magic.t
Subject: Patch tests for systems without fork()
Date: Thu, 23 Jan 1997 23:51:28 +0100
From: "Norbert Pueschel" <pueschel@imsdd.meb.uni-bonn.de>
Files: t/io/pipe.t t/lib/filehand.t t/lib/io_pipe.t t/lib/io_sock.t t/lib/open2.t t/lib/open3.t t/op/fork.t
private-msgid: <77724697@Armageddon.meb.uni-bonn.de>
Subject: Test patches for OS/2
Date: Thu, 16 Jan 1997 23:48:18 -0500 (EST)
From: Ilya Zakharevich <ilya@math.ohio-state.edu>
Files: os2/OS2/ExtAttr/t/os2_ea.t os2/OS2/PrfDB/t/os2_prfdb.t os2/OS2/REXX/t/rx_cmprt.t os2/OS2/REXX/t/rx_dllld.t os2/OS2/REXX/t/rx_objcall.t os2/OS2/REXX/t/rx_sql.test os2/OS2/REXX/t/rx_tiesql.test os2/OS2/REXX/t/rx_tievar.t os2/OS2/REXX/t/rx_tieydb.t os2/OS2/REXX/t/rx_varset.t os2/OS2/REXX/t/rx_vrexx.t t/README t/cmd/while.t t/comp/colon.t t/comp/multiline.t t/io/argv.t t/lib/anydbm.t t/lib/gdbm.t t/lib/ndbm.t t/lib/odbm.t t/lib/sdbm.t t/op/cmp.t t/op/magic.t
Msg-ID: <199701170448.XAA28948@monk.mps.ohio-state.edu>
(applied based on p5p patch as commit bbad36071d5a6d4be3588f0f10c88247439076d8)
UTILITIES
Subject: Translate \200 to È in pod2html
From: Chip Salzenberg <chip@atlantic.net>
Files: pod/pod2html.PL
Subject: VMS patches: '.com' extension on scripts
Date: Fri, 24 Jan 1997 18:42:29 -0500 (EST)
From: Charles Bailey <bailey@HMIVAX.HUMGEN.UPENN.EDU>
Files: pod/checkpods.PL pod/pod2html.PL pod/pod2latex.PL pod/pod2man.PL pod/pod2text.PL utils/c2ph.PL utils/h2ph.PL utils/h2xs.PL utils/perlbug.PL utils/perldoc.PL utils/pl2pm.PL utils/splain.PL vms/Makefile vms/descrip.mms x2p/find2perl.PL x2p/s2p.PL
private-msgid: <01IELNPDLYJM003E7J@hmivax.humgen.upenn.edu>
Diffstat (limited to 'ext')
-rw-r--r-- | ext/IO/Makefile.PL | 1 | ||||
-rw-r--r-- | ext/IO/lib/IO/File.pm | 13 | ||||
-rw-r--r-- | ext/IO/lib/IO/Handle.pm | 56 | ||||
-rw-r--r-- | ext/IO/lib/IO/Pipe.pm | 235 | ||||
-rw-r--r-- | ext/IO/lib/IO/Socket.pm | 45 | ||||
-rw-r--r-- | ext/POSIX/POSIX.pm | 31 | ||||
-rw-r--r-- | ext/POSIX/POSIX.pod | 17 | ||||
-rw-r--r-- | ext/POSIX/POSIX.xs | 296 |
8 files changed, 507 insertions, 187 deletions
diff --git a/ext/IO/Makefile.PL b/ext/IO/Makefile.PL index eb059bf8e7..4a34be61fb 100644 --- a/ext/IO/Makefile.PL +++ b/ext/IO/Makefile.PL @@ -4,4 +4,5 @@ WriteMakefile( MAN3PODS => ' ', # Pods will be built by installman. XSPROTOARG => '-noprototypes', # XXX remove later? VERSION_FROM => 'lib/IO/Handle.pm', + XS_VERSION => 1.15 ); diff --git a/ext/IO/lib/IO/File.pm b/ext/IO/lib/IO/File.pm index e44d77f1fe..0f8df001de 100644 --- a/ext/IO/lib/IO/File.pm +++ b/ext/IO/lib/IO/File.pm @@ -11,12 +11,12 @@ IO::File - supply object methods for filehandles use IO::File; $fh = new IO::File; - if ($fh->open "< file") { + if ($fh->open("< file")) { print <$fh>; $fh->close; } - $fh = new IO::File "> FOO"; + $fh = new IO::File "> file"; if (defined $fh) { print $fh "bar\n"; $fh->close; @@ -31,13 +31,12 @@ IO::File - supply object methods for filehandles $fh = new IO::File "file", O_WRONLY|O_APPEND; if (defined $fh) { print $fh "corge\n"; - undef $fh; # automatically closes the file - } - $pos = $fh->getpos; - $fh->setpos $pos; + $pos = $fh->getpos; + $fh->setpos($pos); - $fh->setvbuf($buffer_var, _IOLBF, 1024); + undef $fh; # automatically closes the file + } autoflush STDOUT 1; diff --git a/ext/IO/lib/IO/Handle.pm b/ext/IO/lib/IO/Handle.pm index 03118ee55e..135351fac0 100644 --- a/ext/IO/lib/IO/Handle.pm +++ b/ext/IO/lib/IO/Handle.pm @@ -1,3 +1,4 @@ + package IO::Handle; =head1 NAME @@ -9,39 +10,33 @@ IO::Handle - supply object methods for I/O handles use IO::Handle; $fh = new IO::Handle; - if ($fh->open "< file") { - print <$fh>; - $fh->close; - } - - $fh = new IO::Handle "> FOO"; - if (defined $fh) { - print $fh "bar\n"; + if ($fh->fdopen(fileno(STDIN),"r")) { + print $fh->getline; $fh->close; } - $fh = new IO::Handle "file", "r"; - if (defined $fh) { - print <$fh>; - undef $fh; # automatically closes the file - } - - $fh = new IO::Handle "file", O_WRONLY|O_APPEND; - if (defined $fh) { - print $fh "corge\n"; - undef $fh; # automatically closes the file + $fh = new IO::Handle; + if ($fh->fdopen(fileno(STDOUT),"w")) { + $fh->print("Some text\n"); } - $pos = $fh->getpos; - $fh->setpos $pos; - $fh->setvbuf($buffer_var, _IOLBF, 1024); + undef $fh; # automatically closes the file if it's open + autoflush STDOUT 1; =head1 DESCRIPTION -C<IO::Handle> is the base class for all other IO handle classes. +C<IO::Handle> is the base class for all other IO handle classes. It is +not intended that objects of C<IO::Handle> would be created directly, +but instead C<IO::Handle> is inherited from by several other classes +in the IO hierarchy. + +If you are reading this documentation, looking for a replacement for +the C<FileHandle> package, then I suggest you read the documentation +for C<IO::File> + A C<IO::Handle> object is a reference to a symbol (see the C<Symbol> package) =head1 CONSTRUCTOR @@ -167,7 +162,7 @@ module keeps a C<timeout> variable in 'io_socket_timeout'. L<perlfunc>, L<perlop/"I/O Operators">, -L<FileHandle> +L<IO::File> =head1 BUGS @@ -184,7 +179,7 @@ Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt> require 5.000; use strict; -use vars qw($VERSION @EXPORT_OK $AUTOLOAD @ISA); +use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA); use Carp; use Symbol; use SelectSaver; @@ -192,7 +187,8 @@ use SelectSaver; require Exporter; @ISA = qw(Exporter); -$VERSION = "1.1402"; +$VERSION = "1.1501"; +$XS_VERSION = "1.15"; @EXPORT_OK = qw( autoflush @@ -231,7 +227,7 @@ $VERSION = "1.1402"; require DynaLoader; @IO::ISA = qw(DynaLoader); -bootstrap IO $VERSION; +bootstrap IO $XS_VERSION; sub AUTOLOAD { if ($AUTOLOAD =~ /::(_?[a-z])/) { @@ -314,14 +310,8 @@ sub fdopen { sub close { @_ == 1 or croak 'usage: $fh->close()'; my($fh) = @_; - my $r = close($fh); - - # This may seem as though it should be in IO::Pipe, but the - # object gets blessed out of IO::Pipe when reader/writer is called - waitpid(${*$fh}{'io_pipe_pid'},0) - if(defined ${*$fh}{'io_pipe_pid'}); - $r; + close($fh); } ################################################ diff --git a/ext/IO/lib/IO/Pipe.pm b/ext/IO/lib/IO/Pipe.pm index 34cb0daad2..499856a6c6 100644 --- a/ext/IO/lib/IO/Pipe.pm +++ b/ext/IO/lib/IO/Pipe.pm @@ -1,7 +1,145 @@ +# IO::Pipe.pm # +# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights +# reserved. This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. package IO::Pipe; +require 5.000; + +use IO::Handle; +use strict; +use vars qw($VERSION); +use Carp; +use Symbol; + +$VERSION = "1.09"; + +sub new { + my $type = shift; + my $class = ref($type) || $type || "IO::Pipe"; + @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]"; + + my $me = bless gensym(), $class; + + my($readfh,$writefh) = @_ ? @_ : $me->handles; + + pipe($readfh, $writefh) + or return undef; + + @{*$me} = ($readfh, $writefh); + + $me; +} + +sub handles { + @_ == 1 or croak 'usage: $pipe->handles()'; + (IO::Pipe::End->new(), IO::Pipe::End->new()); +} + +my $do_spawn = $^O eq 'os2'; + +sub _doit { + my $me = shift; + my $rw = shift; + + my $pid = $do_spawn ? 0 : fork(); + + if($pid) { # Parent + return $pid; + } + elsif(defined $pid) { # Child or spawn + my $fh; + my $io = $rw ? \*STDIN : \*STDOUT; + my ($mode, $save) = $rw ? "r" : "w"; + if ($do_spawn) { + require Fcntl; + $save = IO::Handle->new_from_fd($io, $mode); + # Close in child: + fcntl(shift, Fcntl::F_SETFD(), 1) or croak "fcntl: $!"; + $fh = $rw ? ${*$me}[0] : ${*$me}[1]; + } else { + shift; + $fh = $rw ? $me->reader() : $me->writer(); # close the other end + } + bless $io, "IO::Handle"; + $io->fdopen($fh, $mode); + + if ($do_spawn) { + $pid = eval { system 1, @_ }; # 1 == P_NOWAIT + my $err = $!; + + $io->fdopen($save, $mode); + $save->close or croak "Cannot close $!"; + croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0; + return $pid; + } else { + exec @_ or + croak "IO::Pipe: Cannot exec: $!"; + } + } + else { + croak "IO::Pipe: Cannot fork: $!"; + } + + # NOT Reached +} + +sub reader { + @_ >= 1 or croak 'usage: $pipe->reader()'; + my $me = shift; + my $fh = ${*$me}[0]; + my $pid = $me->_doit(0, $fh, @_) + if(@_); + + close ${*$me}[1]; + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +sub writer { + @_ >= 1 or croak 'usage: $pipe->writer()'; + my $me = shift; + my $fh = ${*$me}[1]; + my $pid = $me->_doit(1, $fh, @_) + if(@_); + + close ${*$me}[0]; + bless $me, ref($fh); + *{*$me} = *{*$fh}; # Alias self to handle + bless $fh; # Really wan't un-bless here + ${*$me}{'io_pipe_pid'} = $pid + if defined $pid; + + $me; +} + +package IO::Pipe::End; + +use vars qw(@ISA); + +@ISA = qw(IO::Handle); + +sub close { + my $fh = shift; + my $r = $fh->SUPER::close(@_); + + waitpid(${*$fh}{'io_pipe_pid'},0) + if(defined ${*$fh}{'io_pipe_pid'}); + + $r; +} + +1; + +__END__ + =head1 NAME IO::pipe - supply object methods for pipes @@ -79,7 +217,7 @@ is called and C<ARGS> are passed to exec. This method is called during construction by C<IO::Pipe::new> on the newly created C<IO::Pipe> object. It returns an array of two objects -blessed into C<IO::Handle>, or a subclass thereof. +blessed into C<IO::Pipe::End>, or a subclass thereof. =back @@ -93,101 +231,8 @@ Graham Barr <bodg@tiuk.ti.com> =head1 COPYRIGHT -Copyright (c) 1995 Graham Barr. All rights reserved. This program is free +Copyright (c) 1996 Graham Barr. All rights reserved. This program is free software; you can redistribute it and/or modify it under the same terms as Perl itself. =cut - -require 5.000; -use strict; -use vars qw($VERSION); -use Carp; -use Symbol; -require IO::Handle; - -$VERSION = "1.08"; - -sub new { - my $type = shift; - my $class = ref($type) || $type || "IO::Pipe"; - @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]"; - - my $me = bless gensym(), $class; - - my($readfh,$writefh) = @_ ? @_ : $me->handles; - - pipe($readfh, $writefh) - or return undef; - - @{*$me} = ($readfh, $writefh); - - $me; -} - -sub handles { - @_ == 1 or croak 'usage: $pipe->handles()'; - (IO::Handle->new(), IO::Handle->new()); -} - -sub _doit { - my $me = shift; - my $rw = shift; - - my $pid = fork(); - - if($pid) { # Parent - return $pid; - } - elsif(defined $pid) { # Child - my $fh = $rw ? $me->reader() : $me->writer(); - my $io = $rw ? \*STDIN : \*STDOUT; - - bless $io, "IO::Handle"; - $io->fdopen($fh, $rw ? "r" : "w"); - exec @_ or - croak "IO::Pipe: Cannot exec: $!"; - } - else { - croak "IO::Pipe: Cannot fork: $!"; - } - - # NOT Reached -} - -sub reader { - @_ >= 1 or croak 'usage: $pipe->reader()'; - my $me = shift; - my $fh = ${*$me}[0]; - my $pid = $me->_doit(0,@_) - if(@_); - - close(${*$me}[1]); - bless $me, ref($fh); - *{*$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; - - $me; -} - -sub writer { - @_ >= 1 or croak 'usage: $pipe->writer()'; - my $me = shift; - my $fh = ${*$me}[1]; - my $pid = $me->_doit(1,@_) - if(@_); - - close(${*$me}[0]); - bless $me, ref($fh); - *{*$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; - - $me; -} - -1; - diff --git a/ext/IO/lib/IO/Socket.pm b/ext/IO/lib/IO/Socket.pm index 6a69c6b624..264d1ac076 100644 --- a/ext/IO/lib/IO/Socket.pm +++ b/ext/IO/lib/IO/Socket.pm @@ -1,4 +1,8 @@ +# IO::Socket.pm # +# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights +# reserved. This program is free software; you can redistribute it and/or +# modify it under the same terms as Perl itself. package IO::Socket; @@ -114,7 +118,7 @@ use Exporter; @ISA = qw(IO::Handle); -$VERSION = "1.15"; +$VERSION = "1.16"; sub import { my $pkg = shift; @@ -136,16 +140,7 @@ my @domain2pkg = (); sub register_domain { my($p,$d) = @_; - $domain2pkg[$d] = bless \$d, $p; -} - -sub _domain2pkg { - my $domain = shift; - - croak "Unsupported socket domain" - unless defined $domain2pkg[$domain]; - - $domain2pkg[$domain] + $domain2pkg[$d] = $p; } sub configure { @@ -155,12 +150,13 @@ sub configure { croak 'IO::Socket: Cannot configure a generic socket' unless defined $domain; - my $class = ref(_domain2pkg($domain)); + croak "IO::Socket: Unsupported socket domain" + unless defined $domain2pkg[$domain]; croak "IO::Socket: Cannot configure socket in domain '$domain'" unless ref($fh) eq "IO::Socket"; - bless($fh, $class); + bless($fh, $domain2pkg[$domain]); $fh->configure; } @@ -168,18 +164,13 @@ sub socket { @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)'; my($fh,$domain,$type,$protocol) = @_; - if(!defined ${*$fh}{'io_socket_domain'} - || !ref(${*$fh}{'io_socket_domain'}) - || ${${*$fh}{'io_socket_domain'}} != $domain) { - my $pkg = - ${*$fh}{'io_socket_domain'} = _domain2pkg($domain); - } - socket($fh,$domain,$type,$protocol) or return undef; - ${*$fh}{'io_socket_type'} = $type; - ${*$fh}{'io_socket_proto'} = $protocol; + ${*$fh}{'io_socket_domain'} = $domain; + ${*$fh}{'io_socket_type'} = $type; + ${*$fh}{'io_socket_proto'} = $protocol; + $fh; } @@ -352,7 +343,7 @@ sub timeout { sub sockdomain { @_ == 1 or croak 'usage: $fh->sockdomain()'; my $fh = shift; - ${${*$fh}{'io_socket_domain'}} + ${*$fh}{'io_socket_domain'}; } sub socktype { @@ -549,9 +540,6 @@ sub configure { my $pname = (getprotobynumber($proto))[0]; $type = $arg->{Type} || $socket_type{$pname}; - my $domain = AF_INET; - ${*$fh}{'io_socket_domain'} = bless \$domain; - $fh->socket(AF_INET, $type, $proto) or return _error($fh,"$!"); @@ -667,9 +655,6 @@ sub configure { my $type = $arg->{Type} || SOCK_STREAM; - my $domain = AF_UNIX; - ${*$fh}{'io_socket_domain'} = bless \$domain; - $fh->socket(AF_UNIX, $type, 0) or return undef; @@ -713,7 +698,7 @@ 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 +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. diff --git a/ext/POSIX/POSIX.pm b/ext/POSIX/POSIX.pm index b095ffebe7..ce315dcf7c 100644 --- a/ext/POSIX/POSIX.pm +++ b/ext/POSIX/POSIX.pm @@ -22,11 +22,19 @@ $VERSION = "1.00" ; dirent_h => [qw()], - errno_h => [qw(E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM - EEXIST EFAULT EFBIG EINTR EINVAL EIO EISDIR EMFILE - EMLINK ENAMETOOLONG ENFILE ENODEV ENOENT ENOEXEC ENOLCK - ENOMEM ENOSPC ENOSYS ENOTDIR ENOTEMPTY ENOTTY ENXIO - EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV errno)], + errno_h => [qw(E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT + EAGAIN EALREADY EBADF EBUSY ECHILD ECONNABORTED + ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ EDOM EDQUOT + EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS + EINTR EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK + EMSGSIZE ENAMETOOLONG ENETDOWN ENETRESET ENETUNREACH + ENFILE ENOBUFS ENODEV ENOENT ENOEXEC ENOLCK ENOMEM + ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR + ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM + EPFNOSUPPORT EPIPE EPROCLIM EPROTONOSUPPORT EPROTOTYPE + ERANGE EREMOTE ERESTART EROFS ESHUTDOWN ESOCKTNOSUPPORT + ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS ETXTBSY + EUSERS EWOULDBLOCK EXDEV errno)], fcntl_h => [qw(FD_CLOEXEC F_DUPFD F_GETFD F_GETFL F_GETLK F_RDLCK F_SETFD F_SETFL F_SETLK F_SETLKW F_UNLCK F_WRLCK @@ -72,12 +80,13 @@ $VERSION = "1.00" ; setjmp_h => [qw(longjmp setjmp siglongjmp sigsetjmp)], - signal_h => [qw(SA_NOCLDSTOP SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE - SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV - SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 - SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK - raise sigaction signal sigpending sigprocmask - sigsuspend)], + signal_h => [qw(SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK + SA_RESETHAND SA_RESTART SA_SIGINFO SIGABRT SIGALRM + SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL + SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN + SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR + SIG_IGN SIG_SETMASK SIG_UNBLOCK raise sigaction signal + sigpending sigprocmask sigsuspend)], stdarg_h => [qw()], diff --git a/ext/POSIX/POSIX.pod b/ext/POSIX/POSIX.pod index 34597d1bd5..fba225f5b9 100644 --- a/ext/POSIX/POSIX.pod +++ b/ext/POSIX/POSIX.pod @@ -1576,7 +1576,16 @@ _SC_ARG_MAX _SC_CHILD_MAX _SC_CLK_TCK _SC_JOB_CONTROL _SC_NGROUPS_MAX _SC_OPEN_M =item Constants -E2BIG EACCES EAGAIN EBADF EBUSY ECHILD EDEADLK EDOM EEXIST EFAULT EFBIG EINTR EINVAL EIO EISDIR EMFILE EMLINK ENAMETOOLONG ENFILE ENODEV ENOENT ENOEXEC ENOLCK ENOMEM ENOSPC ENOSYS ENOTDIR ENOTEMPTY ENOTTY ENXIO EPERM EPIPE ERANGE EROFS ESPIPE ESRCH EXDEV +E2BIG EACCES EADDRINUSE EADDRNOTAVAIL EAFNOSUPPORT EAGAIN EALREADY EBADF +EBUSY ECHILD ECONNABORTED ECONNREFUSED ECONNRESET EDEADLK EDESTADDRREQ +EDOM EDQUOT EEXIST EFAULT EFBIG EHOSTDOWN EHOSTUNREACH EINPROGRESS EINTR +EINVAL EIO EISCONN EISDIR ELOOP EMFILE EMLINK EMSGSIZE ENAMETOOLONG +ENETDOWN ENETRESET ENETUNREACH ENFILE ENOBUFS ENODEV ENOENT ENOEXEC +ENOLCK ENOMEM ENOPROTOOPT ENOSPC ENOSYS ENOTBLK ENOTCONN ENOTDIR +ENOTEMPTY ENOTSOCK ENOTTY ENXIO EOPNOTSUPP EPERM EPFNOSUPPORT EPIPE +EPROCLIM EPROTONOSUPPORT EPROTOTYPE ERANGE EREMOTE ERESTART EROFS +ESHUTDOWN ESOCKTNOSUPPORT ESPIPE ESRCH ESTALE ETIMEDOUT ETOOMANYREFS +ETXTBSY EUSERS EWOULDBLOCK EXDEV =back @@ -1636,7 +1645,11 @@ HUGE_VAL =item Constants -SA_NOCLDSTOP SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK SIG_UNBLOCK +SA_NOCLDSTOP SA_NOCLDWAIT SA_NODEFER SA_ONSTACK SA_RESETHAND SA_RESTART +SA_SIGINFO SIGABRT SIGALRM SIGCHLD SIGCONT SIGFPE SIGHUP SIGILL SIGINT +SIGKILL SIGPIPE SIGQUIT SIGSEGV SIGSTOP SIGTERM SIGTSTP SIGTTIN SIGTTOU +SIGUSR1 SIGUSR2 SIG_BLOCK SIG_DFL SIG_ERR SIG_IGN SIG_SETMASK +SIG_UNBLOCK =back diff --git a/ext/POSIX/POSIX.xs b/ext/POSIX/POSIX.xs index 6354dc3db5..42aeb3bb93 100644 --- a/ext/POSIX/POSIX.xs +++ b/ext/POSIX/POSIX.xs @@ -47,6 +47,9 @@ # include <libdef.h> /* LIB$_INVARG constant */ # include <lib$routines.h> /* prototype for lib$ediv() */ # include <starlet.h> /* prototype for sys$gettim() */ +# if DECC_VERSION < 50000000 +# define pid_t int /* old versions of DECC miss this in types.h */ +# endif # undef mkfifo /* #defined in perl.h */ # define mkfifo(a,b) (not_here("mkfifo"),-1) @@ -624,12 +627,36 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EADDRINUSE")) +#ifdef EADDRINUSE + return EADDRINUSE; +#else + goto not_there; +#endif + if (strEQ(name, "EADDRNOTAVAIL")) +#ifdef EADDRNOTAVAIL + return EADDRNOTAVAIL; +#else + goto not_there; +#endif + if (strEQ(name, "EAFNOSUPPORT")) +#ifdef EAFNOSUPPORT + return EAFNOSUPPORT; +#else + goto not_there; +#endif if (strEQ(name, "EAGAIN")) #ifdef EAGAIN return EAGAIN; #else goto not_there; #endif + if (strEQ(name, "EALREADY")) +#ifdef EALREADY + return EALREADY; +#else + goto not_there; +#endif break; case 'B': if (strEQ(name, "EBADF")) @@ -676,6 +703,24 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "ECONNABORTED")) +#ifdef ECONNABORTED + return ECONNABORTED; +#else + goto not_there; +#endif + if (strEQ(name, "ECONNREFUSED")) +#ifdef ECONNREFUSED + return ECONNREFUSED; +#else + goto not_there; +#endif + if (strEQ(name, "ECONNRESET")) +#ifdef ECONNRESET + return ECONNRESET; +#else + goto not_there; +#endif break; case 'D': if (strEQ(name, "EDEADLK")) @@ -684,12 +729,24 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EDESTADDRREQ")) +#ifdef EDESTADDRREQ + return EDESTADDRREQ; +#else + goto not_there; +#endif if (strEQ(name, "EDOM")) #ifdef EDOM return EDOM; #else goto not_there; #endif + if (strEQ(name, "EDQUOT")) +#ifdef EDQUOT + return EDQUOT; +#else + goto not_there; +#endif break; case 'E': if (strEQ(name, "EEXIST")) @@ -713,7 +770,27 @@ int arg; goto not_there; #endif break; + case 'H': + if (strEQ(name, "EHOSTDOWN")) +#ifdef EHOSTDOWN + return EHOSTDOWN; +#else + goto not_there; +#endif + if (strEQ(name, "EHOSTUNREACH")) +#ifdef EHOSTUNREACH + return EHOSTUNREACH; +#else + goto not_there; +#endif + break; case 'I': + if (strEQ(name, "EINPROGRESS")) +#ifdef EINPROGRESS + return EINPROGRESS; +#else + goto not_there; +#endif if (strEQ(name, "EINTR")) #ifdef EINTR return EINTR; @@ -732,12 +809,24 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EISCONN")) +#ifdef EISCONN + return EISCONN; +#else + goto not_there; +#endif if (strEQ(name, "EISDIR")) #ifdef EISDIR return EISDIR; #else goto not_there; #endif + if (strEQ(name, "ELOOP")) +#ifdef ELOOP + return ELOOP; +#else + goto not_there; +#endif break; case 'M': if (strEQ(name, "EMFILE")) @@ -752,29 +841,71 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EMSGSIZE")) +#ifdef EMSGSIZE + return EMSGSIZE; +#else + goto not_there; +#endif break; case 'N': + if (strEQ(name, "ENETDOWN")) +#ifdef ENETDOWN + return ENETDOWN; +#else + goto not_there; +#endif + if (strEQ(name, "ENETRESET")) +#ifdef ENETRESET + return ENETRESET; +#else + goto not_there; +#endif + if (strEQ(name, "ENETUNREACH")) +#ifdef ENETUNREACH + return ENETUNREACH; +#else + goto not_there; +#endif + if (strEQ(name, "ENOBUFS")) +#ifdef ENOBUFS + return ENOBUFS; +#else + goto not_there; +#endif + if (strEQ(name, "ENOEXEC")) +#ifdef ENOEXEC + return ENOEXEC; +#else + goto not_there; +#endif if (strEQ(name, "ENOMEM")) #ifdef ENOMEM return ENOMEM; #else goto not_there; #endif + if (strEQ(name, "ENOPROTOOPT")) +#ifdef ENOPROTOOPT + return ENOPROTOOPT; +#else + goto not_there; +#endif if (strEQ(name, "ENOSPC")) #ifdef ENOSPC return ENOSPC; #else goto not_there; #endif - if (strEQ(name, "ENOEXEC")) -#ifdef ENOEXEC - return ENOEXEC; + if (strEQ(name, "ENOTBLK")) +#ifdef ENOTBLK + return ENOTBLK; #else goto not_there; #endif - if (strEQ(name, "ENOTTY")) -#ifdef ENOTTY - return ENOTTY; + if (strEQ(name, "ENOTCONN")) +#ifdef ENOTCONN + return ENOTCONN; #else goto not_there; #endif @@ -790,6 +921,18 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "ENOTSOCK")) +#ifdef ENOTSOCK + return ENOTSOCK; +#else + goto not_there; +#endif + if (strEQ(name, "ENOTTY")) +#ifdef ENOTTY + return ENOTTY; +#else + goto not_there; +#endif if (strEQ(name, "ENFILE")) #ifdef ENFILE return ENFILE; @@ -840,6 +983,12 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EOPNOTSUPP")) +#ifdef EOPNOTSUPP + return EOPNOTSUPP; +#else + goto not_there; +#endif break; case 'P': if (strEQ(name, "EPERM")) @@ -848,12 +997,36 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EPFNOSUPPORT")) +#ifdef EPFNOSUPPORT + return EPFNOSUPPORT; +#else + goto not_there; +#endif if (strEQ(name, "EPIPE")) #ifdef EPIPE return EPIPE; #else goto not_there; #endif + if (strEQ(name, "EPROCLIM")) +#ifdef EPROCLIM + return EPROCLIM; +#else + goto not_there; +#endif + if (strEQ(name, "EPROTONOSUPPORT")) +#ifdef EPROTONOSUPPORT + return EPROTONOSUPPORT; +#else + goto not_there; +#endif + if (strEQ(name, "EPROTOTYPE")) +#ifdef EPROTOTYPE + return EPROTOTYPE; +#else + goto not_there; +#endif break; case 'R': if (strEQ(name, "ERANGE")) @@ -862,6 +1035,18 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "EREMOTE")) +#ifdef EREMOTE + return EREMOTE; +#else + goto not_there; +#endif + if (strEQ(name, "ERESTART")) +#ifdef ERESTART + return ERESTART; +#else + goto not_there; +#endif if (strEQ(name, "EROFS")) #ifdef EROFS return EROFS; @@ -870,6 +1055,18 @@ int arg; #endif break; case 'S': + if (strEQ(name, "ESHUTDOWN")) +#ifdef ESHUTDOWN + return ESHUTDOWN; +#else + goto not_there; +#endif + if (strEQ(name, "ESOCKTNOSUPPORT")) +#ifdef ESOCKTNOSUPPORT + return ESOCKTNOSUPPORT; +#else + goto not_there; +#endif if (strEQ(name, "ESPIPE")) #ifdef ESPIPE return ESPIPE; @@ -882,7 +1079,49 @@ int arg; #else goto not_there; #endif + if (strEQ(name, "ESTALE")) +#ifdef ESTALE + return ESTALE; +#else + goto not_there; +#endif break; + case 'T': + if (strEQ(name, "ETIMEDOUT")) +#ifdef ETIMEDOUT + return ETIMEDOUT; +#else + goto not_there; +#endif + if (strEQ(name, "ETOOMANYREFS")) +#ifdef ETOOMANYREFS + return ETOOMANYREFS; +#else + goto not_there; +#endif + if (strEQ(name, "ETXTBSY")) +#ifdef ETXTBSY + return ETXTBSY; +#else + goto not_there; +#endif + break; + case 'U': + if (strEQ(name, "EUSERS")) +#ifdef EUSERS + return EUSERS; +#else + goto not_there; +#endif + break; + case 'W': + if (strEQ(name, "EWOULDBLOCK")) +#ifdef EWOULDBLOCK + return EWOULDBLOCK; +#else + goto not_there; +#endif + break; case 'X': if (strEQ(name, "EXIT_FAILURE")) #ifdef EXIT_FAILURE @@ -1769,12 +2008,51 @@ int arg; #else goto not_there; #endif - if (strEQ(name, "SA_NOCLDSTOP")) + if (strnEQ(name, "SA_", 3)) { + if (strEQ(name, "SA_NOCLDSTOP")) #ifdef SA_NOCLDSTOP - return SA_NOCLDSTOP; + return SA_NOCLDSTOP; #else - goto not_there; + goto not_there; #endif + if (strEQ(name, "SA_NOCLDWAIT")) +#ifdef SA_NOCLDWAIT + return SA_NOCLDWAIT; +#else + goto not_there; +#endif + if (strEQ(name, "SA_NODEFER")) +#ifdef SA_NODEFER + return SA_NODEFER; +#else + goto not_there; +#endif + if (strEQ(name, "SA_ONSTACK")) +#ifdef SA_ONSTACK + return SA_ONSTACK; +#else + goto not_there; +#endif + if (strEQ(name, "SA_RESETHAND")) +#ifdef SA_RESETHAND + return SA_RESETHAND; +#else + goto not_there; +#endif + if (strEQ(name, "SA_RESTART")) +#ifdef SA_RESTART + return SA_RESTART; +#else + goto not_there; +#endif + if (strEQ(name, "SA_SIGINFO")) +#ifdef SA_SIGINFO + return SA_SIGINFO; +#else + goto not_there; +#endif + break; + } if (strEQ(name, "SCHAR_MAX")) #ifdef SCHAR_MAX return SCHAR_MAX; |