ext/threads/shared/t/clone.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..34\n");   ### Number of tests that will be run ###
  35 };
  36
  37 my $test = 1;
  38
  39 use threads;
  40 use threads::shared;
  41 ok($test++, 1, 'Loaded');
  42
  43 ### Start of Testing ###
  44
  45 {
  46     my $x = shared_clone(14);
  47     ok($test++, $x == 14, 'number');
  48
  49     $x = shared_clone('test');
  50     ok($test++, $x eq 'test', 'string');
  51 }
  52
  53 {
  54     my %hsh = ('foo' => 2);
  55     eval {
  56         my $x = shared_clone(%hsh);
  57     };
  58     ok($test++, $@ =~ /Usage:/, '1 arg');
  59
  60     threads->create(sub {})->join();  # Hide leaks, etc.
  61 }
  62
  63 {
  64     my $x = 'test';
  65     my $foo :shared = shared_clone($x);
  66     ok($test++, $foo eq 'test', 'cloned string');
  67
  68     $foo = shared_clone(\$x);
  69     ok($test++, $$foo eq 'test', 'cloned scalar ref');
  70
  71     threads->create(sub {
  72         ok($test++, $$foo eq 'test', 'cloned scalar ref in thread');
  73     })->join();
  74
  75     $test++;
  76 }
  77
  78 {
  79     my $foo :shared;
  80     $foo = shared_clone(\$foo);
  81     ok($test++, ref($foo) eq 'REF', 'Circular ref typ');
  82     ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref');
  83
  84     threads->create(sub {
  85         ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref in thread');
  86
  87         my ($x, $y, $z);
  88         $x = \$y; $y = \$z; $z = \$x;
  89         $foo = shared_clone($x);
  90     })->join();
  91
  92     $test++;
  93
  94     ok($test++, threads::shared::_id($$foo) == threads::shared::_id($$$$$foo),
  95                     'Cloned circular refs from thread');
  96 }
  97
  98 {
  99     my @ary = (qw/foo bar baz/);
 100     my $ary = shared_clone(\@ary);
 101
 102     ok($test++, $ary->[1] eq 'bar', 'Cloned array');
 103     $ary->[1] = 99;
 104     ok($test++, $ary->[1] == 99, 'Clone mod');
 105     ok($test++, $ary[1] eq 'bar', 'Original array');
 106
 107     threads->create(sub {
 108         ok($test++, $ary->[1] == 99, 'Clone mod in thread');
 109
 110         $ary[1] = 'bork';
 111         $ary->[1] = 'thread';
 112     })->join();
 113
 114     $test++;
 115
 116     ok($test++, $ary->[1] eq 'thread', 'Clone mod from thread');
 117     ok($test++, $ary[1] eq 'bar', 'Original array');
 118 }
 119
 120 {
 121     my $hsh :shared = shared_clone({'foo' => [qw/foo bar baz/]});
 122     ok($test++, is_shared($hsh), 'Shared hash ref');
 123     ok($test++, is_shared($hsh->{'foo'}), 'Shared hash ref elem');
 124     ok($test++, $$hsh{'foo'}[1] eq 'bar', 'Cloned structure');
 125 }
 126
 127 {
 128     my $obj = \do { my $bork = 99; };
 129     bless($obj, 'Bork');
 130     Internals::SvREADONLY($$obj, 1) if ($] >= 5.008003);
 131
 132     my $bork = shared_clone($obj);
 133     ok($test++, $$bork == 99, 'cloned scalar ref object');
 134     ok($test++, ($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only');
 135     ok($test++, ref($bork) eq 'Bork', 'Object class');
 136
 137     threads->create(sub {
 138         ok($test++, $$bork == 99, 'cloned scalar ref object in thread');
 139         ok($test++, ($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only');
 140         ok($test++, ref($bork) eq 'Bork', 'Object class');
 141     })->join();
 142
 143     $test += 3;
 144 }
 145
 146 {
 147     my $scalar = 'zip';
 148
 149     my $obj = {
 150         'ary' => [ 1, 'foo', [ 86 ], { 'bar' => [ 'baz' ] } ],
 151         'ref' => \$scalar,
 152     };
 153
 154     $obj->{'self'} = $obj;
 155
 156     bless($obj, 'Foo');
 157
 158     my $copy :shared;
 159
 160     threads->create(sub {
 161         $copy = shared_clone($obj);
 162
 163         ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread');
 164         ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj');
 165         ok($test++, is_shared($copy->{'ary'}->[2]), 'Shared element in cloned obj');
 166     })->join();
 167
 168     $test += 3;
 169
 170     ok($test++, ref($copy) eq 'Foo', 'Obj cloned by thread');
 171     ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread');
 172     ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj');
 173     ok($test++, $copy->{'ary'}->[3]->{'bar'}->[0] eq 'baz', 'Deeply cloned');
 174     ok($test++, ref($copy) eq 'Foo', 'Cloned object class');
 175 }
 176
 177 exit(0);
 178
 179 # EOF