virgin perl 5.6.0

2 files changed, 116 insertions, 21 deletions

diff --git a/gnu/usr.bin/perl/lib/Tie/Array.pm b/gnu/usr.bin/perl/lib/Tie/Array.pm
index 3f34c3b81ff..eb83aaee17a 100644
--- a/gnu/usr.bin/perl/lib/Tie/Array.pm
+++ b/gnu/usr.bin/perl/lib/Tie/Array.pm
@@ -1,7 +1,9 @@
 package Tie::Array;
-use vars qw($VERSION); 
+
+use 5.005_64;
 use strict;
-$VERSION = '1.00';
+use Carp;
+our $VERSION = '1.01';
 
 # Pod documentation after __END__ below.
 
@@ -74,6 +76,16 @@ sub SPLICE
  return @result;
 } 
 
+sub EXISTS {
+    my $pkg = ref $_[0];
+    croak "$pkg dosn't define an EXISTS method";
+}
+
+sub DELETE {
+    my $pkg = ref $_[0];
+    croak "$pkg dosn't define a DELETE method";
+}
+
 package Tie::StdArray;
 use vars qw(@ISA);
 @ISA = 'Tie::Array';
@@ -88,6 +100,8 @@ sub POP       { pop(@{$_[0]}) }
 sub PUSH      { my $o = shift; push(@$o,@_) }
 sub SHIFT     { shift(@{$_[0]}) } 
 sub UNSHIFT   { my $o = shift; unshift(@$o,@_) } 
+sub EXISTS    { exists $_[0]->[$_[1]] }
+sub DELETE    { delete $_[0]->[$_[1]] }
 
 sub SPLICE
 {
@@ -112,15 +126,17 @@ Tie::Array - base class for tied arrays
     package NewArray;
     use Tie::Array;
     @ISA = ('Tie::Array');
-                       
+
     # mandatory methods
     sub TIEARRAY { ... }  
     sub FETCH { ... }     
     sub FETCHSIZE { ... } 
-        
+
     sub STORE { ... }        # mandatory if elements writeable
     sub STORESIZE { ... }    # mandatory if elements can be added/deleted
-                               
+    sub EXISTS { ... }       # mandatory if exists() expected to work
+    sub DELETE { ... }       # mandatory if delete() expected to work
+
     # optional methods - for efficiency
     sub CLEAR { ... }  
     sub PUSH { ... } 
@@ -133,7 +149,7 @@ Tie::Array - base class for tied arrays
 
     package NewStdArray;
     use Tie::Array;
-    
+
     @ISA = ('Tie::StdArray');
 
     # all methods provided by default
@@ -150,9 +166,11 @@ Tie::Array - base class for tied arrays
 
 This module provides methods for array-tying classes. See
 L<perltie> for a list of the functions required in order to tie an array
-to a package. The basic B<Tie::Array> package provides stub C<DELETE> 
-and C<EXTEND> methods, and implementations of C<PUSH>, C<POP>, C<SHIFT>, 
-C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>, 
+to a package. The basic B<Tie::Array> package provides stub C<DESTROY>,
+and C<EXTEND> methods that do nothing, stub C<DELETE> and C<EXISTS>
+methods that croak() if the delete() or exists() builtins are ever called
+on the tied array, and implementations of C<PUSH>, C<POP>, C<SHIFT>,
+C<UNSHIFT>, C<SPLICE> and C<CLEAR> in terms of basic C<FETCH>, C<STORE>,
 C<FETCHSIZE>, C<STORESIZE>.
 
 The B<Tie::StdArray> package provides efficient methods required for tied arrays 
@@ -203,6 +221,18 @@ deleted.
 Informative call that array is likely to grow to have I<count> entries.
 Can be used to optimize allocation. This method need do nothing.
 
+=item EXISTS this, key
+
+Verify that the element at index I<key> exists in the tied array I<this>.
+
+The B<Tie::Array> implementation is a stub that simply croaks.
+
+=item DELETE this, key
+
+Delete the element at index I<key> from the tied array I<this>.
+
+The B<Tie::Array> implementation is a stub that simply croaks.
+
 =item CLEAR this
 
 Clear (remove, delete, ...) all values from the tied array associated with
diff --git a/gnu/usr.bin/perl/lib/Tie/Handle.pm b/gnu/usr.bin/perl/lib/Tie/Handle.pm
index c7550530b87..588ecead899 100644
--- a/gnu/usr.bin/perl/lib/Tie/Handle.pm
+++ b/gnu/usr.bin/perl/lib/Tie/Handle.pm
@@ -1,22 +1,25 @@
 package Tie::Handle;
 
+use 5.005_64;
+our $VERSION = '1.0';
+
 =head1 NAME
 
-Tie::Handle - base class definitions for tied handles
+Tie::Handle, Tie::StdHandle  - base class definitions for tied handles
 
 =head1 SYNOPSIS
 
     package NewHandle;
     require Tie::Handle;
-     
+
     @ISA = (Tie::Handle);
-     
+
     sub READ { ... }		# Provide a needed method
     sub TIEHANDLE { ... }	# Overrides inherited method
-         
-     
+
+
     package main;
-    
+
     tie *FH, 'NewHandle';
 
 =head1 DESCRIPTION
@@ -24,9 +27,7 @@ Tie::Handle - base class definitions for tied handles
 This module provides some skeletal methods for handle-tying classes. See
 L<perltie> for a list of the functions required in tying a handle to a package.
 The basic B<Tie::Handle> package provides a C<new> method, as well as methods
-C<TIESCALAR>, C<FETCH> and C<STORE>. The C<new> method is provided as a means
-of grandfathering, for classes that forget to provide their own C<TIESCALAR>
-method.
+C<TIEHANDLE>, C<PRINT>, C<PRINTF> and C<GETC>. 
 
 For developers wishing to write their own tied-handle classes, the methods
 are summarized below. The L<perltie> section not only documents these, but
@@ -65,6 +66,32 @@ Read a single line
 
 Get a single character
 
+=item CLOSE this
+
+Close the handle
+
+=item OPEN this, filename
+
+(Re-)open the handle
+
+=item BINMODE this
+
+Specify content is binary
+
+=item EOF this
+
+Test for end of file.
+
+=item TELL this
+
+Return position in the file.
+
+=item SEEK this, offset, whence
+
+Position the file.
+
+Test for end of file.
+
 =item DESTROY this
 
 Free the storage associated with the tied handle referenced by I<this>.
@@ -81,6 +108,7 @@ The L<perltie> section contains an example of tying handles.
 =cut
 
 use Carp;
+use warnings::register;
 
 sub new {
     my $pkg = shift;
@@ -92,8 +120,8 @@ sub new {
 sub TIEHANDLE {
     my $pkg = shift;
     if (defined &{"{$pkg}::new"}) {
-	carp "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing"
-	    if $^W;
+	warnings::warn "WARNING: calling ${pkg}->new since ${pkg}->TIEHANDLE is missing"
+	    if warnings::enabled();
 	$pkg->new(@_);
     }
     else {
@@ -117,7 +145,7 @@ sub PRINTF {
     my $self = shift;
     
     if($self->can('WRITE') != \&WRITE) {
-	my $buf = sprintf(@_);
+	my $buf = sprintf(shift,@_);
 	$self->WRITE($buf,length($buf),0);
     }
     else {
@@ -156,6 +184,43 @@ sub WRITE {
 sub CLOSE {
     my $pkg = ref $_[0];
     croak "$pkg doesn't define a CLOSE method";
+} 
+
+package Tie::StdHandle; 
+our @ISA = 'Tie::Handle';       
+use Carp;
+
+sub TIEHANDLE 
+{
+ my $class = shift;
+ my $fh    = do { \local *HANDLE};
+ bless $fh,$class;
+ $fh->OPEN(@_) if (@_);
+ return $fh;
+}         
+
+sub EOF     { eof($_[0]) }
+sub TELL    { tell($_[0]) }
+sub FILENO  { fileno($_[0]) }
+sub SEEK    { seek($_[0],$_[1],$_[2]) }
+sub CLOSE   { close($_[0]) }
+sub BINMODE { binmode($_[0]) }
+
+sub OPEN
+{         
+ $_[0]->CLOSE if defined($_[0]->FILENO);
+ open($_[0],$_[1]);
+}
+
+sub READ     { read($_[0],$_[1],$_[2]) }
+sub READLINE { my $fh = $_[0]; <$fh> }
+sub GETC     { getc($_[0]) }
+
+sub WRITE
+{        
+ my $fh = $_[0];
+ print $fh substr($_[1],0,$_[2])
 }
 
+
 1;