cpan/Tie-RefHash/t/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
  13 BEGIN {
  14     # this is sucky because threads.pm has to be loaded before Test::Builder
  15   use Config;
  16   eval { require Scalar::Util };
  17
  18   if ( $^O eq 'MSWin32' ) {
  19     print "1..0 # Skip -- this test is generally broken on windows for unknown reasons. If you can help debug this patches would be very welcome.\n";
  20     exit 0;
  21   }
  22   if ( $Config{usethreads} and !$Config{use5005threads}
  23       and defined(&Scalar::Util::weaken)
  24       and eval { require threads; threads->import; 1 }
  25   ) {
  26     print "1..14\n";
  27   } else {
  28     print "1..0 # Skip -- threads aren't enabled in your perl, or Scalar::Util::weaken is missing\n";
  29     exit 0;
  30   }
  31 }
  32
  33 use Tie::RefHash;
  34
  35 $\ = "\n";
  36 sub ok ($$) {
  37   print ( ( $_[0] ? "" : "not " ), "ok - $_[1]" );
  38 }
  39
  40 sub is ($$$) {
  41   print ( ( ( ($_[0]||'') eq ($_[1]||'') ) ? "" : "not "), "ok - $_[2]" );
  42 }
  43
  44 tie my %hash, "Tie::RefHash";
  45
  46 my $r1 = {};
  47 my $r2 = [];
  48 my $v1 = "foo";
  49
  50 $hash{$r1} = "hash";
  51 $hash{$r2} = "array";
  52 $hash{$v1} = "string";
  53
  54 is( $hash{$v1}, "string", "fetch by string before clone ($v1)" );
  55 is( $hash{$r1}, "hash", "fetch by ref before clone ($r1)" );
  56 is( $hash{$r2}, "array", "fetch by ref before clone ($r2)" );
  57
  58 my $th = threads->create(sub {
  59   is( scalar keys %hash, 3, "key count is OK" );
  60
  61   ok( exists $hash{$v1}, "string key exists ($v1)" );
  62   is( $hash{$v1}, "string", "fetch by string" );
  63
  64   ok( exists $hash{$r1}, "ref key exists ($r1)" );
  65   is( $hash{$r1}, "hash", "fetch by ref" );
  66
  67   ok( exists $hash{$r2}, "ref key exists ($r2)" );
  68   is( $hash{$r2}, "array", "fetch by ref" );
  69
  70   is( join("\0",sort keys %hash), join("\0",sort $r1, $r2, $v1), "keys are ok" );
  71 });
  72
  73 $th->join;
  74
  75 is( $hash{$v1}, "string", "fetch by string after clone, orig thread ($v1)" );
  76 is( $hash{$r1}, "hash", "fetch by ref after clone ($r1)" );
  77 is( $hash{$r2}, "array", "fetch by ref after clone ($r2)" );