9 files changed, 690 insertions, 0 deletions

diff --git a/gnu/usr.bin/perl/ext/Storable/hints/gnukfreebsd.pl b/gnu/usr.bin/perl/ext/Storable/hints/gnukfreebsd.pl
new file mode 100644
index 00000000000..6e37b40270f
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Storable/hints/gnukfreebsd.pl
@@ -0,0 +1 @@
+do './hints/linux.pl';
diff --git a/gnu/usr.bin/perl/ext/Storable/hints/gnuknetbsd.pl b/gnu/usr.bin/perl/ext/Storable/hints/gnuknetbsd.pl
new file mode 100644
index 00000000000..6e37b40270f
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Storable/hints/gnuknetbsd.pl
@@ -0,0 +1 @@
+do './hints/linux.pl';
diff --git a/gnu/usr.bin/perl/ext/Storable/t/HAS_ATTACH.pm b/gnu/usr.bin/perl/ext/Storable/t/HAS_ATTACH.pm
new file mode 100644
index 00000000000..72855aa101a
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Storable/t/HAS_ATTACH.pm
@@ -0,0 +1,10 @@
+package HAS_ATTACH;
+
+sub STORABLE_attach {
+  ++$attached_count;
+  return bless [], 'HAS_ATTACH';
+}
+
+++$loaded_count;
+
+1;
diff --git a/gnu/usr.bin/perl/ext/Storable/t/attach_errors.t b/gnu/usr.bin/perl/ext/Storable/t/attach_errors.t
new file mode 100755
index 00000000000..85971db72e6
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Storable/t/attach_errors.t
@@ -0,0 +1,269 @@
+#!./perl -w
+#
+#  Copyright 2005, Adam Kennedy.
+#
+#  You may redistribute only under the same terms as Perl 5, as specified
+#  in the README file that comes with the distribution.
+#
+
+# Man, blessed.t scared the hell out of me. For a second there I thought
+# I'd lose Test::More...
+
+# This file tests several known-error cases relating to STORABLE_attach, in
+# which Storable should (correctly) throw errors.
+
+sub BEGIN {
+    if ($ENV{PERL_CORE}){
+	chdir('t') if -d 't';
+	@INC = ('.', '../lib');
+    } else {
+	unshift @INC, 't';
+    }
+    require Config; import Config;
+    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
+        print "1..0 # Skip: Storable was not built\n";
+        exit 0;
+    }
+}
+
+use Test::More tests => 35;
+use Storable ();
+
+
+
+
+
+#####################################################################
+# Error 1
+# 
+# Classes that implement STORABLE_thaw _cannot_ have references
+# returned by their STORABLE_freeze method. When they do, Storable
+# should throw an exception
+
+
+
+# Good Case - should not die
+{
+	my $goodfreeze = bless {}, 'My::GoodFreeze';
+	my $frozen = undef;
+	eval {
+		$frozen = Storable::freeze( $goodfreeze );
+	};
+	ok( ! $@, 'Storable does not die when STORABLE_freeze does not return references' );
+	ok( $frozen, 'Storable freezes to a string successfully' );
+
+	package My::GoodFreeze;
+
+	sub STORABLE_freeze {
+		my ($self, $clone) = @_;
+		
+		# Illegally include a reference in this return
+		return ('');
+	}
+
+	sub STORABLE_attach {
+		my ($class, $clone, $string) = @_;
+		return bless { }, 'My::GoodFreeze';
+	}
+}
+
+
+
+# Error Case - should die on freeze
+{
+	my $badfreeze = bless {}, 'My::BadFreeze';
+	eval {
+		Storable::freeze( $badfreeze );
+	};
+	ok( $@, 'Storable dies correctly when STORABLE_freeze returns a referece' );
+	# Check for a unique substring of the error message
+	ok( $@ =~ /cannot return references/, 'Storable dies with the expected error' );
+
+	package My::BadFreeze;
+
+	sub STORABLE_freeze {
+		my ($self, $clone) = @_;
+		
+		# Illegally include a reference in this return
+		return ('', []);
+	}
+
+	sub STORABLE_attach {
+		my ($class, $clone, $string) = @_;
+		return bless { }, 'My::BadFreeze';
+	}
+}
+
+
+
+
+
+#####################################################################
+# Error 2
+#
+# If, for some reason, a STORABLE_attach object is accidentally stored
+# with references, this should be checked and and error should be throw.
+
+
+
+# Good Case - should not die
+{
+	my $goodthaw = bless {}, 'My::GoodThaw';
+	my $frozen = undef;
+	eval {
+		$frozen = Storable::freeze( $goodthaw );
+	};
+	ok( $frozen, 'Storable freezes to a string as expected' );
+	my $thawed = eval {
+		Storable::thaw( $frozen );
+	};
+	isa_ok( $thawed, 'My::GoodThaw' );
+	is( $thawed->{foo}, 'bar', 'My::GoodThaw thawed correctly as expected' );
+
+	package My::GoodThaw;
+
+	sub STORABLE_freeze {
+		my ($self, $clone) = @_;
+
+		return ('');
+	}
+
+	sub STORABLE_attach {
+		my ($class, $clone, $string) = @_;
+		return bless { 'foo' => 'bar' }, 'My::GoodThaw';
+	}
+}
+
+
+
+# Bad Case - should die on thaw
+{
+	# Create the frozen string normally
+	my $badthaw = bless { }, 'My::BadThaw';
+	my $frozen = undef;
+	eval {
+		$frozen = Storable::freeze( $badthaw );
+	};
+	ok( $frozen, 'BadThaw was frozen with references correctly' );
+
+	# Set up the error condition by deleting the normal STORABLE_thaw,
+	# and creating a STORABLE_attach.
+	*My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw;
+	*My::BadThaw::STORABLE_attach = *My::BadThaw::STORABLE_thaw; # Suppress a warning
+	delete ${'My::BadThaw::'}{STORABLE_thaw};
+
+	# Trigger the error condition
+	my $thawed = undef;
+	eval {
+		$thawed = Storable::thaw( $frozen );
+	};
+	ok( $@, 'My::BadThaw object dies when thawing as expected' );
+	# Check for a snippet from the error message
+	ok( $@ =~ /unexpected references/, 'Dies with the expected error message' );
+
+	package My::BadThaw;
+
+	sub STORABLE_freeze {
+		my ($self, $clone) = @_;
+
+		return ('', []);
+	}
+
+	# Start with no STORABLE_attach method so we can get a
+	# frozen object-containing-a-reference into the freeze string.
+	sub STORABLE_thaw {
+		my ($class, $clone, $string) = @_;
+		return bless { 'foo' => 'bar' }, 'My::BadThaw';
+	}
+}
+
+
+
+
+#####################################################################
+# Error 3
+#
+# Die if what is returned by STORABLE_attach is not something of that class
+
+
+
+# Good Case - should not die
+{
+	my $goodattach = bless { }, 'My::GoodAttach';
+	my $frozen = Storable::freeze( $goodattach );
+	ok( $frozen, 'My::GoodAttach return as expected' );
+	my $thawed = eval {
+		Storable::thaw( $frozen );
+	};
+	isa_ok( $thawed, 'My::GoodAttach' );
+	is( ref($thawed), 'My::GoodAttach::Subclass',
+		'The slightly-tricky good "returns a subclass" case returns as expected' );
+
+	package My::GoodAttach;
+
+	sub STORABLE_freeze {
+		my ($self, $cloning) = @_;
+		return ('');
+	}
+
+	sub STORABLE_attach {
+		my ($class, $cloning, $string) = @_;
+
+		return bless { }, 'My::GoodAttach::Subclass';
+	}
+
+	package My::GoodAttach::Subclass;
+
+	BEGIN {
+		@ISA = 'My::GoodAttach';
+	}
+}
+
+
+
+# Bad Cases - die on thaw
+{
+	my $returnvalue = undef;
+
+	# Create and freeze the object
+	my $badattach = bless { }, 'My::BadAttach';
+	my $frozen = Storable::freeze( $badattach );
+	ok( $frozen, 'BadAttach freezes as expected' );
+
+	# Try a number of different return values, all of which
+	# should cause Storable to die.
+	my @badthings = (
+		undef,
+		'',
+		1,
+		[],
+		{},
+		\"foo",
+		(bless { }, 'Foo'),
+		);
+	foreach ( @badthings ) {
+		$returnvalue = $_;
+
+		my $thawed = undef;
+		eval {
+			$thawed = Storable::thaw( $frozen );
+		};
+		ok( $@, 'BadAttach dies on thaw' );
+		ok( $@ =~ /STORABLE_attach did not return a My::BadAttach object/,
+			'BadAttach dies on thaw with the expected error message' );
+		is( $thawed, undef, 'Double checking $thawed was not set' );
+	}
+	
+	package My::BadAttach;
+
+	sub STORABLE_freeze {
+		my ($self, $cloning) = @_;
+		return ('');
+	}
+
+	sub STORABLE_attach {
+		my ($class, $cloning, $string) = @_;
+
+		return $returnvalue;
+	}
+}
diff --git a/gnu/usr.bin/perl/ext/Storable/t/attach_singleton.t b/gnu/usr.bin/perl/ext/Storable/t/attach_singleton.t
new file mode 100755
index 00000000000..475204f0b57
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Storable/t/attach_singleton.t
@@ -0,0 +1,89 @@
+#!./perl -w
+#
+#  Copyright 2005, Adam Kennedy.
+#
+#  You may redistribute only under the same terms as Perl 5, as specified
+#  in the README file that comes with the distribution.
+#
+
+# Tests freezing/thawing structures containing Singleton objects,
+# which should see both structs pointing to the same object.
+
+sub BEGIN {
+    if ($ENV{PERL_CORE}){
+	chdir('t') if -d 't';
+	@INC = ('.', '../lib');
+    } else {
+	unshift @INC, 't';
+    }
+    require Config; import Config;
+    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
+        print "1..0 # Skip: Storable was not built\n";
+        exit 0;
+    }
+}
+
+use Test::More tests => 11;
+use Storable ();
+
+# Get the singleton
+my $object = My::Singleton->new;
+isa_ok( $object, 'My::Singleton' );
+
+# Confirm (for the record) that the class is actually a Singleton
+my $object2 = My::Singleton->new;
+isa_ok( $object2, 'My::Singleton' );
+is( "$object", "$object2", 'Class is a singleton' );
+
+############
+# Main Tests
+
+my $struct = [ 1, $object, 3 ];
+
+# Freeze the struct
+my $frozen = Storable::freeze( $struct );
+ok( (defined($frozen) and ! ref($frozen) and length($frozen)), 'freeze returns a string' );
+
+# Thaw the struct
+my $thawed = Storable::thaw( $frozen );
+
+# Now it should look exactly like the original
+is_deeply( $struct, $thawed, 'Struct superficially looks like the original' );
+
+# ... EXCEPT that the Singleton should be the same instance of the object
+is( "$struct->[1]", "$thawed->[1]", 'Singleton thaws correctly' );
+
+# We can also test this empirically
+$struct->[1]->{value} = 'Goodbye cruel world!';
+is_deeply( $struct, $thawed, 'Empiric testing corfirms correct behaviour' );
+
+# End Tests
+###########
+
+package My::Singleton;
+
+my $SINGLETON = undef;
+
+sub new {
+	$SINGLETON or
+	$SINGLETON = bless { value => 'Hello World!' }, $_[0];
+}
+
+sub STORABLE_freeze {
+	my $self = shift;
+
+	# We don't actually need to return anything, but provide a null string
+	# to avoid the null-list-return behaviour.
+	return ('foo');
+}
+
+sub STORABLE_attach {
+	my ($class, $clone, $string) = @_;
+	Test::More::ok( ! ref $class, 'STORABLE_attach passed class, and not an object' );
+	Test::More::is( $class, 'My::Singleton', 'STORABLE_attach is passed the correct class name' );
+	Test::More::is( $clone, 0, 'We are not in a dclone' );
+	Test::More::is( $string, 'foo', 'STORABLE_attach gets the string back' );
+
+	# Get the Singleton object and return it
+	return $class->new;
+}
diff --git a/gnu/usr.bin/perl/ext/Storable/t/circular_hook.t b/gnu/usr.bin/perl/ext/Storable/t/circular_hook.t
new file mode 100755
index 00000000000..782b3d345d0
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Storable/t/circular_hook.t
@@ -0,0 +1,91 @@
+#!./perl -w
+#
+#  Copyright 2005, Adam Kennedy.
+#
+#  You may redistribute only under the same terms as Perl 5, as specified
+#  in the README file that comes with the distribution.
+#
+
+# Man, blessed.t scared the hell out of me. For a second there I thought
+# I'd lose Test::More...
+
+# This file tests several known-error cases relating to STORABLE_attach, in
+# which Storable should (correctly) throw errors.
+
+sub BEGIN {
+    if ($ENV{PERL_CORE}){
+	chdir('t') if -d 't';
+	@INC = ('.', '../lib');
+    } else {
+	unshift @INC, 't';
+    }
+    require Config; import Config;
+    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
+        print "1..0 # Skip: Storable was not built\n";
+        exit 0;
+    }
+}
+
+use Storable ();
+use Test::More tests => 9;
+
+my $ddd = bless { }, 'Foo';
+my $eee = bless { Bar => $ddd }, 'Bar';
+$ddd->{Foo} = $eee;
+
+my $array = [ $ddd ];
+
+my $string = Storable::freeze( $array );
+my $thawed = Storable::thaw( $string );
+
+# is_deeply infinite loops in ciculars, so do it manually
+# is_deeply( $array, $thawed, 'Circular hooked objects work' );
+is( ref($thawed), 'ARRAY', 'Top level ARRAY' );
+is( scalar(@$thawed), 1, 'ARRAY contains one element' );
+isa_ok( $thawed->[0], 'Foo' );
+is( scalar(keys %{$thawed->[0]}), 1, 'Foo contains one element' );
+isa_ok( $thawed->[0]->{Foo}, 'Bar' );
+is( scalar(keys %{$thawed->[0]->{Foo}}), 1, 'Bar contains one element' );
+isa_ok( $thawed->[0]->{Foo}->{Bar}, 'Foo' );
+is( $thawed->[0], $thawed->[0]->{Foo}->{Bar}, 'Circular is... well... circular' );
+
+# Make sure the thawing went the way we expected
+is_deeply( \@Foo::order, [ 'Bar', 'Foo' ], 'thaw order is correct (depth first)' );
+
+
+
+
+
+package Foo;
+
+@order = ();
+
+sub STORABLE_freeze {
+	my ($self, $clone) = @_;
+	my $class = ref $self;
+	
+	# print "# Freezing $class\n";
+
+	return ($class, $self->{$class});
+}
+
+sub STORABLE_thaw {
+	my ($self, $clone, $string, @refs) = @_;
+	my $class = ref $self;
+
+	# print "# Thawing $class\n";
+
+	$self->{$class} = shift @refs;
+
+	push @order, $class;
+
+ 	return;
+}
+
+package Bar;
+
+BEGIN {
+@ISA = 'Foo';
+}
+
+1;
diff --git a/gnu/usr.bin/perl/ext/Storable/t/sig_die.t b/gnu/usr.bin/perl/ext/Storable/t/sig_die.t
new file mode 100755
index 00000000000..035075213fc
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Storable/t/sig_die.t
@@ -0,0 +1,44 @@
+#!./perl
+#
+#  Copyright (c) 2002 Slaven Rezic
+#
+#  You may redistribute only under the same terms as Perl 5, as specified
+#  in the README file that comes with the distribution.
+#
+
+sub BEGIN {
+    if ($ENV{PERL_CORE}){
+       chdir('t') if -d 't';
+       @INC = ('.', '../lib');
+    } else {
+       unshift @INC, 't';
+    }
+    require Config; import Config;
+    if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
+        print "1..0 # Skip: Storable was not built\n";
+        exit 0;
+    }
+}
+
+use strict;
+BEGIN {
+    if (!eval q{
+       use Test::More;
+       1;
+    }) {
+       print "1..0 # skip: tests only work with Test::More\n";
+       exit;
+    }
+}
+
+BEGIN { plan tests => 1 }
+
+my @warns;
+$SIG{__WARN__} = sub { push @warns, shift };
+$SIG{__DIE__}  = sub { require Carp; warn Carp::longmess(); warn "Evil die!" };
+
+require Storable;
+
+Storable::dclone({foo => "bar"});
+
+is(join("", @warns), "", "__DIE__ is not evil here");
diff --git a/gnu/usr.bin/perl/ext/Storable/t/testlib.pl b/gnu/usr.bin/perl/ext/Storable/t/testlib.pl
new file mode 100644
index 00000000000..6d885d7f686
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Storable/t/testlib.pl
@@ -0,0 +1,38 @@
+#!perl -w
+use strict;
+use vars '$file';
+
+$file = "storable-testfile.$$";
+die "Temporary file '$file' already exists" if -e $file;
+
+END { while (-f $file) {unlink $file or die "Can't unlink '$file': $!" }}
+
+use Storable qw (store retrieve freeze thaw nstore nfreeze);
+
+sub slurp {
+  my $file = shift;
+  local (*FH, $/);
+  open FH, "<$file" or die "Can't open '$file': $!";
+  binmode FH;
+  my $contents = <FH>;
+  die "Can't read $file: $!" unless defined $contents;
+  return $contents;
+}
+
+sub store_and_retrieve {
+  my $data = shift;
+  unlink $file or die "Can't unlink '$file': $!";
+  open FH, ">$file" or die "Can't open '$file': $!";
+  binmode FH;
+  print FH $data or die "Can't print to '$file': $!";
+  close FH or die "Can't close '$file': $!";
+
+  return  eval {retrieve $file};
+}
+
+sub freeze_and_thaw {
+  my $data = shift;
+  return eval {thaw $data};
+}
+
+$file;
diff --git a/gnu/usr.bin/perl/ext/Storable/t/weak.t b/gnu/usr.bin/perl/ext/Storable/t/weak.t
new file mode 100755
index 00000000000..a8b708b1b31
--- /dev/null
+++ b/gnu/usr.bin/perl/ext/Storable/t/weak.t
@@ -0,0 +1,147 @@
+#!./perl -w
+#
+#  Copyright 2004, Larry Wall.
+#
+#  You may redistribute only under the same terms as Perl 5, as specified
+#  in the README file that comes with the distribution.
+#
+
+sub BEGIN {
+  if ($ENV{PERL_CORE}){
+    chdir('t') if -d 't';
+    @INC = ('.', '../lib', '../ext/Storable/t');
+  } else {
+    # This lets us distribute Test::More in t/
+    unshift @INC, 't';
+  }
+  require Config; import Config;
+  if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) {
+    print "1..0 # Skip: Storable was not built\n";
+    exit 0;
+  }
+  if ($Config{extensions} !~ /\bList\/Util\b/) {
+    print "1..0 # Skip: List::Util was not built\n";
+    exit 0;
+  }
+
+  require Scalar::Util;
+  Scalar::Util->import(qw(weaken isweak));
+  if (grep { /weaken/ } @Scalar::Util::EXPORT_FAIL) {
+    print("1..0 # Skip: No support for weaken in Scalar::Util\n");
+    exit 0;
+  }
+}
+
+use Test::More 'no_plan';
+use Storable qw (store retrieve freeze thaw nstore nfreeze);
+require 'testlib.pl';
+use vars '$file';
+use strict;
+
+sub tester {
+  my ($contents, $sub, $testersub, $what) = @_;
+  # Test that if we re-write it, everything still works:
+  my $clone = &$sub ($contents);
+  is ($@, "", "There should be no error extracting for $what");
+  &$testersub ($clone, $what);
+}
+
+my $r = {};
+my $s1 = [$r, $r];
+weaken $s1->[1];
+ok (isweak($s1->[1]), "element 1 is a weak reference");
+
+my $s0 = [$r, $r];
+weaken $s0->[0];
+ok (isweak($s0->[0]), "element 0 is a weak reference");
+
+my $w = [$r];
+weaken $w->[0];
+ok (isweak($w->[0]), "element 0 is a weak reference");
+
+package OVERLOADED;
+
+use overload
+	'""' => sub { $_[0][0] };
+
+package main;
+
+$a = bless [77], 'OVERLOADED';
+
+my $o = [$a, $a];
+weaken $o->[0];
+ok (isweak($o->[0]), "element 0 is a weak reference");
+
+my @tests = (
+[$s1,
+ sub  {
+  my ($clone, $what) = @_;
+  isa_ok($clone,'ARRAY');
+  isa_ok($clone->[0],'HASH');
+  isa_ok($clone->[1],'HASH');
+  ok(!isweak $clone->[0], "Element 0 isn't weak");
+  ok(isweak $clone->[1], "Element 1 is weak");
+}
+],
+# The weak reference needs to hang around long enough for other stuff to
+# be able to make references to it. So try it second.
+[$s0,
+ sub  {
+  my ($clone, $what) = @_;
+  isa_ok($clone,'ARRAY');
+  isa_ok($clone->[0],'HASH');
+  isa_ok($clone->[1],'HASH');
+  ok(isweak $clone->[0], "Element 0 is weak");
+  ok(!isweak $clone->[1], "Element 1 isn't weak");
+}
+],
+[$w,
+ sub  {
+  my ($clone, $what) = @_;
+  isa_ok($clone,'ARRAY');
+  if ($what eq 'nothing') {
+    # We're the original, so we're still a weakref to a hash
+    isa_ok($clone->[0],'HASH');
+    ok(isweak $clone->[0], "Element 0 is weak");
+  } else {
+    is($clone->[0],undef);
+  }
+}
+],
+[$o,
+sub {
+  my ($clone, $what) = @_;
+  isa_ok($clone,'ARRAY');
+  isa_ok($clone->[0],'OVERLOADED');
+  isa_ok($clone->[1],'OVERLOADED');
+  ok(isweak $clone->[0], "Element 0 is weak");
+  ok(!isweak $clone->[1], "Element 1 isn't weak");
+  is ("$clone->[0]", 77, "Element 0 stringifies to 77");
+  is ("$clone->[1]", 77, "Element 1 stringifies to 77");
+}
+],
+);
+
+foreach (@tests) {
+  my ($input, $testsub) = @$_;
+
+  tester($input, sub {return shift}, $testsub, 'nothing');
+
+  ok (defined store($input, $file));
+
+  # Read the contents into memory:
+  my $contents = slurp ($file);
+
+  tester($contents, \&store_and_retrieve, $testsub, 'file');
+
+  # And now try almost everything again with a Storable string
+  my $stored = freeze $input;
+  tester($stored, \&freeze_and_thaw, $testsub, 'string');
+
+  ok (defined nstore($input, $file));
+
+  tester($contents, \&store_and_retrieve, $testsub, 'network file');
+
+  $stored = nfreeze $input;
+  tester($stored, \&freeze_and_thaw, $testsub, 'network string');
+}