ext/threads/shared/t/av_simple.t

   1 BEGIN {
   2 #    chdir 't' if -d 't';
   3 #    push @INC ,'../lib';
   4     require Config; import Config;
   5     unless ($Config{'useithreads'}) {
   6         print "1..0 # Skip: no useithreads\n";
   7         exit 0;
   8     }
   9 }
  10
  11
  12 sub ok {
  13     my ($id, $ok, $name) = @_;
  14
  15     # You have to do it this way or VMS will get confused.
  16     print $ok ? "ok $id - $name\n" : "not ok $id - $name\n";
  17
  18     printf "# Failed test at line %d\n", (caller)[2] unless $ok;
  19
  20     return $ok;
  21 }
  22
  23
  24
  25 use ExtUtils::testlib;
  26 use strict;
  27 BEGIN { print "1..43\n" };
  28 use threads;
  29 use threads::shared;
  30 ok(1,1,"loaded");
  31 my @foo;
  32 share(@foo);
  33 ok(2,1,"shared \@foo");
  34 $foo[0] = "hi";
  35 ok(3, $foo[0] eq 'hi', "Check assignment works");
  36 $foo[0] = "bar";
  37 ok(4, $foo[0] eq 'bar', "Check overwriting works");
  38 ok(5, $foo[1] == undef, "Check undef value");
  39 $foo[2] = "test";
  40 ok(6, $foo[2] eq "test", "Check extending the array works");
  41 ok(7, $foo[1] == undef, "Check undef value again");
  42 ok(8, scalar(@foo) == 3, "Check the length of the array");
  43 ok(9,$#foo == 2, "Check last element of array");
  44 threads->create(sub { $foo[0] = "thread1" })->join;
  45 ok(10, $foo[0] eq "thread1", "Check that a value can be changed in another thread");
  46 push(@foo, "another value");
  47 ok(11, $foo[3] eq "another value", "Check that push works");
  48 push(@foo, 1,2,3);
  49 ok(12, $foo[-1] == 3, "More push");
  50 ok(13, $foo[-2] == 2, "More push");
  51 ok(14, $foo[4] == 1, "More push");
  52 threads->create(sub { push @foo, "thread2" })->join();
  53 ok(15, $foo[7] eq "thread2", "Check push in another thread");
  54 unshift(@foo, "start");
  55 ok(16, $foo[0] eq "start", "Check unshift");
  56 unshift(@foo, 1,2,3);
  57 ok(17, $foo[0] == 1, "Check multiple unshift");
  58 ok(18, $foo[1] == 2, "Check multiple unshift");
  59 ok(19, $foo[2] == 3, "Check multiple unshift");
  60 threads->create(sub { unshift @foo, "thread3" })->join();
  61 ok(20, $foo[0] eq "thread3", "Check unshift from another thread");
  62 my $var = pop(@foo);
  63 ok(21, $var eq "thread2", "Check pop");
  64 threads->create(sub { my $foo = pop @foo; ok(22, $foo == 3, "Check pop works in a thread")})->join();
  65 $var = pop(@foo);
  66 ok(23, $var == 2, "Check pop after thread");
  67 $var = shift(@foo);
  68 ok(24, $var eq "thread3", "Check shift");
  69 threads->create(sub { my $foo = shift @foo; ok(25, $foo  == 1, "Check shift works in a thread");
  70 })->join();
  71 $var = shift(@foo);
  72 ok(26, $var == 2, "Check shift after thread");
  73 {
  74     my @foo2;
  75     share @foo2;
  76     my $empty = shift @foo2;
  77     ok(27, $empty == undef , "Check shift on empty array");
  78     $empty = pop @foo2;
  79     ok(28, $empty == undef , "Check pop on empty array");
  80 }
  81 my $i = 0;
  82 foreach my $var (@foo) {
  83     $i++;
  84 }
  85 ok(29, scalar @foo == $i, "Check foreach");
  86 my $ref = \@foo;
  87 ok(30, $ref->[0] == 3, "Check reference access");
  88 threads->create(sub { $ref->[0] = "thread4"})->join();
  89 ok(31, $ref->[0] eq "thread4", "Check that it works after another thread");
  90 undef($ref);
  91 threads->create(sub { @foo = () })->join();
  92 ok(32, @foo == 0, "Check that array is empty");
  93 ok(33, exists($foo[0]) == 0, "Check that zero index doesn't index");
  94 @foo = ("sky");
  95 ok(34, exists($foo[0]) == 1, "Check that zero index exists now");
  96 ok(35, $foo[0] eq "sky", "And check that it also contains the right value");
  97 $#foo = 20;
  98 $foo[20] = "sky";
  99 ok(36, delete($foo[20]) eq "sky", "Check delete works");
 100
 101 threads->create(sub { delete($foo[0])})->join();
 102 ok(37, delete($foo[0]) == undef, "Check that delete works from a thread");
 103
 104 @foo = (1,2,3,4,5);
 105
 106 {
 107     my ($t1,$t2) = @foo[2,3];
 108     ok(38, $t1 == 3, "Check slice");
 109     ok(39, $t2 == 4, "Check slice again");
 110     my @t1 = @foo[1...4];
 111     ok(40, $t1[0] == 2, "Check slice list");
 112     ok(41, $t1[2] == 4, "Check slice list 2");
 113     threads->create(sub { @foo[0,1] = ("hej","hop") })->join();
 114     ok(42,$foo[0] eq "hej", "Check slice assign");
 115 }
 116 {
 117     eval {
 118         my @t1 = splice(@foo,0,2,"hop", "hej");
 119     };
 120     ok(43, my $temp1 = $@ =~/Splice not implemented for shared arrays/, "Check that the warning message is correct for non splice");
 121 }