Commit | Line | Data |
---|---|---|
7a6a85bf | 1 | #!./perl |
7a6a85bf RG |
2 | # |
3 | # Copyright (c) 1995-2000, Raphael Manfredi | |
4 | # | |
9e21b3d0 JH |
5 | # You may redistribute only under the same terms as Perl 5, as specified |
6 | # in the README file that comes with the distribution. | |
7a6a85bf | 7 | # |
7a6a85bf RG |
8 | |
9 | sub BEGIN { | |
48c887dd | 10 | unshift @INC, 't'; |
1afdebce | 11 | unshift @INC, 't/compat' if $] < 5.006002; |
9f233367 | 12 | require Config; import Config; |
0c384302 | 13 | if ($ENV{PERL_CORE} and $Config{'extensions'} !~ /\bStorable\b/) { |
9f233367 PP |
14 | print "1..0 # Skip: Storable was not built\n"; |
15 | exit 0; | |
16 | } | |
372cb964 | 17 | require 'st-dump.pl'; |
7a6a85bf RG |
18 | } |
19 | ||
20 | ||
21 | use Storable qw(dclone); | |
22 | ||
dddb60fc | 23 | use Test::More tests => 14; |
7a6a85bf RG |
24 | |
25 | $a = 'toto'; | |
26 | $b = \$a; | |
27 | $c = bless {}, CLASS; | |
28 | $c->{attribute} = 'attrval'; | |
29 | %a = ('key', 'value', 1, 0, $a, $b, 'cvar', \$c); | |
30 | @a = ('first', undef, 3, -4, -3.14159, 456, 4.5, | |
31 | $b, \$a, $a, $c, \$c, \%a); | |
32 | ||
dddb60fc NC |
33 | my $aref = dclone(\@a); |
34 | isnt($aref, undef); | |
7a6a85bf RG |
35 | |
36 | $dumped = &dump(\@a); | |
dddb60fc | 37 | isnt($dumped, undef); |
7a6a85bf RG |
38 | |
39 | $got = &dump($aref); | |
dddb60fc | 40 | isnt($got, undef); |
7a6a85bf | 41 | |
dddb60fc | 42 | is($got, $dumped); |
7a6a85bf RG |
43 | |
44 | package FOO; @ISA = qw(Storable); | |
45 | ||
46 | sub make { | |
47 | my $self = bless {}; | |
48 | $self->{key} = \%main::a; | |
49 | return $self; | |
50 | }; | |
51 | ||
52 | package main; | |
53 | ||
54 | $foo = FOO->make; | |
dddb60fc NC |
55 | my $r = $foo->dclone; |
56 | isnt($r, undef); | |
7a6a85bf | 57 | |
dddb60fc | 58 | is(&dump($foo), &dump($r)); |
7a6a85bf RG |
59 | |
60 | # Ensure refs to "undef" values are properly shared during cloning | |
61 | my $hash; | |
62 | push @{$$hash{''}}, \$$hash{a}; | |
dddb60fc | 63 | is($$hash{''}[0], \$$hash{a}); |
7a6a85bf RG |
64 | |
65 | my $cloned = dclone(dclone($hash)); | |
dddb60fc | 66 | is($$cloned{''}[0], \$$cloned{a}); |
7a6a85bf RG |
67 | |
68 | $$cloned{a} = "blah"; | |
dddb60fc | 69 | is($$cloned{''}[0], \$$cloned{a}); |
7a6a85bf | 70 | |
14bff8b8 AS |
71 | # [ID 20020221.007] SEGV in Storable with empty string scalar object |
72 | package TestString; | |
73 | sub new { | |
74 | my ($type, $string) = @_; | |
75 | return bless(\$string, $type); | |
76 | } | |
77 | package main; | |
78 | my $empty_string_obj = TestString->new(''); | |
79 | my $clone = dclone($empty_string_obj); | |
80 | # If still here after the dclone the fix (#17543) worked. | |
dddb60fc NC |
81 | is(ref $clone, ref $empty_string_obj); |
82 | is($$clone, $$empty_string_obj); | |
83 | is($$clone, ''); | |
2711d9fb SR |
84 | |
85 | ||
dddb60fc | 86 | SKIP: { |
2711d9fb | 87 | # Do not fail if Tie::Hash and/or Tie::StdHash is not available |
dddb60fc NC |
88 | skip 'No Tie::StdHash available', 2 |
89 | unless eval { require Tie::Hash; scalar keys %Tie::StdHash:: }; | |
2711d9fb SR |
90 | tie my %tie, "Tie::StdHash" or die $!; |
91 | $tie{array} = [1,2,3,4]; | |
92 | $tie{hash} = {1,2,3,4}; | |
93 | my $clone_array = dclone $tie{array}; | |
dddb60fc | 94 | is("@$clone_array", "@{$tie{array}}"); |
2711d9fb | 95 | my $clone_hash = dclone $tie{hash}; |
dddb60fc | 96 | is($clone_hash->{1}, $tie{hash}{1}); |
2711d9fb | 97 | } |