lib/Tie/RefHash/threaded.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 use strict;
  11
  12 BEGIN {
  13     # this is sucky because threads.pm has to be loaded before Test::Builder
  14   use Config;
  15   if ( $Config{usethreads} and !$Config{use5005threads} ) {
  16     require threads; "threads"->import;
  17     print "1..14\n";
  18   } else {
  19     print "1..0 # Skip -- threads aren't enabled in your perl\n";
  20     exit 0;
  21   }
  22 }
  23
  24 use Tie::RefHash;
  25
  26 $\ = "\n";
  27 sub ok ($$) {
  28   print ( ( $_[0] ? "" : "not " ), "ok - $_[1]" );
  29 }
  30
  31 sub is ($$$) {
  32   print ( ( ( $_[0] eq $_[1] ) ? "" : "not "), "ok - $_[2]" );
  33 }
  34
  35 tie my %hash, "Tie::RefHash";
  36
  37 my $r1 = {};
  38 my $r2 = [];
  39 my $v1 = "foo";
  40
  41 $hash{$r1} = "hash";
  42 $hash{$r2} = "array";
  43 $hash{$v1} = "string";
  44
  45 is( $hash{$v1}, "string", "fetch by string before clone ($v1)" );
  46 is( $hash{$r1}, "hash", "fetch by ref before clone ($r1)" );
  47 is( $hash{$r2}, "array", "fetch by ref before clone ($r2)" );
  48
  49 my $th = threads->create(sub {
  50   is( scalar keys %hash, 3, "key count is OK" );
  51
  52   ok( exists $hash{$v1}, "string key exists ($v1)" );
  53   is( $hash{$v1}, "string", "fetch by string" );
  54
  55   ok( exists $hash{$r1}, "ref key exists ($r1)" );
  56   is( $hash{$r1}, "hash", "fetch by ref" );
  57
  58   ok( exists $hash{$r2}, "ref key exists ($r2)" );
  59   is( $hash{$r2}, "array", "fetch by ref" );
  60
  61   is( join("\0",sort keys %hash), join("\0",sort $r1, $r2, $v1), "keys are ok" );
  62 });
  63
  64 $th->join;
  65
  66 is( $hash{$v1}, "string", "fetch by string after clone, orig thread ($v1)" );
  67 is( $hash{$r1}, "hash", "fetch by ref after clone ($r1)" );
  68 is( $hash{$r2}, "array", "fetch by ref after clone ($r2)" );