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