cpan/Tie-RefHash/t/storable.t

   1 #!/usr/bin/perl -T -w
   2
   3 BEGIN {
   4     if( $ENV{PERL_CORE} ) {
   5         chdir 't';
   6         @INC = '../lib';
   7     }
   8 }
   9
  10 BEGIN {
  11   unless ( eval { require Storable; 1 } ){
  12     print "1..0 # Skip -- Storable is not available\n";
  13     exit 0;
  14   }
  15 }
  16
  17 use strict;
  18
  19 use Tie::RefHash;
  20
  21 use Storable qw/dclone nfreeze thaw/;
  22
  23 $\ = "\n";
  24 print "1..24";
  25
  26 sub ok ($$) {
  27     print ( ( $_[0] ? "" : "not " ), "ok - $_[1]" );
  28 }
  29
  30 sub is ($$$) {
  31     print ( ( ( $_[0] eq $_[1] ) ? "" : "not "), "ok - $_[2]" );
  32 }
  33
  34 sub isa_ok ($$) {
  35     ok( eval { $_[0]->isa($_[1]) }, "the object isa $_[1]");
  36 }
  37
  38 tie my %hash, "Tie::RefHash";
  39
  40 my $key = { foo => 1 };
  41 $hash{$key} = "value";
  42 $hash{non_ref} = "other";
  43
  44 foreach my $clone ( \%hash, dclone(\%hash), thaw(nfreeze(\%hash)) ){
  45
  46   ok( tied(%$clone), "copy is tied");
  47   isa_ok( tied(%$clone), "Tie::RefHash" );
  48
  49   my @keys = keys %$clone;
  50   is( scalar(@keys), 2, "one key in clone");
  51   my $key = ref($keys[0]) ? shift @keys : pop @keys;
  52   my $reg = $keys[0];
  53
  54   ok( ref($key), "key is a ref after clone" );
  55   is( $key->{foo}, 1, "key serialized ok");
  56
  57   is( $clone->{$key}, "value", "and is still pointing at the same value" );
  58
  59   ok( !ref($reg), "regular key is non ref" );
  60   is( $clone->{$reg}, "other", "and is also a valid key" );
  61 }
  62
  63