ext/threads/shared/t/object.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     if ($] < 5.010) {
  15         print("1..0 # SKIP Needs Perl 5.10.0 or later\n");
  16         exit(0);
  17     }
  18 }
  19
  20 use ExtUtils::testlib;
  21
  22 BEGIN {
  23     $| = 1;
  24     print("1..28\n");   ### Number of tests that will be run ###
  25 };
  26
  27 use threads;
  28 use threads::shared;
  29
  30 my $TEST;
  31 BEGIN {
  32     share($TEST);
  33     $TEST = 1;
  34 }
  35
  36 sub ok {
  37     my ($ok, $name) = @_;
  38
  39     lock($TEST);
  40     my $id = $TEST++;
  41
  42     # You have to do it this way or VMS will get confused.
  43     if ($ok) {
  44         print("ok $id - $name\n");
  45     } else {
  46         print("not ok $id - $name\n");
  47         printf("# Failed test at line %d\n", (caller)[2]);
  48     }
  49
  50     return ($ok);
  51 }
  52
  53 ok(1, 'Loaded');
  54
  55 ### Start of Testing ###
  56
  57 { package Jar;
  58     my @jar :shared;
  59
  60     sub new
  61     {
  62         bless(&threads::shared::share({}), shift);
  63     }
  64
  65     sub store
  66     {
  67         my ($self, $cookie) = @_;
  68         push(@jar, $cookie);
  69         return $jar[-1];        # Results in destruction of proxy object
  70     }
  71
  72     sub peek
  73     {
  74         return $jar[-1];
  75     }
  76
  77     sub fetch
  78     {
  79         pop(@jar);
  80     }
  81 }
  82
  83 { package Cookie;
  84
  85     sub new
  86     {
  87         my $self = bless(&threads::shared::share({}), shift);
  88         $self->{'type'} = shift;
  89         return $self;
  90     }
  91
  92     sub DESTROY
  93     {
  94         delete(shift->{'type'});
  95     }
  96 }
  97
  98 my $C1 = 'chocolate chip';
  99 my $C2 = 'oatmeal raisin';
 100 my $C3 = 'vanilla wafer';
 101
 102 my $cookie = Cookie->new($C1);
 103 ok($cookie->{'type'} eq $C1, 'Have cookie');
 104
 105 my $jar = Jar->new();
 106 $jar->store($cookie);
 107
 108 ok($cookie->{'type'}      eq $C1, 'Still have cookie');
 109 ok($jar->peek()->{'type'} eq $C1, 'Still have cookie');
 110 ok($cookie->{'type'}      eq $C1, 'Still have cookie');
 111
 112 threads->create(sub {
 113     ok($cookie->{'type'}      eq $C1, 'Have cookie in thread');
 114     ok($jar->peek()->{'type'} eq $C1, 'Still have cookie in thread');
 115     ok($cookie->{'type'}      eq $C1, 'Still have cookie in thread');
 116
 117     $jar->store(Cookie->new($C2));
 118     ok($jar->peek()->{'type'} eq $C2, 'Added cookie in thread');
 119 })->join();
 120
 121 ok($cookie->{'type'}      eq $C1, 'Still have original cookie after thread');
 122 ok($jar->peek()->{'type'} eq $C2, 'Still have added cookie after thread');
 123
 124 $cookie = $jar->fetch();
 125 ok($cookie->{'type'}      eq $C2, 'Fetched cookie from jar');
 126 ok($jar->peek()->{'type'} eq $C1, 'Cookie still in jar');
 127
 128 $cookie = $jar->fetch();
 129 ok($cookie->{'type'}      eq $C1, 'Fetched cookie from jar');
 130 undef($cookie);
 131
 132 share($cookie);
 133 $cookie = $jar->store(Cookie->new($C3));
 134 ok($jar->peek()->{'type'} eq $C3, 'New cookie in jar');
 135 ok($cookie->{'type'}      eq $C3, 'Have cookie');
 136
 137 threads->create(sub {
 138     ok($cookie->{'type'}      eq $C3, 'Have cookie in thread');
 139     $cookie = Cookie->new($C1);
 140     ok($cookie->{'type'}      eq $C1, 'Change cookie in thread');
 141     ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
 142 })->join();
 143
 144 ok($cookie->{'type'}      eq $C1, 'Have changed cookie after thread');
 145 ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
 146 undef($cookie);
 147 ok($jar->peek()->{'type'} eq $C3, 'Still have cookie in jar');
 148 $cookie = $jar->fetch();
 149 ok($cookie->{'type'}      eq $C3, 'Fetched cookie from jar');
 150
 151 { package Foo;
 152
 153     my $ID = 1;
 154     threads::shared::share($ID);
 155
 156     sub new
 157     {
 158         # Anonymous scalar with an internal ID
 159         my $obj = \do{ my $scalar = $ID++; };
 160         threads::shared::share($obj);   # Make it shared
 161         return (bless($obj, 'Foo'));    # Make it an object
 162     }
 163 }
 164
 165 my $obj :shared;
 166 $obj = Foo->new();
 167 ok($$obj == 1, "Main: Object ID $$obj");
 168
 169 threads->create( sub {
 170         ok($$obj == 1, "Thread: Object ID $$obj");
 171
 172         $$obj = 10;
 173         ok($$obj == 10, "Thread: Changed object ID $$obj");
 174
 175         $obj = Foo->new();
 176         ok($$obj == 2, "Thread: New object ID $$obj");
 177     } )->join();
 178
 179 ok($$obj == 2, "Main: New object ID $$obj  # TODO - should be 2");
 180
 181 exit(0);
 182
 183 # EOF