dist/threads-shared/t/dualvar.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     }
  21     else {
  22         print("not ok $id - $name\n");
  23         printf("# Failed test at line %d\n", (caller)[2]);
  24     }
  25
  26     return ($ok);
  27 }
  28
  29 BEGIN {
  30     $| = 1;
  31     print("1..19\n");    ### Number of tests that will be run ###
  32 }
  33
  34 use Scalar::Util qw(dualvar);
  35
  36 use threads;
  37 use threads::shared;
  38
  39 ok(1, 1, 'Loaded');
  40
  41 ### Start of Testing ###
  42
  43 my $dv = dualvar(42, 'Fourty-Two');
  44 my $pi = dualvar(3.14, 'PI');
  45
  46 my @a :shared;
  47
  48 # Individual assignment
  49 # Verify that dualvar preserved during individual element assignment
  50 $a[0] = $dv;
  51 $a[1] = $pi;
  52
  53 ok(2, $a[0] == 42, 'IV number preserved');
  54 ok(3, $a[0] eq 'Fourty-Two', 'string preserved');
  55 ok(4, $a[1] == 3.14, 'NV number preserved');
  56 ok(5, $a[1] eq 'PI', 'string preserved');
  57
  58 #-- List initializer
  59 # Verify that dualvar preserved during initialization
  60 my @a2 :shared = ($dv, $pi);
  61
  62 ok(6, $a2[0] == 42, 'IV number preserved');
  63 ok(7, $a2[0] eq 'Fourty-Two', 'string preserved');
  64 ok(8, $a2[1] == 3.14, 'NV number preserved');
  65 ok(9, $a2[1] eq 'PI', 'string preserved');
  66
  67 #-- List assignment
  68 # Verify that dualvar preserved during list assignment
  69 my @a3 :shared = (0, 0);
  70 @a3 = ($dv, $pi);
  71
  72 ok(10, $a3[0] == 42, 'IV number preserved');
  73 ok(11, $a3[0] eq 'Fourty-Two', 'string preserved');
  74 ok(12, $a3[1] == 3.14, 'NV number preserved');
  75 ok(13, $a3[1] eq 'PI', 'string preserved');
  76
  77 # Back to non-shared
  78 # Verify that entries are still dualvar when leaving the array
  79 my @nsa = @a3;
  80 ok(14, $nsa[0] == 42, 'IV number preserved');
  81 ok(15, $nsa[0] eq 'Fourty-Two', 'string preserved');
  82 ok(16, $nsa[1] == 3.14, 'NV number preserved');
  83 ok(17, $nsa[1] eq 'PI', 'string preserved');
  84
  85 # $! behaves like a dualvar, but is really implemented as a tied SV.
  86 # As a result sharing $! directly only propagates the string value.
  87 # However, we can create a dualvar from it.
  88 $! = 1;
  89 my $ss :shared = dualvar($!,$!);
  90 ok(18, $ss == 1, 'IV number preserved');
  91 ok(19, $ss eq $!, 'string preserved');
  92
  93 exit(0);