ext/threads/shared/t/sv_refs.t

   1 use strict;
   2 use warnings;
   3
   4 BEGIN {
   5     if ($ENV{'PERL_CORE'}){
   6         chdir 't';
   7         unshift @INC, '../lib';
   8     }
   9     use Config;
  10     if (! $Config{'useithreads'}) {
  11         print("1..0 # Skip: Perl not compiled with 'useithreads'\n");
  12         exit(0);
  13     }
  14 }
  15
  16 use ExtUtils::testlib;
  17
  18 sub ok {
  19     my ($id, $ok, $name) = @_;
  20
  21     # You have to do it this way or VMS will get confused.
  22     if ($ok) {
  23         print("ok $id - $name\n");
  24     } else {
  25         print("not ok $id - $name\n");
  26         printf("# Failed test at line %d\n", (caller)[2]);
  27     }
  28
  29     return ($ok);
  30 }
  31
  32 BEGIN {
  33     $| = 1;
  34     print("1..11\n");   ### Number of tests that will be run ###
  35 };
  36
  37 use threads;
  38 use threads::shared;
  39 ok(1, 1, 'Loaded');
  40
  41 ### Start of Testing ###
  42
  43 my $foo;
  44 my $bar = "foo";
  45 share($foo);
  46 eval { $foo = \$bar; };
  47 ok(2,my $temp1 = $@ =~/^Invalid\b.*shared scalar/, "Wrong error message");
  48
  49 share($bar);
  50 $foo = \$bar;
  51 ok(3, $temp1 = $foo =~/SCALAR/, "Check that is a ref");
  52 ok(4, $$foo eq "foo", "Check that it points to the correct value");
  53 $bar = "yeah";
  54 ok(5, $$foo eq "yeah", "Check that assignment works");
  55 $$foo = "yeah2";
  56 ok(6, $$foo eq "yeah2", "Check that deref assignment works");
  57 threads->create(sub {$bar = "yeah3"})->join();
  58 ok(7, $$foo eq "yeah3", "Check that other thread assignemtn works");
  59 threads->create(sub {$foo = "artur"})->join();
  60 ok(8, $foo eq "artur", "Check that uncopupling the ref works");
  61 my $baz;
  62 share($baz);
  63 $baz = "original";
  64 $bar = \$baz;
  65 $foo = \$bar;
  66 ok(9,$$$foo eq 'original', "Check reference chain");
  67 my($t1,$t2);
  68 share($t1);
  69 share($t2);
  70 $t2 = "text";
  71 $t1 = \$t2;
  72 threads->create(sub { $t1 = "bar" })->join();
  73 ok(10,$t1 eq 'bar',"Check that assign to a ROK works");
  74
  75 ok(11, is_shared($foo), "Check for sharing");
  76
  77 # EOF