perl5.005_03

21 files changed, 4272 insertions, 0 deletions

diff --git a/gnu/usr.bin/perl/ext/DynaLoader/dl_cygwin32.xs b/gnu/usr.bin/perl/ext/DynaLoader/dl_cygwin32.xs
new file mode 100644
index 00000000000..2b7563764e1
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/DynaLoader/dl_cygwin32.xs
@@ -0,0 +1,153 @@
+/* dl_cygwin32.xs
+ * 
+ * Platform:	Win32 (Windows NT/Windows 95)
+ * Author:	Wei-Yuen Tan (wyt@hip.com)
+ * Created:	A warm day in June, 1995
+ *
+ * Modified:
+ *    August 23rd 1995 - rewritten after losing everything when I
+ *                       wiped off my NT partition (eek!)
+ */
+/* Modified from the original dl_win32.xs to work with cygwin32
+   -John Cerney 3/26/97
+*/
+/* Porting notes:
+
+I merely took Paul's dl_dlopen.xs, took out extraneous stuff and
+replaced the appropriate SunOS calls with the corresponding Win32
+calls.
+
+*/
+
+#define WIN32_LEAN_AND_MEAN
+// Defines from windows needed for this function only. Can't include full
+//  Cygwin32 windows headers because of problems with CONTEXT redefinition
+//  Removed logic to tell not dynamically load static modules. It is assumed that all
+//   modules are dynamically built. This should be similar to the behavoir on sunOS.
+//   Leaving in the logic would have required changes to the standard perlmain.c code
+//
+// // Includes call a dll function to initialize it's impure_ptr.
+#include <stdio.h>
+void (*impure_setupptr)(struct _reent *);  // pointer to the impure_setup routine
+
+//#include <windows.h>
+#define LOAD_WITH_ALTERED_SEARCH_PATH	(8)
+typedef void *HANDLE;
+typedef HANDLE HINSTANCE;
+#define STDCALL     __attribute__ ((stdcall))
+typedef int STDCALL (*FARPROC)();
+
+HINSTANCE
+STDCALL
+LoadLibraryExA(
+	       char* lpLibFileName,
+	       HANDLE hFile,
+	       unsigned int dwFlags
+	       );
+unsigned int
+STDCALL
+GetLastError(
+	     void
+	     );
+FARPROC
+STDCALL
+GetProcAddress(
+	       HINSTANCE hModule,
+	       char* lpProcName
+	       );
+
+#include <string.h>
+
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+#include "dlutils.c"	/* SaveError() etc	*/
+
+static void
+dl_private_init()
+{
+    (void)dl_generic_private_init();
+}
+
+
+MODULE = DynaLoader	PACKAGE = DynaLoader
+
+BOOT:
+    (void)dl_private_init();
+
+void *
+dl_load_file(filename,flags=0)
+    char *		filename
+    int			flags
+    PREINIT:
+    CODE:
+    DLDEBUG(1,fprintf(stderr,"dl_load_file(%s):\n", filename));
+
+    RETVAL = (void*) LoadLibraryExA(filename, NULL, LOAD_WITH_ALTERED_SEARCH_PATH ) ;
+
+    DLDEBUG(2,fprintf(stderr," libref=%x\n", RETVAL));
+    ST(0) = sv_newmortal() ;
+    if (RETVAL == NULL){
+	SaveError("%d",GetLastError()) ;
+    }
+    else{
+	// setup the dll's impure_ptr:
+	impure_setupptr = GetProcAddress(RETVAL, "impure_setup");
+	if( impure_setupptr == NULL){
+		printf(
+    "Cygwin32 dynaloader error: could not load impure_setup symbol\n");
+		RETVAL = NULL;		
+	}
+	else{
+		// setup the DLLs impure_ptr:
+		(*impure_setupptr)(_impure_ptr);
+		sv_setiv( ST(0), (IV)RETVAL);
+	}
+   }
+	
+
+
+void *
+dl_find_symbol(libhandle, symbolname)
+    void *	libhandle
+    char *	symbolname
+    CODE:
+    DLDEBUG(2,fprintf(stderr,"dl_find_symbol(handle=%x, symbol=%s)\n",
+	libhandle, symbolname));
+    RETVAL = (void*) GetProcAddress((HINSTANCE) libhandle, symbolname);
+    DLDEBUG(2,fprintf(stderr,"  symbolref = %x\n", RETVAL));
+    ST(0) = sv_newmortal() ;
+    if (RETVAL == NULL)
+	SaveError("%d",GetLastError()) ;
+    else
+	sv_setiv( ST(0), (IV)RETVAL);
+
+
+void
+dl_undef_symbols()
+    PPCODE:
+
+
+
+# These functions should not need changing on any platform:
+
+void
+dl_install_xsub(perl_name, symref, filename="$Package")
+    char *		perl_name
+    void *		symref 
+    char *		filename
+    CODE:
+    DLDEBUG(2,fprintf(stderr,"dl_install_xsub(name=%s, symref=%x)\n",
+		perl_name, symref));
+    ST(0)=sv_2mortal(newRV((SV*)newXS(perl_name, (void(*)())symref, filename)));
+
+
+char *
+dl_error()
+    CODE:
+    RETVAL = LastError ;
+    OUTPUT:
+    RETVAL
+
+# end.
diff --git a/gnu/usr.bin/perl/ext/IO/IO.pm b/gnu/usr.bin/perl/ext/IO/IO.pm
new file mode 100644
index 00000000000..1ba05ca9165
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IO/IO.pm
@@ -0,0 +1,36 @@
+#
+
+package IO;
+
+=head1 NAME
+
+IO - load various IO modules
+
+=head1 SYNOPSIS
+
+    use IO;
+
+=head1 DESCRIPTION
+
+C<IO> provides a simple mechanism to load all of the IO modules at one go.
+Currently this includes:
+
+      IO::Handle
+      IO::Seekable
+      IO::File
+      IO::Pipe
+      IO::Socket
+
+For more information on any of these modules, please see its respective
+documentation.
+
+=cut
+
+use IO::Handle;
+use IO::Seekable;
+use IO::File;
+use IO::Pipe;
+use IO::Socket;
+
+1;
+
diff --git a/gnu/usr.bin/perl/ext/IO/IO.xs b/gnu/usr.bin/perl/ext/IO/IO.xs
new file mode 100644
index 00000000000..e558d5c4e0a
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IO/IO.xs
@@ -0,0 +1,288 @@
+#include "EXTERN.h"
+#define PERLIO_NOT_STDIO 1
+#include "perl.h"
+#include "XSUB.h"
+
+#ifdef I_UNISTD
+#  include <unistd.h>
+#endif
+#ifdef I_FCNTL
+#  include <fcntl.h>
+#endif
+
+#ifdef PerlIO
+typedef int SysRet;
+typedef PerlIO * InputStream;
+typedef PerlIO * OutputStream;
+#else
+#define PERLIO_IS_STDIO 1
+typedef int SysRet;
+typedef FILE * InputStream;
+typedef FILE * OutputStream;
+#endif
+
+static int
+not_here(s)
+char *s;
+{
+    croak("%s not implemented on this architecture", s);
+    return -1;
+}
+
+static bool
+constant(name, pval)
+char *name;
+IV *pval;
+{
+    switch (*name) {
+    case '_':
+	if (strEQ(name, "_IOFBF"))
+#ifdef _IOFBF
+	    { *pval = _IOFBF; return TRUE; }
+#else
+	    return FALSE;
+#endif
+	if (strEQ(name, "_IOLBF"))
+#ifdef _IOLBF
+	    { *pval = _IOLBF; return TRUE; }
+#else
+	    return FALSE;
+#endif
+	if (strEQ(name, "_IONBF"))
+#ifdef _IONBF
+	    { *pval = _IONBF; return TRUE; }
+#else
+	    return FALSE;
+#endif
+	break;
+    case 'S':
+	if (strEQ(name, "SEEK_SET"))
+#ifdef SEEK_SET
+	    { *pval = SEEK_SET; return TRUE; }
+#else
+	    return FALSE;
+#endif
+	if (strEQ(name, "SEEK_CUR"))
+#ifdef SEEK_CUR
+	    { *pval = SEEK_CUR; return TRUE; }
+#else
+	    return FALSE;
+#endif
+	if (strEQ(name, "SEEK_END"))
+#ifdef SEEK_END
+	    { *pval = SEEK_END; return TRUE; }
+#else
+	    return FALSE;
+#endif
+	break;
+    }
+
+    return FALSE;
+}
+
+
+MODULE = IO	PACKAGE = IO::Seekable	PREFIX = f
+
+SV *
+fgetpos(handle)
+	InputStream	handle
+    CODE:
+	if (handle) {
+	    Fpos_t pos;
+#ifdef PerlIO
+	    PerlIO_getpos(handle, &pos);
+#else
+	    fgetpos(handle, &pos);
+#endif
+	    ST(0) = sv_2mortal(newSVpv((char*)&pos, sizeof(Fpos_t)));
+	}
+	else {
+	    ST(0) = &sv_undef;
+	    errno = EINVAL;
+	}
+
+SysRet
+fsetpos(handle, pos)
+	InputStream	handle
+	SV *		pos
+    CODE:
+	char *p;
+	if (handle && (p = SvPVx(pos, na)) && na == sizeof(Fpos_t))
+#ifdef PerlIO
+	    RETVAL = PerlIO_setpos(handle, (Fpos_t*)p);
+#else
+	    RETVAL = fsetpos(handle, (Fpos_t*)p);
+#endif
+	else {
+	    RETVAL = -1;
+	    errno = EINVAL;
+	}
+    OUTPUT:
+	RETVAL
+
+MODULE = IO	PACKAGE = IO::File	PREFIX = f
+
+SV *
+new_tmpfile(packname = "IO::File")
+    char *		packname
+    PREINIT:
+	OutputStream fp;
+	GV *gv;
+    CODE:
+#ifdef PerlIO
+	fp = PerlIO_tmpfile();
+#else
+	fp = tmpfile();
+#endif
+	gv = (GV*)SvREFCNT_inc(newGVgen(packname));
+	hv_delete(GvSTASH(gv), GvNAME(gv), GvNAMELEN(gv), G_DISCARD);
+	if (do_open(gv, "+>&", 3, FALSE, 0, 0, fp)) {
+	    ST(0) = sv_2mortal(newRV((SV*)gv));
+	    sv_bless(ST(0), gv_stashpv(packname, TRUE));
+	    SvREFCNT_dec(gv);	/* undo increment in newRV() */
+	}
+	else {
+	    ST(0) = &sv_undef;
+	    SvREFCNT_dec(gv);
+	}
+
+MODULE = IO	PACKAGE = IO::Handle	PREFIX = f
+
+SV *
+constant(name)
+	char *		name
+    CODE:
+	IV i;
+	if (constant(name, &i))
+	    ST(0) = sv_2mortal(newSViv(i));
+	else
+	    ST(0) = &sv_undef;
+
+int
+ungetc(handle, c)
+	InputStream	handle
+	int		c
+    CODE:
+	if (handle)
+#ifdef PerlIO
+	    RETVAL = PerlIO_ungetc(handle, c);
+#else
+	    RETVAL = ungetc(c, handle);
+#endif
+	else {
+	    RETVAL = -1;
+	    errno = EINVAL;
+	}
+    OUTPUT:
+	RETVAL
+
+int
+ferror(handle)
+	InputStream	handle
+    CODE:
+	if (handle)
+#ifdef PerlIO
+	    RETVAL = PerlIO_error(handle);
+#else
+	    RETVAL = ferror(handle);
+#endif
+	else {
+	    RETVAL = -1;
+	    errno = EINVAL;
+	}
+    OUTPUT:
+	RETVAL
+
+int
+clearerr(handle)
+	InputStream	handle
+    CODE:
+	if (handle) {
+#ifdef PerlIO
+	    PerlIO_clearerr(handle);
+#else
+	    clearerr(handle);
+#endif
+	    RETVAL = 0;
+	}
+	else {
+	    RETVAL = -1;
+	    errno = EINVAL;
+	}
+    OUTPUT:
+	RETVAL
+
+int
+untaint(handle)
+       SV *	handle
+    CODE:
+#ifdef IOf_UNTAINT
+	IO * io;
+	io = sv_2io(handle);
+	if (io) {
+	    IoFLAGS(io) |= IOf_UNTAINT;
+	    RETVAL = 0;
+	}
+        else {
+#endif
+	    RETVAL = -1;
+	    errno = EINVAL;
+#ifdef IOf_UNTAINT
+	}
+#endif
+    OUTPUT:
+	RETVAL
+
+SysRet
+fflush(handle)
+	OutputStream	handle
+    CODE:
+	if (handle)
+#ifdef PerlIO
+	    RETVAL = PerlIO_flush(handle);
+#else
+	    RETVAL = Fflush(handle);
+#endif
+	else {
+	    RETVAL = -1;
+	    errno = EINVAL;
+	}
+    OUTPUT:
+	RETVAL
+
+void
+setbuf(handle, buf)
+	OutputStream	handle
+	char *		buf = SvPOK(ST(1)) ? sv_grow(ST(1), BUFSIZ) : 0;
+    CODE:
+	if (handle)
+#ifdef PERLIO_IS_STDIO
+	    setbuf(handle, buf);
+#else
+	    not_here("IO::Handle::setbuf");
+#endif
+
+SysRet
+setvbuf(handle, buf, type, size)
+	OutputStream	handle
+	char *		buf = SvPOK(ST(1)) ? sv_grow(ST(1), SvIV(ST(3))) : 0;
+	int		type
+	int		size
+    CODE:
+/* Should check HAS_SETVBUF once Configure tests for that */
+#if defined(PERLIO_IS_STDIO) && defined(_IOFBF)
+	if (!handle)			/* Try input stream. */
+	    handle = IoIFP(sv_2io(ST(0)));
+	if (handle)
+	    RETVAL = setvbuf(handle, buf, type, size);
+	else {
+	    RETVAL = -1;
+	    errno = EINVAL;
+	}
+#else
+	RETVAL = (SysRet) not_here("IO::Handle::setvbuf");
+#endif
+    OUTPUT:
+	RETVAL
+
+
diff --git a/gnu/usr.bin/perl/ext/IO/Makefile.PL b/gnu/usr.bin/perl/ext/IO/Makefile.PL
new file mode 100644
index 00000000000..4a34be61fbb
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IO/Makefile.PL
@@ -0,0 +1,8 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+    NAME => 'IO',
+    MAN3PODS   => ' ',			# Pods will be built by installman.
+    XSPROTOARG => '-noprototypes', 	# XXX remove later?
+    VERSION_FROM => 'lib/IO/Handle.pm',
+    XS_VERSION => 1.15
+);
diff --git a/gnu/usr.bin/perl/ext/IO/README b/gnu/usr.bin/perl/ext/IO/README
new file mode 100644
index 00000000000..e855afade40
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IO/README
@@ -0,0 +1,4 @@
+This directory contains files from the IO distribution maintained by
+Graham Barr <bodg@tiuk.ti.com>. If you find that you have to modify
+any files in this directory then please forward him a patch for only
+the files in this directory.
diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/File.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/File.pm
new file mode 100644
index 00000000000..de7fabc6f25
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IO/lib/IO/File.pm
@@ -0,0 +1,167 @@
+#
+
+package IO::File;
+
+=head1 NAME
+
+IO::File - supply object methods for filehandles
+
+=head1 SYNOPSIS
+
+    use IO::File;
+
+    $fh = new IO::File;
+    if ($fh->open("< file")) {
+        print <$fh>;
+        $fh->close;
+    }
+
+    $fh = new IO::File "> file";
+    if (defined $fh) {
+        print $fh "bar\n";
+        $fh->close;
+    }
+
+    $fh = new IO::File "file", "r";
+    if (defined $fh) {
+        print <$fh>;
+        undef $fh;       # automatically closes the file
+    }
+
+    $fh = new IO::File "file", O_WRONLY|O_APPEND;
+    if (defined $fh) {
+        print $fh "corge\n";
+
+        $pos = $fh->getpos;
+        $fh->setpos($pos);
+
+        undef $fh;       # automatically closes the file
+    }
+
+    autoflush STDOUT 1;
+
+=head1 DESCRIPTION
+
+C<IO::File> inherits from C<IO::Handle> and C<IO::Seekable>. It extends
+these classes with methods that are specific to file handles.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ([ ARGS ] )
+
+Creates a C<IO::File>.  If it receives any parameters, they are passed to
+the method C<open>; if the open fails, the object is destroyed.  Otherwise,
+it is returned to the caller.
+
+=item new_tmpfile
+
+Creates an C<IO::File> opened for read/write on a newly created temporary
+file.  On systems where this is possible, the temporary file is anonymous
+(i.e. it is unlinked after creation, but held open).  If the temporary
+file cannot be created or opened, the C<IO::File> object is destroyed.
+Otherwise, it is returned to the caller.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item open( FILENAME [,MODE [,PERMS]] )
+
+C<open> accepts one, two or three parameters.  With one parameter,
+it is just a front end for the built-in C<open> function.  With two
+parameters, the first parameter is a filename that may include
+whitespace or other special characters, and the second parameter is
+the open mode, optionally followed by a file permission value.
+
+If C<IO::File::open> receives a Perl mode string ("E<gt>", "+E<lt>", etc.)
+or a POSIX fopen() mode string ("w", "r+", etc.), it uses the basic
+Perl C<open> operator.
+
+If C<IO::File::open> is given a numeric mode, it passes that mode
+and the optional permissions value to the Perl C<sysopen> operator.
+For convenience, C<IO::File::import> tries to import the O_XXX
+constants from the Fcntl module.  If dynamic loading is not available,
+this may fail, but the rest of IO::File will still work.
+
+=back
+
+=head1 SEE ALSO
+
+L<perlfunc>, 
+L<perlop/"I/O Operators">,
+L<IO::Handle>
+L<IO::Seekable>
+
+=head1 HISTORY
+
+Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>.
+
+=cut
+
+require 5.000;
+use strict;
+use vars qw($VERSION @EXPORT @EXPORT_OK $AUTOLOAD @ISA);
+use Carp;
+use Symbol;
+use SelectSaver;
+use IO::Seekable;
+
+require Exporter;
+require DynaLoader;
+
+@ISA = qw(IO::Handle IO::Seekable Exporter DynaLoader);
+
+$VERSION = "1.06021";
+
+@EXPORT = @IO::Seekable::EXPORT;
+
+eval {
+    # Make all Fcntl O_XXX constants available for importing
+    require Fcntl;
+    my @O = grep /^O_/, @Fcntl::EXPORT;
+    Fcntl->import(@O);  # first we import what we want to export
+    push(@EXPORT, @O);
+};
+
+
+################################################
+## Constructor
+##
+
+sub new {
+    my $type = shift;
+    my $class = ref($type) || $type || "IO::File";
+    @_ >= 0 && @_ <= 3
+	or croak "usage: new $class [FILENAME [,MODE [,PERMS]]]";
+    my $fh = $class->SUPER::new();
+    if (@_) {
+	$fh->open(@_)
+	    or return undef;
+    }
+    $fh;
+}
+
+################################################
+## Open
+##
+
+sub open {
+    @_ >= 2 && @_ <= 4 or croak 'usage: $fh->open(FILENAME [,MODE [,PERMS]])';
+    my ($fh, $file) = @_;
+    if (@_ > 2) {
+	my ($mode, $perms) = @_[2, 3];
+	if ($mode =~ /^\d+$/) {
+	    defined $perms or $perms = 0666;
+	    return sysopen($fh, $file, $mode, $perms);
+	}
+	$file = './' . $file if $file =~ m{\A[^\\/\w]};
+	$file = IO::Handle::_open_mode_string($mode) . " $file\0";
+    }
+    open($fh, $file);
+}
+
+1;
diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm
new file mode 100644
index 00000000000..39e32f05abb
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Handle.pm
@@ -0,0 +1,544 @@
+
+package IO::Handle;
+
+=head1 NAME
+
+IO::Handle - supply object methods for I/O handles
+
+=head1 SYNOPSIS
+
+    use IO::Handle;
+
+    $fh = new IO::Handle;
+    if ($fh->fdopen(fileno(STDIN),"r")) {
+        print $fh->getline;
+        $fh->close;
+    }
+
+    $fh = new IO::Handle;
+    if ($fh->fdopen(fileno(STDOUT),"w")) {
+        $fh->print("Some text\n");
+    }
+
+    use IO::Handle '_IOLBF';
+    $fh->setvbuf($buffer_var, _IOLBF, 1024);
+
+    undef $fh;       # automatically closes the file if it's open
+
+    autoflush STDOUT 1;
+
+=head1 DESCRIPTION
+
+C<IO::Handle> is the base class for all other IO handle classes. It is
+not intended that objects of C<IO::Handle> would be created directly,
+but instead C<IO::Handle> is inherited from by several other classes
+in the IO hierarchy.
+
+If you are reading this documentation, looking for a replacement for
+the C<FileHandle> package, then I suggest you read the documentation
+for C<IO::File>
+
+A C<IO::Handle> object is a reference to a symbol (see the C<Symbol> package)
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ()
+
+Creates a new C<IO::Handle> object.
+
+=item new_from_fd ( FD, MODE )
+
+Creates a C<IO::Handle> like C<new> does.
+It requires two parameters, which are passed to the method C<fdopen>;
+if the fdopen fails, the object is destroyed. Otherwise, it is returned
+to the caller.
+
+=back
+
+=head1 METHODS
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<IO::Handle> methods, which are just front ends for the
+corresponding built-in functions:
+
+    close
+    fileno
+    getc
+    eof
+    read
+    truncate
+    stat
+    print
+    printf
+    sysread
+    syswrite
+
+See L<perlvar> for complete descriptions of each of the following
+supported C<IO::Handle> methods:
+
+    autoflush
+    output_field_separator
+    output_record_separator
+    input_record_separator
+    input_line_number
+    format_page_number
+    format_lines_per_page
+    format_lines_left
+    format_name
+    format_top_name
+    format_line_break_characters
+    format_formfeed
+    format_write
+
+Furthermore, for doing normal I/O you might need these:
+
+=over 
+
+=item $fh->fdopen ( FD, MODE )
+
+C<fdopen> is like an ordinary C<open> except that its first parameter
+is not a filename but rather a file handle name, a IO::Handle object,
+or a file descriptor number.
+
+=item $fh->opened
+
+Returns true if the object is currently a valid file descriptor.
+
+=item $fh->getline
+
+This works like <$fh> described in L<perlop/"I/O Operators">
+except that it's more readable and can be safely called in an
+array context but still returns just one line.
+
+=item $fh->getlines
+
+This works like <$fh> when called in an array context to
+read all the remaining lines in a file, except that it's more readable.
+It will also croak() if accidentally called in a scalar context.
+
+=item $fh->ungetc ( ORD )
+
+Pushes a character with the given ordinal value back onto the given
+handle's input stream.
+
+=item $fh->write ( BUF, LEN [, OFFSET }\] )
+
+This C<write> is like C<write> found in C, that is it is the
+opposite of read. The wrapper for the perl C<write> function is
+called C<format_write>.
+
+=item $fh->flush
+
+Flush the given handle's buffer.
+
+=item $fh->error
+
+Returns a true value if the given handle has experienced any errors
+since it was opened or since the last call to C<clearerr>.
+
+=item $fh->clearerr
+
+Clear the given handle's error indicator.
+
+=back
+
+If the C functions setbuf() and/or setvbuf() are available, then
+C<IO::Handle::setbuf> and C<IO::Handle::setvbuf> set the buffering
+policy for an IO::Handle.  The calling sequences for the Perl functions
+are the same as their C counterparts--including the constants C<_IOFBF>,
+C<_IOLBF>, and C<_IONBF> for setvbuf()--except that the buffer parameter
+specifies a scalar variable to use as a buffer.  WARNING: A variable
+used as a buffer by C<setbuf> or C<setvbuf> must not be modified in any
+way until the IO::Handle is closed or C<setbuf> or C<setvbuf> is called
+again, or memory corruption may result!  Note that you need to import
+the constants C<_IOFBF>, C<_IOLBF>, and C<_IONBF> explicitly.
+
+Lastly, there is a special method for working under B<-T> and setuid/gid
+scripts:
+
+=over
+
+=item $fh->untaint
+
+Marks the object as taint-clean, and as such data read from it will also
+be considered taint-clean. Note that this is a very trusting action to
+take, and appropriate consideration for the data source and potential
+vulnerability should be kept in mind.
+
+=back
+
+=head1 NOTE
+
+A C<IO::Handle> object is a GLOB reference. Some modules that
+inherit from C<IO::Handle> may want to keep object related variables
+in the hash table part of the GLOB. In an attempt to prevent modules
+trampling on each other I propose the that any such module should prefix
+its variables with its own name separated by _'s. For example the IO::Socket
+module keeps a C<timeout> variable in 'io_socket_timeout'.
+
+=head1 SEE ALSO
+
+L<perlfunc>, 
+L<perlop/"I/O Operators">,
+L<IO::File>
+
+=head1 BUGS
+
+Due to backwards compatibility, all filehandles resemble objects
+of class C<IO::Handle>, or actually classes derived from that class.
+They actually aren't.  Which means you can't derive your own 
+class from C<IO::Handle> and inherit those methods.
+
+=head1 HISTORY
+
+Derived from FileHandle.pm by Graham Barr E<lt>F<bodg@tiuk.ti.com>E<gt>
+
+=cut
+
+require 5.000;
+use strict;
+use vars qw($VERSION $XS_VERSION @EXPORT_OK $AUTOLOAD @ISA);
+use Carp;
+use Symbol;
+use SelectSaver;
+
+require Exporter;
+@ISA = qw(Exporter);
+
+$VERSION = "1.1504";
+$XS_VERSION = "1.15";
+
+@EXPORT_OK = qw(
+    autoflush
+    output_field_separator
+    output_record_separator
+    input_record_separator
+    input_line_number
+    format_page_number
+    format_lines_per_page
+    format_lines_left
+    format_name
+    format_top_name
+    format_line_break_characters
+    format_formfeed
+    format_write
+
+    print
+    printf
+    getline
+    getlines
+
+    SEEK_SET
+    SEEK_CUR
+    SEEK_END
+    _IOFBF
+    _IOLBF
+    _IONBF
+);
+
+
+################################################
+## Interaction with the XS.
+##
+
+require DynaLoader;
+@IO::ISA = qw(DynaLoader);
+bootstrap IO $XS_VERSION;
+
+sub AUTOLOAD {
+    if ($AUTOLOAD =~ /::(_?[a-z])/) {
+	$AutoLoader::AUTOLOAD = $AUTOLOAD;
+	goto &AutoLoader::AUTOLOAD
+    }
+    my $constname = $AUTOLOAD;
+    $constname =~ s/.*:://;
+    my $val = constant($constname);
+    defined $val or croak "$constname is not a valid IO::Handle macro";
+    no strict 'refs';
+    *$AUTOLOAD = sub { $val };
+    goto &$AUTOLOAD;
+}
+
+
+################################################
+## Constructors, destructors.
+##
+
+sub new {
+    my $class = ref($_[0]) || $_[0] || "IO::Handle";
+    @_ == 1 or croak "usage: new $class";
+    my $fh = gensym;
+    bless $fh, $class;
+}
+
+sub new_from_fd {
+    my $class = ref($_[0]) || $_[0] || "IO::Handle";
+    @_ == 3 or croak "usage: new_from_fd $class FD, MODE";
+    my $fh = gensym;
+    shift;
+    IO::Handle::fdopen($fh, @_)
+	or return undef;
+    bless $fh, $class;
+}
+
+#
+# There is no need for DESTROY to do anything, because when the
+# last reference to an IO object is gone, Perl automatically
+# closes its associated files (if any).  However, to avoid any
+# attempts to autoload DESTROY, we here define it to do nothing.
+#
+sub DESTROY {}
+
+
+################################################
+## Open and close.
+##
+
+sub _open_mode_string {
+    my ($mode) = @_;
+    $mode =~ /^\+?(<|>>?)$/
+      or $mode =~ s/^r(\+?)$/$1</
+      or $mode =~ s/^w(\+?)$/$1>/
+      or $mode =~ s/^a(\+?)$/$1>>/
+      or croak "IO::Handle: bad open mode: $mode";
+    $mode;
+}
+
+sub fdopen {
+    @_ == 3 or croak 'usage: $fh->fdopen(FD, MODE)';
+    my ($fh, $fd, $mode) = @_;
+    local(*GLOB);
+
+    if (ref($fd) && "".$fd =~ /GLOB\(/o) {
+	# It's a glob reference; Alias it as we cannot get name of anon GLOBs
+	my $n = qualify(*GLOB);
+	*GLOB = *{*$fd};
+	$fd =  $n;
+    } elsif ($fd =~ m#^\d+$#) {
+	# It's an FD number; prefix with "=".
+	$fd = "=$fd";
+    }
+
+    open($fh, _open_mode_string($mode) . '&' . $fd)
+	? $fh : undef;
+}
+
+sub close {
+    @_ == 1 or croak 'usage: $fh->close()';
+    my($fh) = @_;
+
+    close($fh);
+}
+
+################################################
+## Normal I/O functions.
+##
+
+# flock
+# select
+
+sub opened {
+    @_ == 1 or croak 'usage: $fh->opened()';
+    defined fileno($_[0]);
+}
+
+sub fileno {
+    @_ == 1 or croak 'usage: $fh->fileno()';
+    fileno($_[0]);
+}
+
+sub getc {
+    @_ == 1 or croak 'usage: $fh->getc()';
+    getc($_[0]);
+}
+
+sub eof {
+    @_ == 1 or croak 'usage: $fh->eof()';
+    eof($_[0]);
+}
+
+sub print {
+    @_ or croak 'usage: $fh->print([ARGS])';
+    my $this = shift;
+    print $this @_;
+}
+
+sub printf {
+    @_ >= 2 or croak 'usage: $fh->printf(FMT,[ARGS])';
+    my $this = shift;
+    printf $this @_;
+}
+
+sub getline {
+    @_ == 1 or croak 'usage: $fh->getline';
+    my $this = shift;
+    return scalar <$this>;
+} 
+
+*gets = \&getline;  # deprecated
+
+sub getlines {
+    @_ == 1 or croak 'usage: $fh->getline()';
+    wantarray or
+	croak 'Can\'t call $fh->getlines in a scalar context, use $fh->getline';
+    my $this = shift;
+    return <$this>;
+}
+
+sub truncate {
+    @_ == 2 or croak 'usage: $fh->truncate(LEN)';
+    truncate($_[0], $_[1]);
+}
+
+sub read {
+    @_ == 3 || @_ == 4 or croak '$fh->read(BUF, LEN [, OFFSET])';
+    read($_[0], $_[1], $_[2], $_[3] || 0);
+}
+
+sub sysread {
+    @_ == 3 || @_ == 4 or croak '$fh->sysread(BUF, LEN [, OFFSET])';
+    sysread($_[0], $_[1], $_[2], $_[3] || 0);
+}
+
+sub write {
+    @_ == 3 || @_ == 4 or croak '$fh->write(BUF, LEN [, OFFSET])';
+    local($\) = "";
+    print { $_[0] } substr($_[1], $_[3] || 0, $_[2]);
+}
+
+sub syswrite {
+    @_ == 3 || @_ == 4 or croak '$fh->syswrite(BUF, LEN [, OFFSET])';
+    syswrite($_[0], $_[1], $_[2], $_[3] || 0);
+}
+
+sub stat {
+    @_ == 1 or croak 'usage: $fh->stat()';
+    stat($_[0]);
+}
+
+################################################
+## State modification functions.
+##
+
+sub autoflush {
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $|;
+    $| = @_ > 1 ? $_[1] : 1;
+    $prev;
+}
+
+sub output_field_separator {
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $,;
+    $, = $_[1] if @_ > 1;
+    $prev;
+}
+
+sub output_record_separator {
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $\;
+    $\ = $_[1] if @_ > 1;
+    $prev;
+}
+
+sub input_record_separator {
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $/;
+    $/ = $_[1] if @_ > 1;
+    $prev;
+}
+
+sub input_line_number {
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $.;
+    $. = $_[1] if @_ > 1;
+    $prev;
+}
+
+sub format_page_number {
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $%;
+    $% = $_[1] if @_ > 1;
+    $prev;
+}
+
+sub format_lines_per_page {
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $=;
+    $= = $_[1] if @_ > 1;
+    $prev;
+}
+
+sub format_lines_left {
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $-;
+    $- = $_[1] if @_ > 1;
+    $prev;
+}
+
+sub format_name {
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $~;
+    $~ = qualify($_[1], caller) if @_ > 1;
+    $prev;
+}
+
+sub format_top_name {
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $^;
+    $^ = qualify($_[1], caller) if @_ > 1;
+    $prev;
+}
+
+sub format_line_break_characters {
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $:;
+    $: = $_[1] if @_ > 1;
+    $prev;
+}
+
+sub format_formfeed {
+    my $old = new SelectSaver qualify($_[0], caller);
+    my $prev = $^L;
+    $^L = $_[1] if @_ > 1;
+    $prev;
+}
+
+sub formline {
+    my $fh = shift;
+    my $picture = shift;
+    local($^A) = $^A;
+    local($\) = "";
+    formline($picture, @_);
+    print $fh $^A;
+}
+
+sub format_write {
+    @_ < 3 || croak 'usage: $fh->write( [FORMAT_NAME] )';
+    if (@_ == 2) {
+	my ($fh, $fmt) = @_;
+	my $oldfmt = $fh->format_name($fmt);
+	write($fh);
+	$fh->format_name($oldfmt);
+    } else {
+	write($_[0]);
+    }
+}
+
+sub fcntl {
+    @_ == 3 || croak 'usage: $fh->fcntl( OP, VALUE );';
+    my ($fh, $op, $val) = @_;
+    my $r = fcntl($fh, $op, $val);
+    defined $r && $r eq "0 but true" ? 0 : $r;
+}
+
+sub ioctl {
+    @_ == 3 || croak 'usage: $fh->ioctl( OP, VALUE );';
+    my ($fh, $op, $val) = @_;
+    my $r = ioctl($fh, $op, $val);
+    defined $r && $r eq "0 but true" ? 0 : $r;
+}
+
+1;
diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/Pipe.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Pipe.pm
new file mode 100644
index 00000000000..ae6d9a547e2
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Pipe.pm
@@ -0,0 +1,239 @@
+# IO::Pipe.pm
+#
+# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Pipe;
+
+require 5.000;
+
+use IO::Handle;
+use strict;
+use vars qw($VERSION);
+use Carp;
+use Symbol;
+
+$VERSION = "1.0901";
+
+sub new {
+    my $type = shift;
+    my $class = ref($type) || $type || "IO::Pipe";
+    @_ == 0 || @_ == 2 or croak "usage: new $class [READFH, WRITEFH]";
+
+    my $me = bless gensym(), $class;
+
+    my($readfh,$writefh) = @_ ? @_ : $me->handles;
+
+    pipe($readfh, $writefh)
+	or return undef;
+
+    @{*$me} = ($readfh, $writefh);
+
+    $me;
+}
+
+sub handles {
+    @_ == 1 or croak 'usage: $pipe->handles()';
+    (IO::Pipe::End->new(), IO::Pipe::End->new());
+}
+
+my $do_spawn = $^O eq 'os2';
+
+sub _doit {
+    my $me = shift;
+    my $rw = shift;
+
+    my $pid = $do_spawn ? 0 : fork();
+
+    if($pid) { # Parent
+        return $pid;
+    }
+    elsif(defined $pid) { # Child or spawn
+        my $fh;
+        my $io = $rw ? \*STDIN : \*STDOUT;
+        my ($mode, $save) = $rw ? "r" : "w";
+        if ($do_spawn) {
+          require Fcntl;
+          $save = IO::Handle->new_from_fd($io, $mode);
+          # Close in child:
+          fcntl(shift, Fcntl::F_SETFD(), 1) or croak "fcntl: $!";
+          $fh = $rw ? ${*$me}[0] : ${*$me}[1];
+        } else {
+          shift;
+          $fh = $rw ? $me->reader() : $me->writer(); # close the other end
+        }
+        bless $io, "IO::Handle";
+        $io->fdopen($fh, $mode);
+        $fh->close;
+
+        if ($do_spawn) {
+          $pid = eval { system 1, @_ }; # 1 == P_NOWAIT
+          my $err = $!;
+    
+          $io->fdopen($save, $mode);
+          $save->close or croak "Cannot close $!";
+          croak "IO::Pipe: Cannot spawn-NOWAIT: $err" if not $pid or $pid < 0;
+          return $pid;
+        } else {
+          exec @_ or
+            croak "IO::Pipe: Cannot exec: $!";
+        }
+    }
+    else {
+        croak "IO::Pipe: Cannot fork: $!";
+    }
+
+    # NOT Reached
+}
+
+sub reader {
+    @_ >= 1 or croak 'usage: $pipe->reader()';
+    my $me = shift;
+    my $fh  = ${*$me}[0];
+    my $pid = $me->_doit(0, $fh, @_)
+        if(@_);
+
+    close ${*$me}[1];
+    bless $me, ref($fh);
+    *{*$me} = *{*$fh};          # Alias self to handle
+    bless $fh;                  # Really wan't un-bless here
+    ${*$me}{'io_pipe_pid'} = $pid
+        if defined $pid;
+
+    $me;
+}
+
+sub writer {
+    @_ >= 1 or croak 'usage: $pipe->writer()';
+    my $me = shift;
+    my $fh  = ${*$me}[1];
+    my $pid = $me->_doit(1, $fh, @_)
+        if(@_);
+
+    close ${*$me}[0];
+    bless $me, ref($fh);
+    *{*$me} = *{*$fh};          # Alias self to handle
+    bless $fh;                  # Really wan't un-bless here
+    ${*$me}{'io_pipe_pid'} = $pid
+        if defined $pid;
+
+    $me;
+}
+
+package IO::Pipe::End;
+
+use vars qw(@ISA);
+
+@ISA = qw(IO::Handle);
+
+sub close {
+    my $fh = shift;
+    my $r = $fh->SUPER::close(@_);
+
+    waitpid(${*$fh}{'io_pipe_pid'},0)
+	if(defined ${*$fh}{'io_pipe_pid'});
+
+    $r;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+IO::pipe - supply object methods for pipes
+
+=head1 SYNOPSIS
+
+	use IO::Pipe;
+
+	$pipe = new IO::Pipe;
+
+	if($pid = fork()) { # Parent
+	    $pipe->reader();
+
+	    while(<$pipe> {
+		....
+	    }
+
+	}
+	elsif(defined $pid) { # Child
+	    $pipe->writer();
+
+	    print $pipe ....
+	}
+
+	or
+
+	$pipe = new IO::Pipe;
+
+	$pipe->reader(qw(ls -l));
+
+	while(<$pipe>) {
+	    ....
+	}
+
+=head1 DESCRIPTION
+
+C<IO::Pipe> provides an interface to createing pipes between
+processes.
+
+=head1 CONSTRCUTOR
+
+=over 4
+
+=item new ( [READER, WRITER] )
+
+Creates a C<IO::Pipe>, which is a reference to a newly created symbol
+(see the C<Symbol> package). C<IO::Pipe::new> optionally takes two
+arguments, which should be objects blessed into C<IO::Handle>, or a
+subclass thereof. These two objects will be used for the system call
+to C<pipe>. If no arguments are given then method C<handles> is called
+on the new C<IO::Pipe> object.
+
+These two handles are held in the array part of the GLOB until either
+C<reader> or C<writer> is called.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item reader ([ARGS])
+
+The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
+handle at the reading end of the pipe. If C<ARGS> are given then C<fork>
+is called and C<ARGS> are passed to exec.
+
+=item writer ([ARGS])
+
+The object is re-blessed into a sub-class of C<IO::Handle>, and becomes a
+handle at the writing end of the pipe. If C<ARGS> are given then C<fork>
+is called and C<ARGS> are passed to exec.
+
+=item handles ()
+
+This method is called during construction by C<IO::Pipe::new>
+on the newly created C<IO::Pipe> object. It returns an array of two objects
+blessed into C<IO::Pipe::End>, or a subclass thereof.
+
+=back
+
+=head1 SEE ALSO
+
+L<IO::Handle>
+
+=head1 AUTHOR
+
+Graham Barr <bodg@tiuk.ti.com>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1996 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/Seekable.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Seekable.pm
new file mode 100644
index 00000000000..91c381a61e9
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Seekable.pm
@@ -0,0 +1,68 @@
+#
+
+package IO::Seekable;
+
+=head1 NAME
+
+IO::Seekable - supply seek based methods for I/O objects
+
+=head1 SYNOPSIS
+
+    use IO::Seekable;
+    package IO::Something;
+    @ISA = qw(IO::Seekable);
+
+=head1 DESCRIPTION
+
+C<IO::Seekable> does not have a constuctor of its own as is intended to
+be inherited by other C<IO::Handle> based objects. It provides methods
+which allow seeking of the file descriptors.
+
+If the C functions fgetpos() and fsetpos() are available, then
+C<IO::File::getpos> returns an opaque value that represents the
+current position of the IO::File, and C<IO::File::setpos> uses
+that value to return to a previously visited position.
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<IO::Seekable> methods, which are just front ends for the
+corresponding built-in functions:
+
+    seek
+    tell
+
+=head1 SEE ALSO
+
+L<perlfunc>, 
+L<perlop/"I/O Operators">,
+L<IO::Handle>
+L<IO::File>
+
+=head1 HISTORY
+
+Derived from FileHandle.pm by Graham Barr E<lt>bodg@tiuk.ti.comE<gt>
+
+=cut
+
+require 5.000;
+use Carp;
+use strict;
+use vars qw($VERSION @EXPORT @ISA);
+use IO::Handle qw(SEEK_SET SEEK_CUR SEEK_END);
+require Exporter;
+
+@EXPORT = qw(SEEK_SET SEEK_CUR SEEK_END);
+@ISA = qw(Exporter);
+
+$VERSION = "1.06";
+
+sub seek {
+    @_ == 3 or croak 'usage: $fh->seek(POS, WHENCE)';
+    seek($_[0], $_[1], $_[2]);
+}
+
+sub tell {
+    @_ == 1 or croak 'usage: $fh->tell()';
+    tell($_[0]);
+}
+
+1;
diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/Select.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Select.pm
new file mode 100644
index 00000000000..dea684a62ed
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Select.pm
@@ -0,0 +1,371 @@
+# IO::Select.pm
+#
+# Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+# software; you can redistribute it and/or modify it under the same terms
+# as Perl itself.
+
+package IO::Select;
+
+=head1 NAME
+
+IO::Select - OO interface to the select system call
+
+=head1 SYNOPSIS
+
+    use IO::Select;
+
+    $s = IO::Select->new();
+
+    $s->add(\*STDIN);
+    $s->add($some_handle);
+
+    @ready = $s->can_read($timeout);
+
+    @ready = IO::Select->new(@handles)->read(0);
+
+=head1 DESCRIPTION
+
+The C<IO::Select> package implements an object approach to the system C<select>
+function call. It allows the user to see what IO handles, see L<IO::Handle>,
+are ready for reading, writing or have an error condition pending.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ HANDLES ] )
+
+The constructor creates a new object and optionally initialises it with a set
+of handles.
+
+=back
+
+=head1 METHODS
+
+=over 4
+
+=item add ( HANDLES )
+
+Add the list of handles to the C<IO::Select> object. It is these values that
+will be returned when an event occurs. C<IO::Select> keeps these values in a
+cache which is indexed by the C<fileno> of the handle, so if more than one
+handle with the same C<fileno> is specified then only the last one is cached.
+
+Each handle can be an C<IO::Handle> object, an integer or an array
+reference where the first element is a C<IO::Handle> or an integer.
+
+=item remove ( HANDLES )
+
+Remove all the given handles from the object. This method also works
+by the C<fileno> of the handles. So the exact handles that were added
+need not be passed, just handles that have an equivalent C<fileno>
+
+=item exists ( HANDLE )
+
+Returns a true value (actually the handle itself) if it is present.
+Returns undef otherwise.
+
+=item handles
+
+Return an array of all registered handles.
+
+=item can_read ( [ TIMEOUT ] )
+
+Return an array of handles that are ready for reading. C<TIMEOUT> is
+the maximum amount of time to wait before returning an empty list. If
+C<TIMEOUT> is not given and any handles are registered then the call
+will block.
+
+=item can_write ( [ TIMEOUT ] )
+
+Same as C<can_read> except check for handles that can be written to.
+
+=item has_error ( [ TIMEOUT ] )
+
+Same as C<can_read> except check for handles that have an error
+condition, for example EOF.
+
+=item count ()
+
+Returns the number of handles that the object will check for when
+one of the C<can_> methods is called or the object is passed to
+the C<select> static method.
+
+=item bits()
+
+Return the bit string suitable as argument to the core select() call.
+
+=item bits()
+
+Return the bit string suitable as argument to the core select() call.
+
+=item select ( READ, WRITE, ERROR [, TIMEOUT ] )
+
+C<select> is a static method, that is you call it with the package
+name like C<new>. C<READ>, C<WRITE> and C<ERROR> are either C<undef>
+or C<IO::Select> objects. C<TIMEOUT> is optional and has the same
+effect as for the core select call.
+
+The result will be an array of 3 elements, each a reference to an array
+which will hold the handles that are ready for reading, writing and have
+error conditions respectively. Upon error an empty array is returned.
+
+=back
+
+=head1 EXAMPLE
+
+Here is a short example which shows how C<IO::Select> could be used
+to write a server which communicates with several sockets while also
+listening for more connections on a listen socket
+
+    use IO::Select;
+    use IO::Socket;
+
+    $lsn = new IO::Socket::INET(Listen => 1, LocalPort => 8080);
+    $sel = new IO::Select( $lsn );
+    
+    while(@ready = $sel->can_read) {
+        foreach $fh (@ready) {
+            if($fh == $lsn) {
+                # Create a new socket
+                $new = $lsn->accept;
+                $sel->add($new);
+            }
+            else {
+                # Process socket
+
+                # Maybe we have finished with the socket
+                $sel->remove($fh);
+                $fh->close;
+            }
+        }
+    }
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1995 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+use     strict;
+use     vars qw($VERSION @ISA);
+require Exporter;
+
+$VERSION = "1.10";
+
+@ISA = qw(Exporter); # This is only so we can do version checking
+
+sub VEC_BITS () {0}
+sub FD_COUNT () {1}
+sub FIRST_FD () {2}
+
+sub new
+{
+ my $self = shift;
+ my $type = ref($self) || $self;
+
+ my $vec = bless [undef,0], $type;
+
+ $vec->add(@_)
+    if @_;
+
+ $vec;
+}
+
+sub add
+{
+ shift->_update('add', @_);
+}
+
+
+sub remove
+{
+ shift->_update('remove', @_);
+}
+
+
+sub exists
+{
+ my $vec = shift;
+ $vec->[$vec->_fileno(shift) + FIRST_FD];
+}
+
+
+sub _fileno
+{
+ my($self, $f) = @_;
+ $f = $f->[0] if ref($f) eq 'ARRAY';
+ ($f =~ /^\d+$/) ? $f : fileno($f);
+}
+
+sub _update
+{
+ my $vec = shift;
+ my $add = shift eq 'add';
+
+ my $bits = $vec->[VEC_BITS];
+ $bits = '' unless defined $bits;
+
+ my $count = 0;
+ my $f;
+ foreach $f (@_)
+  {
+   my $fn = $vec->_fileno($f);
+   next unless defined $fn;
+   my $i = $fn + FIRST_FD;
+   if ($add) {
+     if (defined $vec->[$i]) {
+	 $vec->[$i] = $f;  # if array rest might be different, so we update
+	 next;
+     }
+     $vec->[FD_COUNT]++;
+     vec($bits, $fn, 1) = 1;
+     $vec->[$i] = $f;
+   } else {      # remove
+     next unless defined $vec->[$i];
+     $vec->[FD_COUNT]--;
+     vec($bits, $fn, 1) = 0;
+     $vec->[$i] = undef;
+   }
+   $count++;
+  }
+ $vec->[VEC_BITS] = $vec->[FD_COUNT] ? $bits : undef;
+ $count;
+}
+
+sub can_read
+{
+ my $vec = shift;
+ my $timeout = shift;
+ my $r = $vec->[VEC_BITS];
+
+ defined($r) && (select($r,undef,undef,$timeout) > 0)
+    ? handles($vec, $r)
+    : ();
+}
+
+sub can_write
+{
+ my $vec = shift;
+ my $timeout = shift;
+ my $w = $vec->[VEC_BITS];
+
+ defined($w) && (select(undef,$w,undef,$timeout) > 0)
+    ? handles($vec, $w)
+    : ();
+}
+
+sub has_error
+{
+ my $vec = shift;
+ my $timeout = shift;
+ my $e = $vec->[VEC_BITS];
+
+ defined($e) && (select(undef,undef,$e,$timeout) > 0)
+    ? handles($vec, $e)
+    : ();
+}
+
+sub count
+{
+ my $vec = shift;
+ $vec->[FD_COUNT];
+}
+
+sub bits
+{
+ my $vec = shift;
+ $vec->[VEC_BITS];
+}
+
+sub as_string  # for debugging
+{
+ my $vec = shift;
+ my $str = ref($vec) . ": ";
+ my $bits = $vec->bits;
+ my $count = $vec->count;
+ $str .= defined($bits) ? unpack("b*", $bits) : "undef";
+ $str .= " $count";
+ my @handles = @$vec;
+ splice(@handles, 0, FIRST_FD);
+ for (@handles) {
+     $str .= " " . (defined($_) ? "$_" : "-");
+ }
+ $str;
+}
+
+sub _max
+{
+ my($a,$b,$c) = @_;
+ $a > $b
+    ? $a > $c
+        ? $a
+        : $c
+    : $b > $c
+        ? $b
+        : $c;
+}
+
+sub select
+{
+ shift
+   if defined $_[0] && !ref($_[0]);
+
+ my($r,$w,$e,$t) = @_;
+ my @result = ();
+
+ my $rb = defined $r ? $r->[VEC_BITS] : undef;
+ my $wb = defined $w ? $w->[VEC_BITS] : undef;
+ my $eb = defined $e ? $e->[VEC_BITS] : undef;
+
+ if(select($rb,$wb,$eb,$t) > 0)
+  {
+   my @r = ();
+   my @w = ();
+   my @e = ();
+   my $i = _max(defined $r ? scalar(@$r)-1 : 0,
+                defined $w ? scalar(@$w)-1 : 0,
+                defined $e ? scalar(@$e)-1 : 0);
+
+   for( ; $i >= FIRST_FD ; $i--)
+    {
+     my $j = $i - FIRST_FD;
+     push(@r, $r->[$i])
+        if defined $rb && defined $r->[$i] && vec($rb, $j, 1);
+     push(@w, $w->[$i])
+        if defined $wb && defined $w->[$i] && vec($wb, $j, 1);
+     push(@e, $e->[$i])
+        if defined $eb && defined $e->[$i] && vec($eb, $j, 1);
+    }
+
+   @result = (\@r, \@w, \@e);
+  }
+ @result;
+}
+
+
+sub handles
+{
+ my $vec = shift;
+ my $bits = shift;
+ my @h = ();
+ my $i;
+ my $max = scalar(@$vec) - 1;
+
+ for ($i = FIRST_FD; $i <= $max; $i++)
+  {
+   next unless defined $vec->[$i];
+   push(@h, $vec->[$i])
+      if !defined($bits) || vec($bits, $i - FIRST_FD, 1);
+  }
+ 
+ @h;
+}
+
+1;
diff --git a/gnu/usr.bin/perl/ext/IO/lib/IO/Socket.pm b/gnu/usr.bin/perl/ext/IO/lib/IO/Socket.pm
new file mode 100644
index 00000000000..aadb502f193
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/IO/lib/IO/Socket.pm
@@ -0,0 +1,728 @@
+# IO::Socket.pm
+#
+# Copyright (c) 1996 Graham Barr <Graham.Barr@tiuk.ti.com>. All rights
+# reserved. This program is free software; you can redistribute it and/or
+# modify it under the same terms as Perl itself.
+
+package IO::Socket;
+
+=head1 NAME
+
+IO::Socket - Object interface to socket communications
+
+=head1 SYNOPSIS
+
+    use IO::Socket;
+
+=head1 DESCRIPTION
+
+C<IO::Socket> provides an object interface to creating and using sockets. It
+is built upon the L<IO::Handle> interface and inherits all the methods defined
+by L<IO::Handle>.
+
+C<IO::Socket> only defines methods for those operations which are common to all
+types of socket. Operations which are specified to a socket in a particular 
+domain have methods defined in sub classes of C<IO::Socket>
+
+C<IO::Socket> will export all functions (and constants) defined by L<Socket>.
+
+=head1 CONSTRUCTOR
+
+=over 4
+
+=item new ( [ARGS] )
+
+Creates an C<IO::Socket>, which is a reference to a
+newly created symbol (see the C<Symbol> package). C<new>
+optionally takes arguments, these arguments are in key-value pairs.
+C<new> only looks for one key C<Domain> which tells new which domain
+the socket will be in. All other arguments will be passed to the
+configuration method of the package for that domain, See below.
+
+C<IO::Socket>s will be in autoflush mode after creation.  Note that
+versions of IO::Socket prior to 1.1603 (as shipped with Perl 5.004_04)
+did not do this.   So if you need backward compatibility, you should
+set autoflush explicitly.
+
+=back
+
+=head1 METHODS
+
+See L<perlfunc> for complete descriptions of each of the following
+supported C<IO::Socket> methods, which are just front ends for the
+corresponding built-in functions:
+
+    socket
+    socketpair
+    bind
+    listen
+    accept
+    send
+    recv
+    peername (getpeername)
+    sockname (getsockname)
+
+Some methods take slightly different arguments to those defined in L<perlfunc>
+in attempt to make the interface more flexible. These are
+
+=over 4
+
+=item accept([PKG])
+
+perform the system call C<accept> on the socket and return a new object. The
+new object will be created in the same class as the listen socket, unless
+C<PKG> is specified. This object can be used to communicate with the client
+that was trying to connect. In a scalar context the new socket is returned,
+or undef upon failure. In an array context a two-element array is returned
+containing the new socket and the peer address, the list will
+be empty upon failure.
+
+Additional methods that are provided are
+
+=item timeout([VAL])
+
+Set or get the timeout value associated with this socket. If called without
+any arguments then the current setting is returned. If called with an argument
+the current setting is changed and the previous value returned.
+
+=item sockopt(OPT [, VAL])
+
+Unified method to both set and get options in the SOL_SOCKET level. If called
+with one argument then getsockopt is called, otherwise setsockopt is called.
+
+=item sockdomain
+
+Returns the numerical number for the socket domain type. For example, for
+a AF_INET socket the value of &AF_INET will be returned.
+
+=item socktype
+
+Returns the numerical number for the socket type. For example, for
+a SOCK_STREAM socket the value of &SOCK_STREAM will be returned.
+
+=item protocol
+
+Returns the numerical number for the protocol being used on the socket, if
+known. If the protocol is unknown, as with an AF_UNIX socket, zero
+is returned.
+
+=back
+
+=cut
+
+
+require 5.000;
+
+use Config;
+use IO::Handle;
+use Socket 1.3;
+use Carp;
+use strict;
+use vars qw(@ISA $VERSION);
+use Exporter;
+
+@ISA = qw(IO::Handle);
+
+$VERSION = "1.1603";
+
+sub import {
+    my $pkg = shift;
+    my $callpkg = caller;
+    Exporter::export 'Socket', $callpkg, @_;
+}
+
+sub new {
+    my($class,%arg) = @_;
+    my $fh = $class->SUPER::new();
+    $fh->autoflush;
+
+    ${*$fh}{'io_socket_timeout'} = delete $arg{Timeout};
+
+    return scalar(%arg) ? $fh->configure(\%arg)
+			: $fh;
+}
+
+my @domain2pkg = ();
+
+sub register_domain {
+    my($p,$d) = @_;
+    $domain2pkg[$d] = $p;
+}
+
+sub configure {
+    my($fh,$arg) = @_;
+    my $domain = delete $arg->{Domain};
+
+    croak 'IO::Socket: Cannot configure a generic socket'
+	unless defined $domain;
+
+    croak "IO::Socket: Unsupported socket domain"
+	unless defined $domain2pkg[$domain];
+
+    croak "IO::Socket: Cannot configure socket in domain '$domain'"
+	unless ref($fh) eq "IO::Socket";
+
+    bless($fh, $domain2pkg[$domain]);
+    $fh->configure($arg);
+}
+
+sub socket {
+    @_ == 4 or croak 'usage: $fh->socket(DOMAIN, TYPE, PROTOCOL)';
+    my($fh,$domain,$type,$protocol) = @_;
+
+    socket($fh,$domain,$type,$protocol) or
+    	return undef;
+
+    ${*$fh}{'io_socket_domain'} = $domain;
+    ${*$fh}{'io_socket_type'}   = $type;
+    ${*$fh}{'io_socket_proto'}  = $protocol;
+
+    $fh;
+}
+
+sub socketpair {
+    @_ == 4 || croak 'usage: IO::Socket->pair(DOMAIN, TYPE, PROTOCOL)';
+    my($class,$domain,$type,$protocol) = @_;
+    my $fh1 = $class->new();
+    my $fh2 = $class->new();
+
+    socketpair($fh1,$fh1,$domain,$type,$protocol) or
+    	return ();
+
+    ${*$fh1}{'io_socket_type'}  = ${*$fh2}{'io_socket_type'}  = $type;
+    ${*$fh1}{'io_socket_proto'} = ${*$fh2}{'io_socket_proto'} = $protocol;
+
+    ($fh1,$fh2);
+}
+
+sub connect {
+    @_ == 2 || @_ == 3 or croak 'usage: $fh->connect(NAME) or $fh->connect(PORT, ADDR)';
+    my $fh = shift;
+    my $addr = @_ == 1 ? shift : sockaddr_in(@_);
+    my $timeout = ${*$fh}{'io_socket_timeout'};
+    local($SIG{ALRM}) = $timeout ? sub { undef $fh; }
+				 : $SIG{ALRM} || 'DEFAULT';
+
+     eval {
+    	croak 'connect: Bad address'
+    	    if(@_ == 2 && !defined $_[1]);
+
+    	if($timeout) {
+    	    defined $Config{d_alarm} && defined alarm($timeout) or
+    	    	$timeout = 0;
+    	}
+
+	my $ok = connect($fh, $addr);
+
+    	alarm(0)
+    	    if($timeout);
+
+	croak "connect: timeout"
+	    unless defined $fh;
+
+	undef $fh unless $ok;
+    };
+
+    $fh;
+}
+
+sub bind {
+    @_ == 2 || @_ == 3 or croak 'usage: $fh->bind(NAME) or $fh->bind(PORT, ADDR)';
+    my $fh = shift;
+    my $addr = @_ == 1 ? shift : sockaddr_in(@_);
+
+    return bind($fh, $addr) ? $fh
+			    : undef;
+}
+
+sub listen {
+    @_ >= 1 && @_ <= 2 or croak 'usage: $fh->listen([QUEUE])';
+    my($fh,$queue) = @_;
+    $queue = 5
+	unless $queue && $queue > 0;
+
+    return listen($fh, $queue) ? $fh
+			       : undef;
+}
+
+sub accept {
+    @_ == 1 || @_ == 2 or croak 'usage $fh->accept([PKG])';
+    my $fh = shift;
+    my $pkg = shift || $fh;
+    my $timeout = ${*$fh}{'io_socket_timeout'};
+    my $new = $pkg->new(Timeout => $timeout);
+    my $peer = undef;
+
+    eval {
+    	if($timeout) {
+    	    my $fdset = "";
+    	    vec($fdset, $fh->fileno,1) = 1;
+    	    croak "accept: timeout"
+    	    	unless select($fdset,undef,undef,$timeout);
+    	}
+    	$peer = accept($new,$fh);
+    };
+
+    return wantarray ? defined $peer ? ($new, $peer)
+    	    	    	    	     : () 
+    	      	     : defined $peer ? $new
+    	    	    	    	     : undef;
+}
+
+sub sockname {
+    @_ == 1 or croak 'usage: $fh->sockname()';
+    getsockname($_[0]);
+}
+
+sub peername {
+    @_ == 1 or croak 'usage: $fh->peername()';
+    my($fh) = @_;
+    getpeername($fh)
+      || ${*$fh}{'io_socket_peername'}
+      || undef;
+}
+
+sub send {
+    @_ >= 2 && @_ <= 4 or croak 'usage: $fh->send(BUF, [FLAGS, [TO]])';
+    my $fh    = $_[0];
+    my $flags = $_[2] || 0;
+    my $peer  = $_[3] || $fh->peername;
+
+    croak 'send: Cannot determine peer address'
+	 unless($peer);
+
+    my $r = defined(getpeername($fh))
+	? send($fh, $_[1], $flags)
+	: send($fh, $_[1], $flags, $peer);
+
+    # remember who we send to, if it was sucessful
+    ${*$fh}{'io_socket_peername'} = $peer
+	if(@_ == 4 && defined $r);
+
+    $r;
+}
+
+sub recv {
+    @_ == 3 || @_ == 4 or croak 'usage: $fh->recv(BUF, LEN [, FLAGS])';
+    my $sock  = $_[0];
+    my $len   = $_[2];
+    my $flags = $_[3] || 0;
+
+    # remember who we recv'd from
+    ${*$sock}{'io_socket_peername'} = recv($sock, $_[1]='', $len, $flags);
+}
+
+
+sub setsockopt {
+    @_ == 4 or croak '$fh->setsockopt(LEVEL, OPTNAME)';
+    setsockopt($_[0],$_[1],$_[2],$_[3]);
+}
+
+my $intsize = length(pack("i",0));
+
+sub getsockopt {
+    @_ == 3 or croak '$fh->getsockopt(LEVEL, OPTNAME)';
+    my $r = getsockopt($_[0],$_[1],$_[2]);
+    # Just a guess
+    $r = unpack("i", $r)
+	if(defined $r && length($r) == $intsize);
+    $r;
+}
+
+sub sockopt {
+    my $fh = shift;
+    @_ == 1 ? $fh->getsockopt(SOL_SOCKET,@_)
+	    : $fh->setsockopt(SOL_SOCKET,@_);
+}
+
+sub timeout {
+    @_ == 1 || @_ == 2 or croak 'usage: $fh->timeout([VALUE])';
+    my($fh,$val) = @_;
+    my $r = ${*$fh}{'io_socket_timeout'} || undef;
+
+    ${*$fh}{'io_socket_timeout'} = 0 + $val
+	if(@_ == 2);
+
+    $r;
+}
+
+sub sockdomain {
+    @_ == 1 or croak 'usage: $fh->sockdomain()';
+    my $fh = shift;
+    ${*$fh}{'io_socket_domain'};
+}
+
+sub socktype {
+    @_ == 1 or croak 'usage: $fh->socktype()';
+    my $fh = shift;
+    ${*$fh}{'io_socket_type'}
+}
+
+sub protocol {
+    @_ == 1 or croak 'usage: $fh->protocol()';
+    my($fh) = @_;
+    ${*$fh}{'io_socket_protocol'};
+}
+
+=head1 SUB-CLASSES
+
+=cut
+
+##
+## AF_INET
+##
+
+package IO::Socket::INET;
+
+use strict;
+use vars qw(@ISA);
+use Socket;
+use Carp;
+use Exporter;
+
+@ISA = qw(IO::Socket);
+
+IO::Socket::INET->register_domain( AF_INET );
+
+my %socket_type = ( tcp => SOCK_STREAM,
+		    udp => SOCK_DGRAM,
+		    icmp => SOCK_RAW,
+		  );
+
+=head2 IO::Socket::INET
+
+C<IO::Socket::INET> provides a constructor to create an AF_INET domain socket
+and some related methods. The constructor can take the following options
+
+    PeerAddr	Remote host address          <hostname>[:<port>]
+    PeerPort	Remote port or service       <service>[(<no>)] | <no>
+    LocalAddr	Local host bind	address      hostname[:port]
+    LocalPort	Local host bind	port         <service>[(<no>)] | <no>
+    Proto	Protocol name (or number)    "tcp" | "udp" | ...
+    Type	Socket type                  SOCK_STREAM | SOCK_DGRAM | ...
+    Listen	Queue size for listen
+    Reuse	Set SO_REUSEADDR before binding
+    Timeout	Timeout	value for various operations
+
+
+If C<Listen> is defined then a listen socket is created, else if the
+socket type, which is derived from the protocol, is SOCK_STREAM then
+connect() is called.
+
+The C<PeerAddr> can be a hostname or the IP-address on the
+"xx.xx.xx.xx" form.  The C<PeerPort> can be a number or a symbolic
+service name.  The service name might be followed by a number in
+parenthesis which is used if the service is not known by the system.
+The C<PeerPort> specification can also be embedded in the C<PeerAddr>
+by preceding it with a ":".
+
+If C<Proto> is not given and you specify a symbolic C<PeerPort> port,
+then the constructor will try to derive C<Proto> from the service
+name.  As a last resort C<Proto> "tcp" is assumed.  The C<Type>
+parameter will be deduced from C<Proto> if not specified.
+
+If the constructor is only passed a single argument, it is assumed to
+be a C<PeerAddr> specification.
+
+Examples:
+
+   $sock = IO::Socket::INET->new(PeerAddr => 'www.perl.org',
+                                 PeerPort => 'http(80)',
+                                 Proto    => 'tcp');
+
+   $sock = IO::Socket::INET->new(PeerAddr => 'localhost:smtp(25)');
+
+   $sock = IO::Socket::INET->new(Listen    => 5,
+                                 LocalAddr => 'localhost',
+                                 LocalPort => 9000,
+                                 Proto     => 'tcp');
+
+   $sock = IO::Socket::INET->new('127.0.0.1:25');
+
+
+=head2 METHODS
+
+=over 4
+
+=item sockaddr ()
+
+Return the address part of the sockaddr structure for the socket
+
+=item sockport ()
+
+Return the port number that the socket is using on the local host
+
+=item sockhost ()
+
+Return the address part of the sockaddr structure for the socket in a
+text form xx.xx.xx.xx
+
+=item peeraddr ()
+
+Return the address part of the sockaddr structure for the socket on
+the peer host
+
+=item peerport ()
+
+Return the port number for the socket on the peer host.
+
+=item peerhost ()
+
+Return the address part of the sockaddr structure for the socket on the
+peer host in a text form xx.xx.xx.xx
+
+=back
+
+=cut
+
+sub new
+{
+  my $class = shift;
+  unshift(@_, "PeerAddr") if @_ == 1;
+  return $class->SUPER::new(@_);
+}
+
+sub _sock_info {
+  my($addr,$port,$proto) = @_;
+  my @proto = ();
+  my @serv = ();
+
+  $port = $1
+	if(defined $addr && $addr =~ s,:([\w\(\)/]+)$,,);
+
+  if(defined $proto) {
+    @proto = $proto =~ m,\D, ? getprotobyname($proto)
+			     : getprotobynumber($proto);
+
+    $proto = $proto[2] || undef;
+  }
+
+  if(defined $port) {
+    $port =~ s,\((\d+)\)$,,;
+
+    my $defport = $1 || undef;
+    my $pnum = ($port =~ m,^(\d+)$,)[0];
+
+    @serv= getservbyname($port, $proto[0] || "")
+	if($port =~ m,\D,);
+
+    $port = $pnum || $serv[2] || $defport || undef;
+
+    $proto = (getprotobyname($serv[3]))[2] || undef
+	if @serv && !$proto;
+  }
+
+ return ($addr || undef,
+	 $port || undef,
+	 $proto || undef
+	);
+}
+
+sub _error {
+    my $fh = shift;
+    $@ = join("",ref($fh),": ",@_);
+    carp $@ if $^W;
+    close($fh)
+	if(defined fileno($fh));
+    return undef;
+}
+
+sub configure {
+    my($fh,$arg) = @_;
+    my($lport,$rport,$laddr,$raddr,$proto,$type);
+
+
+    ($laddr,$lport,$proto) = _sock_info($arg->{LocalAddr},
+					$arg->{LocalPort},
+					$arg->{Proto});
+
+    $laddr = defined $laddr ? inet_aton($laddr)
+			    : INADDR_ANY;
+
+    return _error($fh,"Bad hostname '",$arg->{LocalAddr},"'")
+	unless(defined $laddr);
+
+    unless(exists $arg->{Listen}) {
+	($raddr,$rport,$proto) = _sock_info($arg->{PeerAddr},
+					    $arg->{PeerPort},
+					    $proto);
+    }
+
+    if(defined $raddr) {
+	$raddr = inet_aton($raddr);
+	return _error($fh,"Bad hostname '",$arg->{PeerAddr},"'")
+		unless(defined $raddr);
+    }
+
+    $proto ||= (getprotobyname "tcp")[2];
+    return _error($fh,'Cannot determine protocol')
+	unless($proto);
+
+    my $pname = (getprotobynumber($proto))[0];
+    $type = $arg->{Type} || $socket_type{$pname};
+
+    $fh->socket(AF_INET, $type, $proto) or
+	return _error($fh,"$!");
+
+    if ($arg->{Reuse}) {
+	$fh->sockopt(SO_REUSEADDR,1) or
+		return _error($fh);
+    }
+
+    $fh->bind($lport || 0, $laddr) or
+	return _error($fh,"$!");
+
+    if(exists $arg->{Listen}) {
+	$fh->listen($arg->{Listen} || 5) or
+	    return _error($fh,"$!");
+    }
+    else {
+	return _error($fh,'Cannot determine remote port')
+		unless($rport || $type == SOCK_DGRAM || $type == SOCK_RAW);
+
+	if($type == SOCK_STREAM || defined $raddr) {
+	    return _error($fh,'Bad peer address')
+	    	unless(defined $raddr);
+
+	    $fh->connect($rport,$raddr) or
+		return _error($fh,"$!");
+	}
+    }
+
+    $fh;
+}
+
+sub sockaddr {
+    @_ == 1 or croak 'usage: $fh->sockaddr()';
+    my($fh) = @_;
+    (sockaddr_in($fh->sockname))[1];
+}
+
+sub sockport {
+    @_ == 1 or croak 'usage: $fh->sockport()';
+    my($fh) = @_;
+    (sockaddr_in($fh->sockname))[0];
+}
+
+sub sockhost {
+    @_ == 1 or croak 'usage: $fh->sockhost()';
+    my($fh) = @_;
+    inet_ntoa($fh->sockaddr);
+}
+
+sub peeraddr {
+    @_ == 1 or croak 'usage: $fh->peeraddr()';
+    my($fh) = @_;
+    (sockaddr_in($fh->peername))[1];
+}
+
+sub peerport {
+    @_ == 1 or croak 'usage: $fh->peerport()';
+    my($fh) = @_;
+    (sockaddr_in($fh->peername))[0];
+}
+
+sub peerhost {
+    @_ == 1 or croak 'usage: $fh->peerhost()';
+    my($fh) = @_;
+    inet_ntoa($fh->peeraddr);
+}
+
+##
+## AF_UNIX
+##
+
+package IO::Socket::UNIX;
+
+use strict;
+use vars qw(@ISA $VERSION);
+use Socket;
+use Carp;
+use Exporter;
+
+@ISA = qw(IO::Socket);
+
+IO::Socket::UNIX->register_domain( AF_UNIX );
+
+=head2 IO::Socket::UNIX
+
+C<IO::Socket::UNIX> provides a constructor to create an AF_UNIX domain socket
+and some related methods. The constructor can take the following options
+
+    Type    	Type of socket (eg SOCK_STREAM or SOCK_DGRAM)
+    Local   	Path to local fifo
+    Peer    	Path to peer fifo
+    Listen  	Create a listen socket
+
+=head2 METHODS
+
+=over 4
+
+=item hostpath()
+
+Returns the pathname to the fifo at the local end
+
+=item peerpath()
+
+Returns the pathanme to the fifo at the peer end
+
+=back
+
+=cut
+
+sub configure {
+    my($fh,$arg) = @_;
+    my($bport,$cport);
+
+    my $type = $arg->{Type} || SOCK_STREAM;
+
+    $fh->socket(AF_UNIX, $type, 0) or
+	return undef;
+
+    if(exists $arg->{Local}) {
+	my $addr = sockaddr_un($arg->{Local});
+	$fh->bind($addr) or
+	    return undef;
+    }
+    if(exists $arg->{Listen}) {
+	$fh->listen($arg->{Listen} || 5) or
+	    return undef;
+    }
+    elsif(exists $arg->{Peer}) {
+	my $addr = sockaddr_un($arg->{Peer});
+	$fh->connect($addr) or
+	    return undef;
+    }
+
+    $fh;
+}
+
+sub hostpath {
+    @_ == 1 or croak 'usage: $fh->hostpath()';
+    my $n = $_[0]->sockname || return undef;
+    (sockaddr_un($n))[0];
+}
+
+sub peerpath {
+    @_ == 1 or croak 'usage: $fh->peerpath()';
+    my $n = $_[0]->peername || return undef;
+    (sockaddr_un($n))[0];
+}
+
+=head1 SEE ALSO
+
+L<Socket>, L<IO::Handle>
+
+=head1 AUTHOR
+
+Graham Barr E<lt>F<Graham.Barr@tiuk.ti.com>E<gt>
+
+=head1 COPYRIGHT
+
+Copyright (c) 1996 Graham Barr. All rights reserved. This program is free
+software; you can redistribute it and/or modify it under the same terms
+as Perl itself.
+
+=cut
+
+1; # Keep require happy
diff --git a/gnu/usr.bin/perl/ext/NDBM_File/hints/dec_osf.pl b/gnu/usr.bin/perl/ext/NDBM_File/hints/dec_osf.pl
new file mode 100644
index 00000000000..e96d907e10a
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/NDBM_File/hints/dec_osf.pl
@@ -0,0 +1,2 @@
+#   Spider Boardman  <spider@Orb.Nashua.NH.US>
+$self->{LIBS} = [''];
diff --git a/gnu/usr.bin/perl/ext/NDBM_File/hints/dynixptx.pl b/gnu/usr.bin/perl/ext/NDBM_File/hints/dynixptx.pl
new file mode 100644
index 00000000000..d402c179014
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/NDBM_File/hints/dynixptx.pl
@@ -0,0 +1,3 @@
+# On DYNIX/ptx 4.0 (v4.1.3), ndbm is actually contained in the 
+# libc library, and must be explicitly linked against -lc when compiling.
+$self->{LIBS} = ['-lc'];
diff --git a/gnu/usr.bin/perl/ext/ODBM_File/hints/hpux.pl b/gnu/usr.bin/perl/ext/ODBM_File/hints/hpux.pl
new file mode 100644
index 00000000000..31f9d24bcae
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/ODBM_File/hints/hpux.pl
@@ -0,0 +1,4 @@
+#  Try to work around "bad free" messages.  See note in ODBM_File.xs.
+#   Andy Dougherty  <doughera@lafcol.lafayette.edu>
+#   Sun Sep  8 12:57:52 EDT 1996
+$self->{CCFLAGS} = $Config{ccflags} . ' -DDBM_BUG_DUPLICATE_FREE' ;
diff --git a/gnu/usr.bin/perl/ext/ODBM_File/hints/ultrix.pl b/gnu/usr.bin/perl/ext/ODBM_File/hints/ultrix.pl
new file mode 100644
index 00000000000..31f9d24bcae
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/ODBM_File/hints/ultrix.pl
@@ -0,0 +1,4 @@
+#  Try to work around "bad free" messages.  See note in ODBM_File.xs.
+#   Andy Dougherty  <doughera@lafcol.lafayette.edu>
+#   Sun Sep  8 12:57:52 EDT 1996
+$self->{CCFLAGS} = $Config{ccflags} . ' -DDBM_BUG_DUPLICATE_FREE' ;
diff --git a/gnu/usr.bin/perl/ext/Opcode/Makefile.PL b/gnu/usr.bin/perl/ext/Opcode/Makefile.PL
new file mode 100644
index 00000000000..7fdcdf6ac13
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Opcode/Makefile.PL
@@ -0,0 +1,7 @@
+use ExtUtils::MakeMaker;
+WriteMakefile(
+    NAME => 'Opcode',
+    MAN3PODS 	=> ' ',
+    VERSION_FROM => 'Opcode.pm',
+    XS_VERSION => '1.02'
+);
diff --git a/gnu/usr.bin/perl/ext/Opcode/Opcode.pm b/gnu/usr.bin/perl/ext/Opcode/Opcode.pm
new file mode 100644
index 00000000000..a35ad1b47b4
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Opcode/Opcode.pm
@@ -0,0 +1,569 @@
+package Opcode;
+
+require 5.002;
+
+use vars qw($VERSION $XS_VERSION @ISA @EXPORT_OK);
+
+$VERSION = "1.04";
+$XS_VERSION = "1.02";
+
+use strict;
+use Carp;
+use Exporter ();
+use DynaLoader ();
+@ISA = qw(Exporter DynaLoader);
+
+BEGIN {
+    @EXPORT_OK = qw(
+	opset ops_to_opset
+	opset_to_ops opset_to_hex invert_opset
+	empty_opset full_opset
+	opdesc opcodes opmask define_optag
+	opmask_add verify_opset opdump
+    );
+}
+
+sub opset (;@);
+sub opset_to_hex ($);
+sub opdump (;$);
+use subs @EXPORT_OK;
+
+bootstrap Opcode $XS_VERSION;
+
+_init_optags();
+
+sub ops_to_opset { opset @_ }	# alias for old name
+
+sub opset_to_hex ($) {
+    return "(invalid opset)" unless verify_opset($_[0]);
+    unpack("h*",$_[0]);
+}
+
+sub opdump (;$) {
+	my $pat = shift;
+    # handy utility: perl -MOpcode=opdump -e 'opdump File'
+    foreach(opset_to_ops(full_opset)) {
+        my $op = sprintf "  %12s  %s\n", $_, opdesc($_);
+		next if defined $pat and $op !~ m/$pat/i;
+		print $op;
+    }
+}
+
+
+
+sub _init_optags {
+    my(%all, %seen);
+    @all{opset_to_ops(full_opset)} = (); # keys only
+
+    local($_);
+    local($/) = "\n=cut"; # skip to optags definition section
+    <DATA>;
+    $/ = "\n=";		# now read in 'pod section' chunks
+    while(<DATA>) {
+	next unless m/^item\s+(:\w+)/;
+	my $tag = $1;
+
+	# Split into lines, keep only indented lines
+	my @lines = grep { m/^\s/    } split(/\n/);
+	foreach (@lines) { s/--.*//  } # delete comments
+	my @ops   = map  { split ' ' } @lines; # get op words
+
+	foreach(@ops) {
+	    warn "$tag - $_ already tagged in $seen{$_}\n" if $seen{$_};
+	    $seen{$_} = $tag;
+	    delete $all{$_};
+	}
+	# opset will croak on invalid names
+	define_optag($tag, opset(@ops));
+    }
+    close(DATA);
+    warn "Untagged opnames: ".join(' ',keys %all)."\n" if %all;
+}
+
+
+1;
+
+__DATA__
+
+=head1 NAME
+
+Opcode - Disable named opcodes when compiling perl code
+
+=head1 SYNOPSIS
+
+  use Opcode;
+
+
+=head1 DESCRIPTION
+
+Perl code is always compiled into an internal format before execution.
+
+Evaluating perl code (e.g. via "eval" or "do 'file'") causes
+the code to be compiled into an internal format and then,
+provided there was no error in the compilation, executed.
+The internal format is based on many distinct I<opcodes>.
+
+By default no opmask is in effect and any code can be compiled.
+
+The Opcode module allow you to define an I<operator mask> to be in
+effect when perl I<next> compiles any code.  Attempting to compile code
+which contains a masked opcode will cause the compilation to fail
+with an error. The code will not be executed.
+
+=head1 NOTE
+
+The Opcode module is not usually used directly. See the ops pragma and
+Safe modules for more typical uses.
+
+=head1 WARNING
+
+The authors make B<no warranty>, implied or otherwise, about the
+suitability of this software for safety or security purposes.
+
+The authors shall not in any case be liable for special, incidental,
+consequential, indirect or other similar damages arising from the use
+of this software.
+
+Your mileage will vary. If in any doubt B<do not use it>.
+
+
+=head1 Operator Names and Operator Lists
+
+The canonical list of operator names is the contents of the array
+op_name defined and initialised in file F<opcode.h> of the Perl
+source distribution (and installed into the perl library).
+
+Each operator has both a terse name (its opname) and a more verbose or
+recognisable descriptive name. The opdesc function can be used to
+return a list of descriptions for a list of operators.
+
+Many of the functions and methods listed below take a list of
+operators as parameters. Most operator lists can be made up of several
+types of element. Each element can be one of
+
+=over 8
+
+=item an operator name (opname)
+
+Operator names are typically small lowercase words like enterloop,
+leaveloop, last, next, redo etc. Sometimes they are rather cryptic
+like gv2cv, i_ncmp and ftsvtx.
+
+=item an operator tag name (optag)
+
+Operator tags can be used to refer to groups (or sets) of operators.
+Tag names always being with a colon. The Opcode module defines several
+optags and the user can define others using the define_optag function.
+
+=item a negated opname or optag
+
+An opname or optag can be prefixed with an exclamation mark, e.g., !mkdir.
+Negating an opname or optag means remove the corresponding ops from the
+accumulated set of ops at that point.
+
+=item an operator set (opset)
+
+An I<opset> as a binary string of approximately 43 bytes which holds a
+set or zero or more operators.
+
+The opset and opset_to_ops functions can be used to convert from
+a list of operators to an opset and I<vice versa>.
+
+Wherever a list of operators can be given you can use one or more opsets.
+See also Manipulating Opsets below.
+
+=back
+
+
+=head1 Opcode Functions
+
+The Opcode package contains functions for manipulating operator names
+tags and sets. All are available for export by the package.
+
+=over 8
+
+=item opcodes
+
+In a scalar context opcodes returns the number of opcodes in this
+version of perl (around 340 for perl5.002).
+
+In a list context it returns a list of all the operator names.
+(Not yet implemented, use @names = opset_to_ops(full_opset).)
+
+=item opset (OP, ...)
+
+Returns an opset containing the listed operators.
+
+=item opset_to_ops (OPSET)
+
+Returns a list of operator names corresponding to those operators in
+the set.
+
+=item opset_to_hex (OPSET)
+
+Returns a string representation of an opset. Can be handy for debugging.
+
+=item full_opset
+
+Returns an opset which includes all operators.
+
+=item empty_opset
+
+Returns an opset which contains no operators.
+
+=item invert_opset (OPSET)
+
+Returns an opset which is the inverse set of the one supplied.
+
+=item verify_opset (OPSET, ...)
+
+Returns true if the supplied opset looks like a valid opset (is the
+right length etc) otherwise it returns false. If an optional second
+parameter is true then verify_opset will croak on an invalid opset
+instead of returning false.
+
+Most of the other Opcode functions call verify_opset automatically
+and will croak if given an invalid opset.
+
+=item define_optag (OPTAG, OPSET)
+
+Define OPTAG as a symbolic name for OPSET. Optag names always start
+with a colon C<:>.
+
+The optag name used must not be defined already (define_optag will
+croak if it is already defined). Optag names are global to the perl
+process and optag definitions cannot be altered or deleted once
+defined.
+
+It is strongly recommended that applications using Opcode should use a
+leading capital letter on their tag names since lowercase names are
+reserved for use by the Opcode module. If using Opcode within a module
+you should prefix your tags names with the name of your module to
+ensure uniqueness and thus avoid clashes with other modules.
+
+=item opmask_add (OPSET)
+
+Adds the supplied opset to the current opmask. Note that there is
+currently I<no> mechanism for unmasking ops once they have been masked.
+This is intentional.
+
+=item opmask
+
+Returns an opset corresponding to the current opmask.
+
+=item opdesc (OP, ...)
+
+This takes a list of operator names and returns the corresponding list
+of operator descriptions.
+
+=item opdump (PAT)
+
+Dumps to STDOUT a two column list of op names and op descriptions.
+If an optional pattern is given then only lines which match the
+(case insensitive) pattern will be output.
+
+It's designed to be used as a handy command line utility:
+
+	perl -MOpcode=opdump -e opdump
+	perl -MOpcode=opdump -e 'opdump Eval'
+
+=back
+
+=head1 Manipulating Opsets
+
+Opsets may be manipulated using the perl bit vector operators & (and), | (or),
+^ (xor) and ~ (negate/invert).
+
+However you should never rely on the numerical position of any opcode
+within the opset. In other words both sides of a bit vector operator
+should be opsets returned from Opcode functions.
+
+Also, since the number of opcodes in your current version of perl might
+not be an exact multiple of eight, there may be unused bits in the last
+byte of an upset. This should not cause any problems (Opcode functions
+ignore those extra bits) but it does mean that using the ~ operator
+will typically not produce the same 'physical' opset 'string' as the
+invert_opset function.
+
+
+=head1 TO DO (maybe)
+
+    $bool = opset_eq($opset1, $opset2)	true if opsets are logically eqiv
+
+    $yes = opset_can($opset, @ops)	true if $opset has all @ops set
+
+    @diff = opset_diff($opset1, $opset2) => ('foo', '!bar', ...)
+
+=cut
+
+# the =cut above is used by _init_optags() to get here quickly
+
+=head1 Predefined Opcode Tags
+
+=over 5
+
+=item :base_core
+
+    null stub scalar pushmark wantarray const defined undef
+
+    rv2sv sassign
+
+    rv2av aassign aelem aelemfast aslice av2arylen
+
+    rv2hv helem hslice each values keys exists delete
+
+    preinc i_preinc predec i_predec postinc i_postinc postdec i_postdec
+    int hex oct abs pow multiply i_multiply divide i_divide
+    modulo i_modulo add i_add subtract i_subtract
+
+    left_shift right_shift bit_and bit_xor bit_or negate i_negate
+    not complement
+
+    lt i_lt gt i_gt le i_le ge i_ge eq i_eq ne i_ne ncmp i_ncmp
+    slt sgt sle sge seq sne scmp
+
+    substr vec stringify study pos length index rindex ord chr
+
+    ucfirst lcfirst uc lc quotemeta trans chop schop chomp schomp
+
+    match split
+
+    list lslice splice push pop shift unshift reverse
+
+    cond_expr flip flop andassign orassign and or xor
+
+    warn die lineseq nextstate unstack scope enter leave
+
+    rv2cv anoncode prototype
+
+    entersub leavesub return method -- XXX loops via recursion?
+
+    leaveeval -- needed for Safe to operate, is safe without entereval
+
+=item :base_mem
+
+These memory related ops are not included in :base_core because they
+can easily be used to implement a resource attack (e.g., consume all
+available memory).
+
+    concat repeat join range
+
+    anonlist anonhash
+
+Note that despite the existance of this optag a memory resource attack
+may still be possible using only :base_core ops.
+
+Disabling these ops is a I<very> heavy handed way to attempt to prevent
+a memory resource attack. It's probable that a specific memory limit
+mechanism will be added to perl in the near future.
+
+=item :base_loop
+
+These loop ops are not included in :base_core because they can easily be
+used to implement a resource attack (e.g., consume all available CPU time).
+
+    grepstart grepwhile
+    mapstart mapwhile
+    enteriter iter
+    enterloop leaveloop
+    last next redo
+    goto
+
+=item :base_io
+
+These ops enable I<filehandle> (rather than filename) based input and
+output. These are safe on the assumption that only pre-existing
+filehandles are available for use.  To create new filehandles other ops
+such as open would need to be enabled.
+
+    readline rcatline getc read
+
+    formline enterwrite leavewrite
+
+    print sysread syswrite send recv
+
+    eof tell seek sysseek
+
+    readdir telldir seekdir rewinddir
+
+=item :base_orig
+
+These are a hotchpotch of opcodes still waiting to be considered
+
+    gvsv gv gelem
+
+    padsv padav padhv padany
+
+    rv2gv refgen srefgen ref
+
+    bless -- could be used to change ownership of objects (reblessing)
+
+    pushre regcmaybe regcomp subst substcont
+
+    sprintf prtf -- can core dump
+
+    crypt
+
+    tie untie
+
+    dbmopen dbmclose
+    sselect select
+    pipe_op sockpair
+
+    getppid getpgrp setpgrp getpriority setpriority localtime gmtime
+
+    entertry leavetry -- can be used to 'hide' fatal errors
+
+=item :base_math
+
+These ops are not included in :base_core because of the risk of them being
+used to generate floating point exceptions (which would have to be caught
+using a $SIG{FPE} handler).
+
+    atan2 sin cos exp log sqrt
+
+These ops are not included in :base_core because they have an effect
+beyond the scope of the compartment.
+
+    rand srand
+
+=item :default
+
+A handy tag name for a I<reasonable> default set of ops.  (The current ops
+allowed are unstable while development continues. It will change.)
+
+    :base_core :base_mem :base_loop :base_io :base_orig
+
+If safety matters to you (and why else would you be using the Opcode module?)
+then you should not rely on the definition of this, or indeed any other, optag!
+
+
+=item :filesys_read
+
+    stat lstat readlink
+
+    ftatime ftblk ftchr ftctime ftdir fteexec fteowned fteread
+    ftewrite ftfile ftis ftlink ftmtime ftpipe ftrexec ftrowned
+    ftrread ftsgid ftsize ftsock ftsuid fttty ftzero ftrwrite ftsvtx
+
+    fttext ftbinary
+
+    fileno
+
+=item :sys_db
+
+    ghbyname ghbyaddr ghostent shostent ehostent      -- hosts
+    gnbyname gnbyaddr gnetent snetent enetent         -- networks
+    gpbyname gpbynumber gprotoent sprotoent eprotoent -- protocols
+    gsbyname gsbyport gservent sservent eservent      -- services
+
+    gpwnam gpwuid gpwent spwent epwent getlogin       -- users
+    ggrnam ggrgid ggrent sgrent egrent                -- groups
+
+=item :browse
+
+A handy tag name for a I<reasonable> default set of ops beyond the
+:default optag.  Like :default (and indeed all the other optags) its
+current definition is unstable while development continues. It will change.
+
+The :browse tag represents the next step beyond :default. It it a
+superset of the :default ops and adds :filesys_read the :sys_db.
+The intent being that scripts can access more (possibly sensitive)
+information about your system but not be able to change it.
+
+    :default :filesys_read :sys_db
+
+=item :filesys_open
+
+    sysopen open close
+    umask binmode
+
+    open_dir closedir -- other dir ops are in :base_io
+
+=item :filesys_write
+
+    link unlink rename symlink truncate
+
+    mkdir rmdir
+
+    utime chmod chown
+
+    fcntl -- not strictly filesys related, but possibly as dangerous?
+
+=item :subprocess
+
+    backtick system
+
+    fork
+
+    wait waitpid
+
+    glob -- access to Cshell via <`rm *`>
+
+=item :ownprocess
+
+    exec exit kill
+
+    time tms -- could be used for timing attacks (paranoid?)
+
+=item :others
+
+This tag holds groups of assorted specialist opcodes that don't warrant
+having optags defined for them.
+
+SystemV Interprocess Communications:
+
+    msgctl msgget msgrcv msgsnd
+
+    semctl semget semop
+
+    shmctl shmget shmread shmwrite
+
+=item :still_to_be_decided
+
+    chdir
+    flock ioctl
+
+    socket getpeername ssockopt
+    bind connect listen accept shutdown gsockopt getsockname
+
+    sleep alarm -- changes global timer state and signal handling
+    sort -- assorted problems including core dumps
+    tied -- can be used to access object implementing a tie
+    pack unpack -- can be used to create/use memory pointers
+
+    entereval -- can be used to hide code from initial compile
+    require dofile 
+
+    caller -- get info about calling environment and args
+
+    reset
+
+    dbstate -- perl -d version of nextstate(ment) opcode
+
+=item :dangerous
+
+This tag is simply a bucket for opcodes that are unlikely to be used via
+a tag name but need to be tagged for completness and documentation.
+
+    syscall dump chroot
+
+
+=back
+
+=head1 SEE ALSO
+
+ops(3) -- perl pragma interface to Opcode module.
+
+Safe(3) -- Opcode and namespace limited execution compartments
+
+=head1 AUTHORS
+
+Originally designed and implemented by Malcolm Beattie,
+mbeattie@sable.ox.ac.uk as part of Safe version 1.
+
+Split out from Safe module version 1, named opcode tags and other
+changes added by Tim Bunce E<lt>F<Tim.Bunce@ig.co.uk>E<gt>.
+
+=cut
+
diff --git a/gnu/usr.bin/perl/ext/Opcode/Opcode.xs b/gnu/usr.bin/perl/ext/Opcode/Opcode.xs
new file mode 100644
index 00000000000..9d4b726536a
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Opcode/Opcode.xs
@@ -0,0 +1,472 @@
+#include "EXTERN.h"
+#include "perl.h"
+#include "XSUB.h"
+
+/* maxo shouldn't differ from MAXO but leave room anyway (see BOOT:)	*/
+#define OP_MASK_BUF_SIZE (MAXO + 100)
+
+static HV *op_named_bits;	/* cache shared for whole process	*/
+static SV *opset_all;		/* mask with all bits set		*/
+static IV  opset_len;		/* length of opmasks in bytes		*/
+static int opcode_debug = 0;
+
+static SV  *new_opset _((SV *old_opset));
+static int  verify_opset _((SV *opset, int fatal));
+static void set_opset_bits _((char *bitmap, SV *bitspec, int on, char *opname));
+static void put_op_bitspec _((char *optag,  STRLEN len, SV *opset));
+static SV  *get_op_bitspec _((char *opname, STRLEN len, int fatal));
+
+
+/* Initialise our private op_named_bits HV.
+ * It is first loaded with the name and number of each perl operator.
+ * Then the builtin tags :none and :all are added.
+ * Opcode.pm loads the standard optags from __DATA__
+ */
+
+static void
+op_names_init()
+{
+    int i;
+    STRLEN len;
+    char *opname;
+    char *bitmap;
+
+    op_named_bits = newHV();
+    for(i=0; i < maxo; ++i) {
+	hv_store(op_named_bits, op_name[i],strlen(op_name[i]),
+		Sv=newSViv(i), 0);
+	SvREADONLY_on(Sv);
+    }
+
+    put_op_bitspec(":none",0, sv_2mortal(new_opset(Nullsv)));
+
+    opset_all = new_opset(Nullsv);
+    bitmap = SvPV(opset_all, len);
+    i = len-1; /* deal with last byte specially, see below */
+    while(i-- > 0)
+	bitmap[i] = 0xFF;
+    /* Take care to set the right number of bits in the last byte */
+    bitmap[len-1] = (maxo & 0x07) ? ~(0xFF << (maxo & 0x07)) : 0xFF;
+    put_op_bitspec(":all",0, opset_all); /* don't mortalise */
+}
+
+
+/* Store a new tag definition. Always a mask.
+ * The tag must not already be defined.
+ * SV *mask is copied not referenced.
+ */
+
+static void
+put_op_bitspec(optag, len, mask)
+    char *optag;
+    STRLEN len;
+    SV *mask;
+{
+    SV **svp;
+    verify_opset(mask,1);
+    if (!len)
+	len = strlen(optag);
+    svp = hv_fetch(op_named_bits, optag, len, 1);
+    if (SvOK(*svp))
+	croak("Opcode tag \"%s\" already defined", optag);
+    sv_setsv(*svp, mask);
+    SvREADONLY_on(*svp);
+}
+
+
+
+/* Fetch a 'bits' entry for an opname or optag (IV/PV).
+ * Note that we return the actual entry for speed.
+ * Always sv_mortalcopy() if returing it to user code.
+ */
+
+static SV *
+get_op_bitspec(opname, len, fatal)
+    char *opname;
+    STRLEN len;
+    int fatal;
+{
+    SV **svp;
+    if (!len)
+	len = strlen(opname);
+    svp = hv_fetch(op_named_bits, opname, len, 0);
+    if (!svp || !SvOK(*svp)) {
+	if (!fatal)
+	    return Nullsv;
+	if (*opname == ':')
+	    croak("Unknown operator tag \"%s\"", opname);
+	if (*opname == '!')	/* XXX here later, or elsewhere? */
+	    croak("Can't negate operators here (\"%s\")", opname);
+	if (isALPHA(*opname))
+	    croak("Unknown operator name \"%s\"", opname);
+	croak("Unknown operator prefix \"%s\"", opname);
+    }
+    return *svp;
+}
+
+
+
+static SV *
+new_opset(old_opset)
+    SV *old_opset;
+{
+    SV *opset;
+    if (old_opset) {
+	verify_opset(old_opset,1);
+	opset = newSVsv(old_opset);
+    }
+    else {
+	opset = newSV(opset_len);
+	Zero(SvPVX(opset), opset_len + 1, char);
+	SvCUR_set(opset, opset_len);
+	(void)SvPOK_only(opset);
+    }
+    /* not mortalised here */
+    return opset;
+}
+
+
+static int
+verify_opset(opset, fatal)
+    SV *opset;
+    int fatal;
+{
+    char *err = Nullch;
+    if      (!SvOK(opset))              err = "undefined";
+    else if (!SvPOK(opset))             err = "wrong type";
+    else if (SvCUR(opset) != opset_len) err = "wrong size";
+    if (err && fatal) {
+	croak("Invalid opset: %s", err);
+    }
+    return !err;
+}
+
+
+static void
+set_opset_bits(bitmap, bitspec, on, opname)
+    char *bitmap;
+    SV *bitspec;
+    int on;
+    char *opname;
+{
+    if (SvIOK(bitspec)) {
+	int myopcode = SvIV(bitspec);
+	int offset = myopcode >> 3;
+	int bit    = myopcode & 0x07;
+	if (myopcode >= maxo || myopcode < 0)
+	    croak("panic: opcode \"%s\" value %d is invalid", opname, myopcode);
+	if (opcode_debug >= 2)
+	    warn("set_opset_bits bit %2d (off=%d, bit=%d) %s %s\n",
+			myopcode, offset, bit, opname, (on)?"on":"off");
+	if (on)
+	    bitmap[offset] |= 1 << bit;
+	else
+	    bitmap[offset] &= ~(1 << bit);
+    }
+    else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
+
+	STRLEN len;
+	char *specbits = SvPV(bitspec, len);
+	if (opcode_debug >= 2)
+	    warn("set_opset_bits opset %s %s\n", opname, (on)?"on":"off");
+	if (on) 
+	    while(len-- > 0) bitmap[len] |=  specbits[len];
+	else
+	    while(len-- > 0) bitmap[len] &= ~specbits[len];
+    }
+    else
+	croak("panic: invalid bitspec for \"%s\" (type %u)",
+		opname, (unsigned)SvTYPE(bitspec));
+}
+
+
+static void
+opmask_add(opset)	/* THE ONLY FUNCTION TO EDIT op_mask ITSELF	*/
+    SV *opset;
+{
+    int i,j;
+    char *bitmask;
+    STRLEN len;
+    int myopcode = 0;
+
+    verify_opset(opset,1);			/* croaks on bad opset	*/
+
+    if (!op_mask)		/* caller must ensure op_mask exists	*/
+	croak("Can't add to uninitialised op_mask");
+
+    /* OPCODES ALREADY MASKED ARE NEVER UNMASKED. See opmask_addlocal()	*/
+
+    bitmask = SvPV(opset, len);
+    for (i=0; i < opset_len; i++) {
+	U16 bits = bitmask[i];
+	if (!bits) {	/* optimise for sparse masks */
+	    myopcode += 8;
+	    continue;
+	}
+	for (j=0; j < 8 && myopcode < maxo; )
+	    op_mask[myopcode++] |= bits & (1 << j++);
+    }
+}
+
+static void
+opmask_addlocal(opset, op_mask_buf) /* Localise op_mask then opmask_add() */
+    SV *opset;
+    char *op_mask_buf;
+{
+    char *orig_op_mask = op_mask;
+    SAVEPPTR(op_mask);
+    if (opcode_debug >= 2)
+	SAVEDESTRUCTOR((void(*)_((void*)))warn,"op_mask restored");
+    op_mask = &op_mask_buf[0];
+    if (orig_op_mask)
+	Copy(orig_op_mask, op_mask, maxo, char);
+    else
+	Zero(op_mask, maxo, char);
+    opmask_add(opset);
+}
+
+
+
+MODULE = Opcode	PACKAGE = Opcode
+
+PROTOTYPES: ENABLE
+
+BOOT:
+    assert(maxo < OP_MASK_BUF_SIZE);
+    opset_len = (maxo + 7) / 8;
+    if (opcode_debug >= 1)
+	warn("opset_len %ld\n", (long)opset_len);
+    op_names_init();
+
+
+void
+_safe_call_sv(package, mask, codesv)
+    char *	package
+    SV *	mask
+    SV *	codesv
+    PPCODE:
+    char op_mask_buf[OP_MASK_BUF_SIZE];
+    GV *gv;
+
+    ENTER;
+
+    opmask_addlocal(mask, op_mask_buf);
+
+    save_aptr(&endav);
+    endav = (AV*)sv_2mortal((SV*)newAV()); /* ignore END blocks for now	*/
+
+    save_hptr(&defstash);		/* save current default stack	*/
+    /* the assignment to global defstash changes our sense of 'main'	*/
+    defstash = gv_stashpv(package, GV_ADDWARN); /* should exist already	*/
+
+    /* defstash must itself contain a main:: so we'll add that now	*/
+    /* take care with the ref counts (was cause of long standing bug)	*/
+    /* XXX I'm still not sure if this is right, GV_ADDWARN should warn!	*/
+    gv = gv_fetchpv("main::", GV_ADDWARN, SVt_PVHV);
+    sv_free((SV*)GvHV(gv));
+    GvHV(gv) = (HV*)SvREFCNT_inc(defstash);
+
+    PUSHMARK(sp);
+    perl_call_sv(codesv, GIMME|G_EVAL|G_KEEPERR); /* use callers context */
+    SPAGAIN; /* for the PUTBACK added by xsubpp */
+    LEAVE;
+
+
+int
+verify_opset(opset, fatal = 0)
+    SV *opset
+    int fatal
+
+
+void
+invert_opset(opset)
+    SV *opset
+    CODE:
+    {
+    char *bitmap;
+    STRLEN len = opset_len;
+    opset = new_opset(opset);	/* verify and clone opset */
+    bitmap = SvPVX(opset);
+    while(len-- > 0)
+	bitmap[len] = ~bitmap[len];
+    /* take care of extra bits beyond maxo in last byte	*/
+    if (maxo & 07)
+	bitmap[opset_len-1] &= ~(0xFF << (maxo & 0x07));
+    }
+    ST(0) = opset;
+
+
+void
+opset_to_ops(opset, desc = 0)
+    SV *opset
+    int	desc
+    PPCODE:
+    {
+    STRLEN len;
+    int i, j, myopcode;
+    char *bitmap = SvPV(opset, len);
+    char **names = (desc) ? op_desc : op_name;
+    verify_opset(opset,1);
+    for (myopcode=0, i=0; i < opset_len; i++) {
+	U16 bits = bitmap[i];
+	for (j=0; j < 8 && myopcode < maxo; j++, myopcode++) {
+	    if ( bits & (1 << j) )
+		XPUSHs(sv_2mortal(newSVpv(names[myopcode], 0)));
+	}
+    }
+    }
+
+
+void
+opset(...)
+    CODE:
+    int i, j;
+    SV *bitspec, *opset;
+    char *bitmap;
+    STRLEN len, on;
+    opset = new_opset(Nullsv);
+    bitmap = SvPVX(opset);
+    for (i = 0; i < items; i++) {
+	char *opname;
+	on = 1;
+	if (verify_opset(ST(i),0)) {
+	    opname = "(opset)";
+	    bitspec = ST(i);
+	}
+	else {
+	    opname = SvPV(ST(i), len);
+	    if (*opname == '!') { on=0; ++opname;--len; }
+	    bitspec = get_op_bitspec(opname, len, 1);
+	}
+	set_opset_bits(bitmap, bitspec, on, opname);
+    }
+    ST(0) = opset;
+
+
+#define PERMITING  (ix == 0 || ix == 1)
+#define ONLY_THESE (ix == 0 || ix == 2)
+
+void
+permit_only(safe, ...)
+    SV *safe
+    ALIAS:
+	permit    = 1
+	deny_only = 2
+	deny      = 3
+    CODE:
+    int i, on;
+    SV *bitspec, *mask;
+    char *bitmap, *opname;
+    STRLEN len;
+
+    if (!SvROK(safe) || !SvOBJECT(SvRV(safe)) || SvTYPE(SvRV(safe))!=SVt_PVHV)
+	croak("Not a Safe object");
+    mask = *hv_fetch((HV*)SvRV(safe), "Mask",4, 1);
+    if (ONLY_THESE)	/* *_only = new mask, else edit current	*/
+	 sv_setsv(mask, new_opset(PERMITING ? opset_all : Nullsv));
+    else verify_opset(mask,1); /* croaks */
+    bitmap = SvPVX(mask);
+    for (i = 1; i < items; i++) {
+	on = PERMITING ? 0 : 1;		/* deny = mask bit on	*/
+	if (verify_opset(ST(i),0)) {	/* it's a valid mask	*/
+	    opname = "(opset)";
+	    bitspec = ST(i);
+	}
+	else {				/* it's an opname/optag	*/
+	    opname = SvPV(ST(i), len);
+	    /* invert if op has ! prefix (only one allowed)	*/
+	    if (*opname == '!') { on = !on; ++opname; --len; }
+	    bitspec = get_op_bitspec(opname, len, 1); /* croaks */
+	}
+	set_opset_bits(bitmap, bitspec, on, opname);
+    }
+    ST(0) = &sv_yes;
+
+
+
+void
+opdesc(...)
+    PPCODE:
+    int i, myopcode;
+    STRLEN len;
+    SV **args;
+    /* copy args to a scratch area since we may push output values onto	*/
+    /* the stack faster than we read values off it if masks are used.	*/
+    args = (SV**)SvPVX(sv_2mortal(newSVpv((char*)&ST(0), items*sizeof(SV*))));
+    for (i = 0; i < items; i++) {
+	char *opname = SvPV(args[i], len);
+	SV *bitspec = get_op_bitspec(opname, len, 1);
+	if (SvIOK(bitspec)) {
+	    myopcode = SvIV(bitspec);
+	    if (myopcode < 0 || myopcode >= maxo)
+		croak("panic: opcode %d (%s) out of range",myopcode,opname);
+	    XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0)));
+	}
+	else if (SvPOK(bitspec) && SvCUR(bitspec) == opset_len) {
+	    int b, j;
+	    char *bitmap = SvPV(bitspec,na);
+	    myopcode = 0;
+	    for (b=0; b < opset_len; b++) {
+		U16 bits = bitmap[b];
+		for (j=0; j < 8 && myopcode < maxo; j++, myopcode++)
+		    if (bits & (1 << j))
+			XPUSHs(sv_2mortal(newSVpv(op_desc[myopcode], 0)));
+	    }
+	}
+	else
+	    croak("panic: invalid bitspec for \"%s\" (type %u)",
+		opname, (unsigned)SvTYPE(bitspec));
+    }
+
+
+void
+define_optag(optagsv, mask)
+    SV *optagsv
+    SV *mask
+    CODE:
+    STRLEN len;
+    char *optag = SvPV(optagsv, len);
+    put_op_bitspec(optag, len, mask); /* croaks */
+    ST(0) = &sv_yes;
+
+
+void
+empty_opset()
+    CODE:
+    ST(0) = sv_2mortal(new_opset(Nullsv));
+
+void
+full_opset()
+    CODE:
+    ST(0) = sv_2mortal(new_opset(opset_all));
+
+void
+opmask_add(opset)
+    SV *opset
+    PREINIT:
+    if (!op_mask)
+	Newz(0, op_mask, maxo, char);
+
+void
+opcodes()
+    PPCODE:
+    if (GIMME == G_ARRAY) {
+	croak("opcodes in list context not yet implemented"); /* XXX */
+    }
+    else {
+	XPUSHs(sv_2mortal(newSViv(maxo)));
+    }
+
+void
+opmask()
+    CODE:
+    ST(0) = sv_2mortal(new_opset(Nullsv));
+    if (op_mask) {
+	char *bitmap = SvPVX(ST(0));
+	int myopcode;
+	for(myopcode=0; myopcode < maxo; ++myopcode) {
+	    if (op_mask[myopcode])
+		bitmap[myopcode >> 3] |= 1 << (myopcode & 0x07);
+	}
+    }
+
diff --git a/gnu/usr.bin/perl/ext/Opcode/Safe.pm b/gnu/usr.bin/perl/ext/Opcode/Safe.pm
new file mode 100644
index 00000000000..c9d741647ec
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Opcode/Safe.pm
@@ -0,0 +1,555 @@
+package Safe;
+
+use 5.003_11;
+use strict;
+use vars qw($VERSION);
+
+$VERSION = "2.06";
+
+use Carp;
+
+use Opcode 1.01, qw(
+    opset opset_to_ops opmask_add
+    empty_opset full_opset invert_opset verify_opset
+    opdesc opcodes opmask define_optag opset_to_hex
+);
+
+*ops_to_opset = \&opset;   # Temporary alias for old Penguins
+
+
+my $default_root  = 0;
+my $default_share = ['*_']; #, '*main::'];
+
+sub new {
+    my($class, $root, $mask) = @_;
+    my $obj = {};
+    bless $obj, $class;
+
+    if (defined($root)) {
+	croak "Can't use \"$root\" as root name"
+	    if $root =~ /^main\b/ or $root !~ /^\w[:\w]*$/;
+	$obj->{Root}  = $root;
+	$obj->{Erase} = 0;
+    }
+    else {
+	$obj->{Root}  = "Safe::Root".$default_root++;
+	$obj->{Erase} = 1;
+    }
+
+    # use permit/deny methods instead till interface issues resolved
+    # XXX perhaps new Safe 'Root', mask => $mask, foo => bar, ...;
+    croak "Mask parameter to new no longer supported" if defined $mask;
+    $obj->permit_only(':default');
+
+    # We must share $_ and @_ with the compartment or else ops such
+    # as split, length and so on won't default to $_ properly, nor
+    # will passing argument to subroutines work (via @_). In fact,
+    # for reasons I don't completely understand, we need to share
+    # the whole glob *_ rather than $_ and @_ separately, otherwise
+    # @_ in non default packages within the compartment don't work.
+    $obj->share_from('main', $default_share);
+    return $obj;
+}
+
+sub DESTROY {
+    my $obj = shift;
+    $obj->erase if $obj->{Erase};
+}
+
+sub erase {
+    my $obj= shift;
+    my $pkg = $obj->root();
+    my ($stem, $leaf);
+
+    no strict 'refs';
+    $pkg = "main::$pkg\::";	# expand to full symbol table name
+    ($stem, $leaf) = $pkg =~ m/(.*::)(\w+::)$/;
+
+    # The 'my $foo' is needed! Without it you get an
+    # 'Attempt to free unreferenced scalar' warning!
+    my $stem_symtab = *{$stem}{HASH};
+
+    #warn "erase($pkg) stem=$stem, leaf=$leaf";
+    #warn " stem_symtab hash ".scalar(%$stem_symtab)."\n";
+	# ", join(', ', %$stem_symtab),"\n";
+
+    delete $stem_symtab->{$leaf};
+
+#    my $leaf_glob   = $stem_symtab->{$leaf};
+#    my $leaf_symtab = *{$leaf_glob}{HASH};
+#    warn " leaf_symtab ", join(', ', %$leaf_symtab),"\n";
+#    %$leaf_symtab = ();
+    #delete $leaf_symtab->{'__ANON__'};
+    #delete $leaf_symtab->{'foo'};
+    #delete $leaf_symtab->{'main::'};
+#    my $foo = undef ${"$stem\::"}{"$leaf\::"};
+
+    $obj->share_from('main', $default_share);
+    1;
+}
+
+
+sub reinit {
+    my $obj= shift;
+    $obj->erase;
+    $obj->share_redo;
+}
+
+sub root {
+    my $obj = shift;
+    croak("Safe root method now read-only") if @_;
+    return $obj->{Root};
+}
+
+
+sub mask {
+    my $obj = shift;
+    return $obj->{Mask} unless @_;
+    $obj->deny_only(@_);
+}
+
+# v1 compatibility methods
+sub trap   { shift->deny(@_)   }
+sub untrap { shift->permit(@_) }
+
+sub deny {
+    my $obj = shift;
+    $obj->{Mask} |= opset(@_);
+}
+sub deny_only {
+    my $obj = shift;
+    $obj->{Mask} = opset(@_);
+}
+
+sub permit {
+    my $obj = shift;
+    # XXX needs testing
+    $obj->{Mask} &= invert_opset opset(@_);
+}
+sub permit_only {
+    my $obj = shift;
+    $obj->{Mask} = invert_opset opset(@_);
+}
+
+
+sub dump_mask {
+    my $obj = shift;
+    print opset_to_hex($obj->{Mask}),"\n";
+}
+
+
+
+sub share {
+    my($obj, @vars) = @_;
+    $obj->share_from(scalar(caller), \@vars);
+}
+
+sub share_from {
+    my $obj = shift;
+    my $pkg = shift;
+    my $vars = shift;
+    my $no_record = shift || 0;
+    my $root = $obj->root();
+    croak("vars not an array ref") unless ref $vars eq 'ARRAY';
+	no strict 'refs';
+    # Check that 'from' package actually exists
+    croak("Package \"$pkg\" does not exist")
+	unless keys %{"$pkg\::"};
+    my $arg;
+    foreach $arg (@$vars) {
+	# catch some $safe->share($var) errors:
+	croak("'$arg' not a valid symbol table name")
+	    unless $arg =~ /^[\$\@%*&]?\w[\w:]*$/
+	    	or $arg =~ /^\$\W$/;
+	my ($var, $type);
+	$type = $1 if ($var = $arg) =~ s/^(\W)//;
+	# warn "share_from $pkg $type $var";
+	*{$root."::$var"} = (!$type)       ? \&{$pkg."::$var"}
+			  : ($type eq '&') ? \&{$pkg."::$var"}
+			  : ($type eq '$') ? \${$pkg."::$var"}
+			  : ($type eq '@') ? \@{$pkg."::$var"}
+			  : ($type eq '%') ? \%{$pkg."::$var"}
+			  : ($type eq '*') ?  *{$pkg."::$var"}
+			  : croak(qq(Can't share "$type$var" of unknown type));
+    }
+    $obj->share_record($pkg, $vars) unless $no_record or !$vars;
+}
+
+sub share_record {
+    my $obj = shift;
+    my $pkg = shift;
+    my $vars = shift;
+    my $shares = \%{$obj->{Shares} ||= {}};
+    # Record shares using keys of $obj->{Shares}. See reinit.
+    @{$shares}{@$vars} = ($pkg) x @$vars if @$vars;
+}
+sub share_redo {
+    my $obj = shift;
+    my $shares = \%{$obj->{Shares} ||= {}};
+	my($var, $pkg);
+    while(($var, $pkg) = each %$shares) {
+	# warn "share_redo $pkg\:: $var";
+	$obj->share_from($pkg,  [ $var ], 1);
+    }
+}
+sub share_forget {
+    delete shift->{Shares};
+}
+
+sub varglob {
+    my ($obj, $var) = @_;
+    no strict 'refs';
+    return *{$obj->root()."::$var"};
+}
+
+
+sub reval {
+    my ($obj, $expr, $strict) = @_;
+    my $root = $obj->{Root};
+
+    # Create anon sub ref in root of compartment.
+    # Uses a closure (on $expr) to pass in the code to be executed.
+    # (eval on one line to keep line numbers as expected by caller)
+	my $evalcode = sprintf('package %s; sub { eval $expr; }', $root);
+    my $evalsub;
+
+	if ($strict) { use strict; $evalsub = eval $evalcode; }
+	else         {  no strict; $evalsub = eval $evalcode; }
+
+    return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+}
+
+sub rdo {
+    my ($obj, $file) = @_;
+    my $root = $obj->{Root};
+
+    my $evalsub = eval
+	    sprintf('package %s; sub { do $file }', $root);
+    return Opcode::_safe_call_sv($root, $obj->{Mask}, $evalsub);
+}
+
+
+1;
+
+__DATA__
+
+=head1 NAME
+
+Safe - Compile and execute code in restricted compartments
+
+=head1 SYNOPSIS
+
+  use Safe;
+
+  $compartment = new Safe;
+
+  $compartment->permit(qw(time sort :browse));
+
+  $result = $compartment->reval($unsafe_code);
+
+=head1 DESCRIPTION
+
+The Safe extension module allows the creation of compartments
+in which perl code can be evaluated. Each compartment has
+
+=over 8
+
+=item a new namespace
+
+The "root" of the namespace (i.e. "main::") is changed to a
+different package and code evaluated in the compartment cannot
+refer to variables outside this namespace, even with run-time
+glob lookups and other tricks.
+
+Code which is compiled outside the compartment can choose to place
+variables into (or I<share> variables with) the compartment's namespace
+and only that data will be visible to code evaluated in the
+compartment.
+
+By default, the only variables shared with compartments are the
+"underscore" variables $_ and @_ (and, technically, the less frequently
+used %_, the _ filehandle and so on). This is because otherwise perl
+operators which default to $_ will not work and neither will the
+assignment of arguments to @_ on subroutine entry.
+
+=item an operator mask
+
+Each compartment has an associated "operator mask". Recall that
+perl code is compiled into an internal format before execution.
+Evaluating perl code (e.g. via "eval" or "do 'file'") causes
+the code to be compiled into an internal format and then,
+provided there was no error in the compilation, executed.
+Code evaulated in a compartment compiles subject to the
+compartment's operator mask. Attempting to evaulate code in a
+compartment which contains a masked operator will cause the
+compilation to fail with an error. The code will not be executed.
+
+The default operator mask for a newly created compartment is
+the ':default' optag.
+
+It is important that you read the Opcode(3) module documentation
+for more information, especially for detailed definitions of opnames,
+optags and opsets.
+
+Since it is only at the compilation stage that the operator mask
+applies, controlled access to potentially unsafe operations can
+be achieved by having a handle to a wrapper subroutine (written
+outside the compartment) placed into the compartment. For example,
+
+    $cpt = new Safe;
+    sub wrapper {
+        # vet arguments and perform potentially unsafe operations
+    }
+    $cpt->share('&wrapper');
+
+=back
+
+
+=head1 WARNING
+
+The authors make B<no warranty>, implied or otherwise, about the
+suitability of this software for safety or security purposes.
+
+The authors shall not in any case be liable for special, incidental,
+consequential, indirect or other similar damages arising from the use
+of this software.
+
+Your mileage will vary. If in any doubt B<do not use it>.
+
+
+=head2 RECENT CHANGES
+
+The interface to the Safe module has changed quite dramatically since
+version 1 (as supplied with Perl5.002). Study these pages carefully if
+you have code written to use Safe version 1 because you will need to
+makes changes.
+
+
+=head2 Methods in class Safe
+
+To create a new compartment, use
+
+    $cpt = new Safe;
+
+Optional argument is (NAMESPACE), where NAMESPACE is the root namespace
+to use for the compartment (defaults to "Safe::Root0", incremented for
+each new compartment).
+
+Note that version 1.00 of the Safe module supported a second optional
+parameter, MASK.  That functionality has been withdrawn pending deeper
+consideration. Use the permit and deny methods described below.
+
+The following methods can then be used on the compartment
+object returned by the above constructor. The object argument
+is implicit in each case.
+
+
+=over 8
+
+=item permit (OP, ...)
+
+Permit the listed operators to be used when compiling code in the
+compartment (in I<addition> to any operators already permitted).
+
+=item permit_only (OP, ...)
+
+Permit I<only> the listed operators to be used when compiling code in
+the compartment (I<no> other operators are permitted).
+
+=item deny (OP, ...)
+
+Deny the listed operators from being used when compiling code in the
+compartment (other operators may still be permitted).
+
+=item deny_only (OP, ...)
+
+Deny I<only> the listed operators from being used when compiling code
+in the compartment (I<all> other operators will be permitted).
+
+=item trap (OP, ...)
+
+=item untrap (OP, ...)
+
+The trap and untrap methods are synonyms for deny and permit
+respectfully.
+
+=item share (NAME, ...)
+
+This shares the variable(s) in the argument list with the compartment.
+This is almost identical to exporting variables using the L<Exporter(3)>
+module.
+
+Each NAME must be the B<name> of a variable, typically with the leading
+type identifier included. A bareword is treated as a function name.
+
+Examples of legal names are '$foo' for a scalar, '@foo' for an
+array, '%foo' for a hash, '&foo' or 'foo' for a subroutine and '*foo'
+for a glob (i.e.  all symbol table entries associated with "foo",
+including scalar, array, hash, sub and filehandle).
+
+Each NAME is assumed to be in the calling package. See share_from
+for an alternative method (which share uses).
+
+=item share_from (PACKAGE, ARRAYREF)
+
+This method is similar to share() but allows you to explicitly name the
+package that symbols should be shared from. The symbol names (including
+type characters) are supplied as an array reference.
+
+    $safe->share_from('main', [ '$foo', '%bar', 'func' ]);
+
+
+=item varglob (VARNAME)
+
+This returns a glob reference for the symbol table entry of VARNAME in
+the package of the compartment. VARNAME must be the B<name> of a
+variable without any leading type marker. For example,
+
+    $cpt = new Safe 'Root';
+    $Root::foo = "Hello world";
+    # Equivalent version which doesn't need to know $cpt's package name:
+    ${$cpt->varglob('foo')} = "Hello world";
+
+
+=item reval (STRING)
+
+This evaluates STRING as perl code inside the compartment.
+
+The code can only see the compartment's namespace (as returned by the
+B<root> method). The compartment's root package appears to be the
+C<main::> package to the code inside the compartment.
+
+Any attempt by the code in STRING to use an operator which is not permitted
+by the compartment will cause an error (at run-time of the main program
+but at compile-time for the code in STRING).  The error is of the form
+"%s trapped by operation mask operation...".
+
+If an operation is trapped in this way, then the code in STRING will
+not be executed. If such a trapped operation occurs or any other
+compile-time or return error, then $@ is set to the error message, just
+as with an eval().
+
+If there is no error, then the method returns the value of the last
+expression evaluated, or a return statement may be used, just as with
+subroutines and B<eval()>. The context (list or scalar) is determined
+by the caller as usual.
+
+This behaviour differs from the beta distribution of the Safe extension
+where earlier versions of perl made it hard to mimic the return
+behaviour of the eval() command and the context was always scalar.
+
+Some points to note:
+
+If the entereval op is permitted then the code can use eval "..." to
+'hide' code which might use denied ops. This is not a major problem
+since when the code tries to execute the eval it will fail because the
+opmask is still in effect. However this technique would allow clever,
+and possibly harmful, code to 'probe' the boundaries of what is
+possible.
+
+Any string eval which is executed by code executing in a compartment,
+or by code called from code executing in a compartment, will be eval'd
+in the namespace of the compartment. This is potentially a serious
+problem.
+
+Consider a function foo() in package pkg compiled outside a compartment
+but shared with it. Assume the compartment has a root package called
+'Root'. If foo() contains an eval statement like eval '$foo = 1' then,
+normally, $pkg::foo will be set to 1.  If foo() is called from the
+compartment (by whatever means) then instead of setting $pkg::foo, the
+eval will actually set $Root::pkg::foo.
+
+This can easily be demonstrated by using a module, such as the Socket
+module, which uses eval "..." as part of an AUTOLOAD function. You can
+'use' the module outside the compartment and share an (autoloaded)
+function with the compartment. If an autoload is triggered by code in
+the compartment, or by any code anywhere that is called by any means
+from the compartment, then the eval in the Socket module's AUTOLOAD
+function happens in the namespace of the compartment. Any variables
+created or used by the eval'd code are now under the control of
+the code in the compartment.
+
+A similar effect applies to I<all> runtime symbol lookups in code
+called from a compartment but not compiled within it.
+
+
+
+=item rdo (FILENAME)
+
+This evaluates the contents of file FILENAME inside the compartment.
+See above documentation on the B<reval> method for further details.
+
+=item root (NAMESPACE)
+
+This method returns the name of the package that is the root of the
+compartment's namespace.
+
+Note that this behaviour differs from version 1.00 of the Safe module
+where the root module could be used to change the namespace. That
+functionality has been withdrawn pending deeper consideration.
+
+=item mask (MASK)
+
+This is a get-or-set method for the compartment's operator mask.
+
+With no MASK argument present, it returns the current operator mask of
+the compartment.
+
+With the MASK argument present, it sets the operator mask for the
+compartment (equivalent to calling the deny_only method).
+
+=back
+
+
+=head2 Some Safety Issues
+
+This section is currently just an outline of some of the things code in
+a compartment might do (intentionally or unintentionally) which can
+have an effect outside the compartment.
+
+=over 8
+
+=item Memory
+
+Consuming all (or nearly all) available memory.
+
+=item CPU
+
+Causing infinite loops etc.
+
+=item Snooping
+
+Copying private information out of your system. Even something as
+simple as your user name is of value to others. Much useful information
+could be gleaned from your environment variables for example.
+
+=item Signals
+
+Causing signals (especially SIGFPE and SIGALARM) to affect your process.
+
+Setting up a signal handler will need to be carefully considered
+and controlled.  What mask is in effect when a signal handler
+gets called?  If a user can get an imported function to get an
+exception and call the user's signal handler, does that user's
+restricted mask get re-instated before the handler is called?
+Does an imported handler get called with its original mask or
+the user's one?
+
+=item State Changes
+
+Ops such as chdir obviously effect the process as a whole and not just
+the code in the compartment. Ops such as rand and srand have a similar
+but more subtle effect.
+
+=back
+
+=head2 AUTHOR
+
+Originally designed and implemented by Malcolm Beattie,
+mbeattie@sable.ox.ac.uk.
+
+Reworked to use the Opcode module and other changes added by Tim Bunce
+E<lt>F<Tim.Bunce@ig.co.uk>E<gt>.
+
+=cut
+
diff --git a/gnu/usr.bin/perl/ext/Opcode/ops.pm b/gnu/usr.bin/perl/ext/Opcode/ops.pm
new file mode 100644
index 00000000000..b9ea36cef39
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Opcode/ops.pm
@@ -0,0 +1,45 @@
+package ops;
+
+use Opcode qw(opmask_add opset invert_opset);
+
+sub import {
+    shift;
+    # Not that unimport is the prefered form since import's don't
+	# accumulate well owing to the 'only ever add opmask' rule.
+	# E.g., perl -Mops=:set1 -Mops=:setb is unlikely to do as expected.
+    opmask_add(invert_opset opset(@_)) if @_;
+}
+
+sub unimport {
+    shift;
+    opmask_add(opset(@_)) if @_;
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+ops - Perl pragma to restrict unsafe operations when compiling
+
+=head1 SYNOPSIS  
+
+  perl -Mops=:default ...    # only allow reasonably safe operations
+
+  perl -M-ops=system ...     # disable the 'system' opcode
+
+=head1 DESCRIPTION
+
+Since the ops pragma currently has an irreversable global effect, it is
+only of significant practical use with the C<-M> option on the command line.
+
+See the L<Opcode> module for information about opcodes, optags, opmasks
+and important information about safety.
+
+=head1 SEE ALSO
+
+Opcode(3), Safe(3), perlrun(3)
+
+=cut
+
diff --git a/gnu/usr.bin/perl/ext/POSIX/hints/next_3.pl b/gnu/usr.bin/perl/ext/POSIX/hints/next_3.pl
new file mode 100644
index 00000000000..d90778398b2
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/POSIX/hints/next_3.pl
@@ -0,0 +1,5 @@
+# NeXT *does* have setpgid when we use the -posix flag, but
+# doesn't when we don't.  The main perl sources are compiled
+# without -posix, so the hints/next_3.sh hint file tells Configure
+# that  d_setpgid=undef.
+$self->{CCFLAGS} = $Config{ccflags} . ' -posix -DHAS_SETPGID' ;