1#!./perl 2# 3# Copyright (c) 1995-2000, Raphael Manfredi 4# 5# You may redistribute only under the same terms as Perl 5, as specified 6# in the README file that comes with the distribution. 7# 8 9sub BEGIN { 10 if ($ENV{PERL_CORE}){ 11 chdir('t') if -d 't'; 12 @INC = ('.', '../lib', '../ext/Storable/t'); 13 } else { 14 unshift @INC, 't'; 15 } 16 require Config; import Config; 17 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { 18 print "1..0 # Skip: Storable was not built\n"; 19 exit 0; 20 } 21 require 'st-dump.pl'; 22} 23 24 25use Storable qw(dclone); 26 27print "1..10\n"; 28 29$a = 'toto'; 30$b = \$a; 31$c = bless {}, CLASS; 32$c->{attribute} = 'attrval'; 33%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); 34@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, 35 $b, \$a, $a, $c, \$c, \%a); 36 37print "not " unless defined ($aref = dclone(\@a)); 38print "ok 1\n"; 39 40$dumped = &dump(\@a); 41print "ok 2\n"; 42 43$got = &dump($aref); 44print "ok 3\n"; 45 46print "not " unless $got eq $dumped; 47print "ok 4\n"; 48 49package FOO; @ISA = qw(Storable); 50 51sub make { 52 my $self = bless {}; 53 $self->{key} = \%main::a; 54 return $self; 55}; 56 57package main; 58 59$foo = FOO->make; 60print "not " unless defined($r = $foo->dclone); 61print "ok 5\n"; 62 63print "not " unless &dump($foo) eq &dump($r); 64print "ok 6\n"; 65 66# Ensure refs to "undef" values are properly shared during cloning 67my $hash; 68push @{$$hash{''}}, \$$hash{a}; 69print "not " unless $$hash{''}[0] == \$$hash{a}; 70print "ok 7\n"; 71 72my $cloned = dclone(dclone($hash)); 73print "not " unless $$cloned{''}[0] == \$$cloned{a}; 74print "ok 8\n"; 75 76$$cloned{a} = "blah"; 77print "not " unless $$cloned{''}[0] == \$$cloned{a}; 78print "ok 9\n"; 79 80# [ID 20020221.007] SEGV in Storable with empty string scalar object 81package TestString; 82sub new { 83 my ($type, $string) = @_; 84 return bless(\$string, $type); 85} 86package main; 87my $empty_string_obj = TestString->new(''); 88my $clone = dclone($empty_string_obj); 89# If still here after the dclone the fix (#17543) worked. 90print ref $clone eq ref $empty_string_obj && 91 $$clone eq $$empty_string_obj && 92 $$clone eq '' ? "ok 10\n" : "not ok 10\n"; 93