dist/threads-shared/t/clone.t

   1 use strict;
   2 use warnings;
   3
   4 BEGIN {
   5     use Config;
   6     if (! $Config{'useithreads'}) {
   7         print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
   8         exit(0);
   9     }
  10 }
  11
  12 use ExtUtils::testlib;
  13
  14 sub ok {
  15     my ($id, $ok, $name) = @_;
  16
  17     # You have to do it this way or VMS will get confused.
  18     if ($ok) {
  19         print("ok $id - $name\n");
  20     } else {
  21         print("not ok $id - $name\n");
  22         printf("# Failed test at line %d\n", (caller)[2]);
  23     }
  24
  25     return ($ok);
  26 }
  27
  28 BEGIN {
  29     $| = 1;
  30     print("1..34\n");   ### Number of tests that will be run ###
  31 };
  32
  33 my $test = 1;
  34
  35 use threads;
  36 use threads::shared;
  37 ok($test++, 1, 'Loaded');
  38
  39 ### Start of Testing ###
  40
  41 {
  42     my $x = shared_clone(14);
  43     ok($test++, $x == 14, 'number');
  44
  45     $x = shared_clone('test');
  46     ok($test++, $x eq 'test', 'string');
  47 }
  48
  49 {
  50     my %hsh = ('foo' => 2);
  51     eval {
  52         my $x = shared_clone(%hsh);
  53     };
  54     ok($test++, $@ =~ /Usage:/, '1 arg');
  55
  56     threads->create(sub {})->join();  # Hide leaks, etc.
  57 }
  58
  59 {
  60     my $x = 'test';
  61     my $foo :shared = shared_clone($x);
  62     ok($test++, $foo eq 'test', 'cloned string');
  63
  64     $foo = shared_clone(\$x);
  65     ok($test++, $$foo eq 'test', 'cloned scalar ref');
  66
  67     threads->create(sub {
  68         ok($test++, $$foo eq 'test', 'cloned scalar ref in thread');
  69     })->join();
  70
  71     $test++;
  72 }
  73
  74 {
  75     my $foo :shared;
  76     $foo = shared_clone(\$foo);
  77     ok($test++, ref($foo) eq 'REF', 'Circular ref typ');
  78     ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref');
  79
  80     threads->create(sub {
  81         ok($test++, threads::shared::_id($foo) == threads::shared::_id($$foo), 'Circular ref in thread');
  82
  83         my ($x, $y, $z);
  84         $x = \$y; $y = \$z; $z = \$x;
  85         $foo = shared_clone($x);
  86     })->join();
  87
  88     $test++;
  89
  90     ok($test++, threads::shared::_id($$foo) == threads::shared::_id($$$$$foo),
  91                     'Cloned circular refs from thread');
  92 }
  93
  94 {
  95     my @ary = (qw/foo bar baz/);
  96     my $ary = shared_clone(\@ary);
  97
  98     ok($test++, $ary->[1] eq 'bar', 'Cloned array');
  99     $ary->[1] = 99;
 100     ok($test++, $ary->[1] == 99, 'Clone mod');
 101     ok($test++, $ary[1] eq 'bar', 'Original array');
 102
 103     threads->create(sub {
 104         ok($test++, $ary->[1] == 99, 'Clone mod in thread');
 105
 106         $ary[1] = 'bork';
 107         $ary->[1] = 'thread';
 108     })->join();
 109
 110     $test++;
 111
 112     ok($test++, $ary->[1] eq 'thread', 'Clone mod from thread');
 113     ok($test++, $ary[1] eq 'bar', 'Original array');
 114 }
 115
 116 {
 117     my $hsh :shared = shared_clone({'foo' => [qw/foo bar baz/]});
 118     ok($test++, is_shared($hsh), 'Shared hash ref');
 119     ok($test++, is_shared($hsh->{'foo'}), 'Shared hash ref elem');
 120     ok($test++, $$hsh{'foo'}[1] eq 'bar', 'Cloned structure');
 121 }
 122
 123 {
 124     my $obj = \do { my $bork = 99; };
 125     bless($obj, 'Bork');
 126     Internals::SvREADONLY($$obj, 1) if ($] >= 5.008003);
 127
 128     my $bork = shared_clone($obj);
 129     ok($test++, $$bork == 99, 'cloned scalar ref object');
 130     ok($test++, ($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only');
 131     ok($test++, ref($bork) eq 'Bork', 'Object class');
 132
 133     threads->create(sub {
 134         ok($test++, $$bork == 99, 'cloned scalar ref object in thread');
 135         ok($test++, ($] < 5.008003) || Internals::SvREADONLY($$bork), 'read-only');
 136         ok($test++, ref($bork) eq 'Bork', 'Object class');
 137     })->join();
 138
 139     $test += 3;
 140 }
 141
 142 {
 143     my $scalar = 'zip';
 144
 145     my $obj = {
 146         'ary' => [ 1, 'foo', [ 86 ], { 'bar' => [ 'baz' ] } ],
 147         'ref' => \$scalar,
 148     };
 149
 150     $obj->{'self'} = $obj;
 151
 152     bless($obj, 'Foo');
 153
 154     my $copy :shared;
 155
 156     threads->create(sub {
 157         $copy = shared_clone($obj);
 158
 159         ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread');
 160         ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj');
 161         ok($test++, is_shared($copy->{'ary'}->[2]), 'Shared element in cloned obj');
 162     })->join();
 163
 164     $test += 3;
 165
 166     ok($test++, ref($copy) eq 'Foo', 'Obj cloned by thread');
 167     ok($test++, ${$copy->{'ref'}} eq 'zip', 'Obj ref in thread');
 168     ok($test++, threads::shared::_id($copy) == threads::shared::_id($copy->{'self'}), 'Circular ref in cloned obj');
 169     ok($test++, $copy->{'ary'}->[3]->{'bar'}->[0] eq 'baz', 'Deeply cloned');
 170     ok($test++, ref($copy) eq 'Foo', 'Cloned object class');
 171 }
 172
 173 exit(0);
 174
 175 # EOF