dclone.t revision 1.1.1.1
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 unshift @INC, 't'; 11 require Config; import Config; 12 if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { 13 print "1..0 # Skip: Storable was not built\n"; 14 exit 0; 15 } 16 require 'st-dump.pl'; 17} 18 19 20use Storable qw(dclone); 21 22print "1..12\n"; 23 24$a = 'toto'; 25$b = \$a; 26$c = bless {}, CLASS; 27$c->{attribute} = 'attrval'; 28%a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); 29@a = ('first', undef, 3, -4, -3.14159, 456, 4.5, 30 $b, \$a, $a, $c, \$c, \%a); 31 32print "not " unless defined ($aref = dclone(\@a)); 33print "ok 1\n"; 34 35$dumped = &dump(\@a); 36print "ok 2\n"; 37 38$got = &dump($aref); 39print "ok 3\n"; 40 41print "not " unless $got eq $dumped; 42print "ok 4\n"; 43 44package FOO; @ISA = qw(Storable); 45 46sub make { 47 my $self = bless {}; 48 $self->{key} = \%main::a; 49 return $self; 50}; 51 52package main; 53 54$foo = FOO->make; 55print "not " unless defined($r = $foo->dclone); 56print "ok 5\n"; 57 58print "not " unless &dump($foo) eq &dump($r); 59print "ok 6\n"; 60 61# Ensure refs to "undef" values are properly shared during cloning 62my $hash; 63push @{$$hash{''}}, \$$hash{a}; 64print "not " unless $$hash{''}[0] == \$$hash{a}; 65print "ok 7\n"; 66 67my $cloned = dclone(dclone($hash)); 68print "not " unless $$cloned{''}[0] == \$$cloned{a}; 69print "ok 8\n"; 70 71$$cloned{a} = "blah"; 72print "not " unless $$cloned{''}[0] == \$$cloned{a}; 73print "ok 9\n"; 74 75# [ID 20020221.007] SEGV in Storable with empty string scalar object 76package TestString; 77sub new { 78 my ($type, $string) = @_; 79 return bless(\$string, $type); 80} 81package main; 82my $empty_string_obj = TestString->new(''); 83my $clone = dclone($empty_string_obj); 84# If still here after the dclone the fix (#17543) worked. 85print ref $clone eq ref $empty_string_obj && 86 $$clone eq $$empty_string_obj && 87 $$clone eq '' ? "ok 10\n" : "not ok 10\n"; 88 89 90# Do not fail if Tie::Hash and/or Tie::StdHash is not available 91if (eval { require Tie::Hash; scalar keys %Tie::StdHash:: }) { 92 tie my %tie, "Tie::StdHash" or die $!; 93 $tie{array} = [1,2,3,4]; 94 $tie{hash} = {1,2,3,4}; 95 my $clone_array = dclone $tie{array}; 96 print "not " unless "@$clone_array" eq "@{$tie{array}}"; 97 print "ok 11\n"; 98 my $clone_hash = dclone $tie{hash}; 99 print "not " unless $clone_hash->{1} eq $tie{hash}{1}; 100 print "ok 12\n"; 101} else { 102 print <<EOF; 103ok 11 # skip No Tie::StdHash available 104ok 12 # skip No Tie::StdHash available 105EOF 106} 107