[p5sagit/p5-mst-13.2.git] / ext / threads / shared / t / waithires.t

use strict;
use warnings;

BEGIN {
    if ($ENV{'PERL_CORE'}){
        chdir 't';
        unshift @INC, '../lib';
    }
    use Config;
    if (! $Config{'useithreads'}) {
        print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
        exit(0);
    }
    eval {
        require Time::HiRes;
        Time::HiRes->import('time');
    };
    if ($@) {
        print("1..0 # SKIP Time::HiRes not available.\n");
        exit(0);
    }
}

use ExtUtils::testlib;

my $Base = 0;
sub ok {
    my ($id, $ok, $name) = @_;
    $id += $Base;

    # You have to do it this way or VMS will get confused.
    if ($ok) {
        print("ok $id - $name\n");
    } else {
        print("not ok $id - $name\n");
        printf("# Failed test at line %d\n", (caller)[2]);
    }

    return ($ok);
}

BEGIN {
    $| = 1;
    print("1..57\n");   ### Number of tests that will be run ###
};

use threads;
use threads::shared;

ok(1, 1, 'Loaded');
$Base++;

### Start of Testing ###

# subsecond cond_timedwait extended tests adapted from wait.t

# The two skips later on in these tests refer to this quote from the
# pod/perl583delta.pod:
#
# =head1 Platform Specific Problems
#
# The regression test ext/threads/shared/t/wait.t fails on early RedHat 9
# and HP-UX 10.20 due to bugs in their threading implementations.
# RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html
# and consider upgrading their glibc.


sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in
                 # stock RH9 glibc/NPTL) or from our own errors, we run tests
                 # in separately forked and alarmed processes.

*forko = ($^O =~ /^dos|os2|mswin32|netware|vms$/i)
? sub (&$$) { my $code = shift; goto &$code; }
: sub (&$$) {
  my ($code, $expected, $patience) = @_;
  my ($test_num, $pid);
  local *CHLD;

  my $bump = $expected;

  unless (defined($pid = open(CHLD, "-|"))) {
    die "fork: $!\n";
  }
  if (! $pid) {   # Child -- run the test
    alarm($patience || 60);
    &$code;
    exit;
  }

  while (<CHLD>) {
    $expected--, $test_num=$1 if /^(?:not )?ok (\d+)/;
    #print "#forko: ($expected, $1) $_";
    print;
  }

  close(CHLD);

  while ($expected--) {
    ok(++$test_num, 0, "missing test result: child status $?");
  }

  $Base += $bump;
};


# - TEST basics

my @wait_how = (
   "simple",  # cond var == lock var; implicit lock; e.g.: cond_wait($c)
   "repeat",  # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
   "twain"    # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
);

SYNC_SHARED: {
  my $test : shared;  # simple|repeat|twain
  my $cond : shared;
  my $lock : shared;

  ok(1, 1, "Shared synchronization tests preparation");
  $Base += 1;

  sub signaller {
    ok(2,1,"$test: child before lock");
    $test =~ /twain/ ? lock($lock) : lock($cond);
    ok(3,1,"$test: child obtained lock");
    if ($test =~ 'twain') {
      no warnings 'threads';   # lock var != cond var, so disable warnings
      cond_signal($cond);
    } else {
      cond_signal($cond);
    }
    ok(4,1,"$test: child signalled condition");
  }

  # - TEST cond_timedwait success

  forko( sub {
    foreach (@wait_how) {
      $test = "cond_timedwait [$_]";
      threads->create(\&ctw, 0.05)->join;
      $Base += 5;
    }
  }, 5*@wait_how, 5);

  sub ctw($) {
      my $to = shift;

      # which lock to obtain?
      $test =~ /twain/ ? lock($lock) : lock($cond);
      ok(1,1, "$test: obtained initial lock");

      my $thr = threads->create(\&signaller);
      my $ok = 0;
      for ($test) {
        $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
        $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
        $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
        die "$test: unknown test\n";
      }
      $thr->join;
      ok(5,$ok, "$test: condition obtained");
  }

  # - TEST cond_timedwait timeout

  forko( sub {
    foreach (@wait_how) {
      $test = "cond_timedwait pause, timeout [$_]";
      threads->create(\&ctw_fail, 0.3)->join;
      $Base += 2;
    }
  }, 2*@wait_how, 5);

  forko( sub {
    foreach (@wait_how) {
      $test = "cond_timedwait instant timeout [$_]";
      threads->create(\&ctw_fail, -0.60)->join;
      $Base += 2;
    }
  }, 2*@wait_how, 5);

  # cond_timedwait timeout (relative timeout)
  sub ctw_fail {
    my $to = shift;
    if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
      # The lock obtaining would pass, but the wait will not.
      ok(1,1, "$test: obtained initial lock");
      ok(2,0, "# SKIP see perl583delta");
    } else {
      $test =~ /twain/ ? lock($lock) : lock($cond);
      ok(1,1, "$test: obtained initial lock");
      my $ok;
      my $delta = time();
      for ($test) {
        $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
        $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
        $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
        die "$test: unknown test\n";
      }
      $delta = time() - $delta;
      ok(2, ! defined($ok), "$test: timeout");

      if (($to > 0) && ($^O ne 'os2')) {
        # Timing tests can be problematic
        if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
          print(STDERR "# Timeout: specified=$to  actual=$delta secs.\n");
        }
      }
    }
  }

} # -- SYNCH_SHARED block


# same as above, but with references to lock and cond vars

SYNCH_REFS: {
  my $test : shared;  # simple|repeat|twain

  my $true_cond; share($true_cond);
  my $true_lock; share($true_lock);

  my $cond = \$true_cond;
  my $lock = \$true_lock;

  ok(1, 1, "Synchronization reference tests preparation");
  $Base += 1;

  sub signaller2 {
    ok(2,1,"$test: child before lock");
    $test =~ /twain/ ? lock($lock) : lock($cond);
    ok(3,1,"$test: child obtained lock");
    if ($test =~ 'twain') {
      no warnings 'threads';   # lock var != cond var, so disable warnings
      cond_signal($cond);
    } else {
      cond_signal($cond);
    }
    ok(4,1,"$test: child signalled condition");
  }

  # - TEST cond_timedwait success

  forko( sub {
    foreach (@wait_how) {
      $test = "cond_timedwait [$_]";
      threads->create(\&ctw2, 0.05)->join;
      $Base += 5;
    }
  }, 5*@wait_how, 5);

  sub ctw2($) {
      my $to = shift;

      # which lock to obtain?
      $test =~ /twain/ ? lock($lock) : lock($cond);
      ok(1,1, "$test: obtained initial lock");

      my $thr = threads->create(\&signaller2);
      my $ok = 0;
      for ($test) {
        $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
        $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
        $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
        die "$test: unknown test\n";
      }
      $thr->join;
      ok(5,$ok, "$test: condition obtained");
  }

  # - TEST cond_timedwait timeout

  forko( sub {
    foreach (@wait_how) {
      $test = "cond_timedwait pause, timeout [$_]";
      threads->create(\&ctw_fail2, 0.3)->join;
      $Base += 2;
    }
  }, 2*@wait_how, 5);

  forko( sub {
    foreach (@wait_how) {
      $test = "cond_timedwait instant timeout [$_]";
      threads->create(\&ctw_fail2, -0.60)->join;
      $Base += 2;
    }
  }, 2*@wait_how, 5);

  sub ctw_fail2 {
    my $to = shift;

    if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
      # The lock obtaining would pass, but the wait will not.
      ok(1,1, "$test: obtained initial lock");
      ok(2,0, "# SKIP see perl583delta");
    } else {
      $test =~ /twain/ ? lock($lock) : lock($cond);
      ok(1,1, "$test: obtained initial lock");
      my $ok;
      my $delta = time();
      for ($test) {
        $ok=cond_timedwait($cond, time() + $to), last        if    /simple/;
        $ok=cond_timedwait($cond, time() + $to, $cond), last if    /repeat/;
        $ok=cond_timedwait($cond, time() + $to, $lock), last if    /twain/;
        die "$test: unknown test\n";
      }
      $delta = time() - $delta;
      ok(2, ! $ok, "$test: timeout");

      if (($to > 0) && ($^O ne 'os2')) {
        # Timing tests can be problematic
        if (($delta < (0.9 * $to)) || ($delta > (1.0 + $to))) {
          print(STDERR "# Timeout: specified=$to  actual=$delta secs.\n");
        }
      }
    }
  }

} # -- SYNCH_REFS block

exit(0);

# EOF
Commit	Line	Data
2a6601ce	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'}) {
6c791b15	11	print("1..0 # SKIP Perl not compiled with 'useithreads'\n");
2a6601ce	12	exit(0);
	13	}
	14	eval {
	15	require Time::HiRes;
7c8caac0	16	Time::HiRes->import('time');
2a6601ce	17	};
2a6601ce	18	if ($@) {
6c791b15	19	print("1..0 # SKIP Time::HiRes not available.\n");
2a6601ce	20	exit(0);
	21	}
	22	}
	23
	24	use ExtUtils::testlib;
	25
	26	my $Base = 0;
	27	sub ok {
	28	my ($id, $ok, $name) = @_;
	29	$id += $Base;
	30
	31	# You have to do it this way or VMS will get confused.
	32	if ($ok) {
	33	print("ok $id - $name\n");
	34	} else {
	35	print("not ok $id - $name\n");
	36	printf("# Failed test at line %d\n", (caller)[2]);
	37	}
	38
	39	return ($ok);
	40	}
	41
	42	BEGIN {
	43	$\| = 1;
f38680ff	44	print("1..57\n"); ### Number of tests that will be run ###
2a6601ce	45	};
	46
	47	use threads;
	48	use threads::shared;
	49
	50	ok(1, 1, 'Loaded');
	51	$Base++;
	52
	53	### Start of Testing ###
	54
	55	# subsecond cond_timedwait extended tests adapted from wait.t
	56
	57	# The two skips later on in these tests refer to this quote from the
	58	# pod/perl583delta.pod:
	59	#
	60	# =head1 Platform Specific Problems
	61	#
	62	# The regression test ext/threads/shared/t/wait.t fails on early RedHat 9
	63	# and HP-UX 10.20 due to bugs in their threading implementations.
	64	# RedHat users should see https://rhn.redhat.com/errata/RHBA-2003-136.html
	65	# and consider upgrading their glibc.
	66
f38680ff	67
2a6601ce	68	sub forko (&$$); # To prevent deadlock from underlying pthread_* bugs (as in
	69	# stock RH9 glibc/NPTL) or from our own errors, we run tests
	70	# in separately forked and alarmed processes.
	71
	72	*forko = ($^O =~ /^dos\|os2\|mswin32\|netware\|vms$/i)
	73	? sub (&$$) { my $code = shift; goto &$code; }
	74	: sub (&$$) {
	75	my ($code, $expected, $patience) = @_;
	76	my ($test_num, $pid);
	77	local *CHLD;
	78
	79	my $bump = $expected;
	80
2a6601ce	81	unless (defined($pid = open(CHLD, "-\|"))) {
	82	die "fork: $!\n";
	83	}
	84	if (! $pid) { # Child -- run the test
f38680ff	85	alarm($patience \|\| 60);
2a6601ce	86	&$code;
	87	exit;
	88	}
	89
	90	while (<CHLD>) {
	91	$expected--, $test_num=$1 if /^(?:not )?ok (\d+)/;
	92	#print "#forko: ($expected, $1) $_";
	93	print;
	94	}
	95
	96	close(CHLD);
	97
	98	while ($expected--) {
f38680ff	99	ok(++$test_num, 0, "missing test result: child status $?");
2a6601ce	100	}
	101
	102	$Base += $bump;
2a6601ce	103	};
2a6601ce	104
f38680ff	105
2a6601ce	106	# - TEST basics
	107
	108	my @wait_how = (
	109	"simple", # cond var == lock var; implicit lock; e.g.: cond_wait($c)
	110	"repeat", # cond var == lock var; explicit lock; e.g.: cond_wait($c, $c)
	111	"twain" # cond var != lock var; explicit lock; e.g.: cond_wait($c, $l)
	112	);
	113
	114	SYNC_SHARED: {
	115	my $test : shared; # simple\|repeat\|twain
	116	my $cond : shared;
	117	my $lock : shared;
	118
	119	ok(1, 1, "Shared synchronization tests preparation");
	120	$Base += 1;
	121
	122	sub signaller {
	123	ok(2,1,"$test: child before lock");
	124	$test =~ /twain/ ? lock($lock) : lock($cond);
	125	ok(3,1,"$test: child obtained lock");
	126	if ($test =~ 'twain') {
	127	no warnings 'threads'; # lock var != cond var, so disable warnings
	128	cond_signal($cond);
	129	} else {
	130	cond_signal($cond);
	131	}
	132	ok(4,1,"$test: child signalled condition");
	133	}
	134
	135	# - TEST cond_timedwait success
	136
	137	forko( sub {
	138	foreach (@wait_how) {
	139	$test = "cond_timedwait [$_]";
	140	threads->create(\&ctw, 0.05)->join;
f38680ff	141	$Base += 5;
2a6601ce	142	}
f38680ff	143	}, 5*@wait_how, 5);
2a6601ce	144
2a6601ce	145	sub ctw($) {
f38680ff	146	my $to = shift;
2a6601ce	147
f38680ff	148	# which lock to obtain?
2a6601ce	149	$test =~ /twain/ ? lock($lock) : lock($cond);
	150	ok(1,1, "$test: obtained initial lock");
	151
f38680ff	152	my $thr = threads->create(\&signaller);
2a6601ce	153	my $ok = 0;
	154	for ($test) {
	155	$ok=cond_timedwait($cond, time() + $to), last if /simple/;
	156	$ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
	157	$ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
	158	die "$test: unknown test\n";
	159	}
f38680ff	160	$thr->join;
2a6601ce	161	ok(5,$ok, "$test: condition obtained");
2a6601ce	162	}
	163
	164	# - TEST cond_timedwait timeout
	165
	166	forko( sub {
	167	foreach (@wait_how) {
	168	$test = "cond_timedwait pause, timeout [$_]";
	169	threads->create(\&ctw_fail, 0.3)->join;
	170	$Base += 2;
	171	}
	172	}, 2*@wait_how, 5);
	173
	174	forko( sub {
	175	foreach (@wait_how) {
	176	$test = "cond_timedwait instant timeout [$_]";
	177	threads->create(\&ctw_fail, -0.60)->join;
	178	$Base += 2;
	179	}
	180	}, 2*@wait_how, 5);
	181
	182	# cond_timedwait timeout (relative timeout)
	183	sub ctw_fail {
	184	my $to = shift;
	185	if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
	186	# The lock obtaining would pass, but the wait will not.
	187	ok(1,1, "$test: obtained initial lock");
	188	ok(2,0, "# SKIP see perl583delta");
	189	} else {
	190	$test =~ /twain/ ? lock($lock) : lock($cond);
	191	ok(1,1, "$test: obtained initial lock");
	192	my $ok;
	193	my $delta = time();
	194	for ($test) {
	195	$ok=cond_timedwait($cond, time() + $to), last if /simple/;
	196	$ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
	197	$ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
	198	die "$test: unknown test\n";
	199	}
	200	$delta = time() - $delta;
27aad8a3	201	ok(2, ! defined($ok), "$test: timeout");
	202
	203	if (($to > 0) && ($^O ne 'os2')) {
	204	# Timing tests can be problematic
	205	if (($delta < (0.9 * $to)) \|\| ($delta > (1.0 + $to))) {
	206	print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
2a6601ce	207	}
	208	}
	209	}
	210	}
	211
	212	} # -- SYNCH_SHARED block
	213
	214
	215	# same as above, but with references to lock and cond vars
	216
	217	SYNCH_REFS: {
	218	my $test : shared; # simple\|repeat\|twain
	219
	220	my $true_cond; share($true_cond);
	221	my $true_lock; share($true_lock);
	222
	223	my $cond = \$true_cond;
	224	my $lock = \$true_lock;
	225
	226	ok(1, 1, "Synchronization reference tests preparation");
	227	$Base += 1;
	228
	229	sub signaller2 {
	230	ok(2,1,"$test: child before lock");
	231	$test =~ /twain/ ? lock($lock) : lock($cond);
	232	ok(3,1,"$test: child obtained lock");
	233	if ($test =~ 'twain') {
	234	no warnings 'threads'; # lock var != cond var, so disable warnings
	235	cond_signal($cond);
	236	} else {
	237	cond_signal($cond);
	238	}
	239	ok(4,1,"$test: child signalled condition");
	240	}
	241
	242	# - TEST cond_timedwait success
	243
	244	forko( sub {
	245	foreach (@wait_how) {
	246	$test = "cond_timedwait [$_]";
	247	threads->create(\&ctw2, 0.05)->join;
f38680ff	248	$Base += 5;
2a6601ce	249	}
f38680ff	250	}, 5*@wait_how, 5);
2a6601ce	251
2a6601ce	252	sub ctw2($) {
f38680ff	253	my $to = shift;
2a6601ce	254
f38680ff	255	# which lock to obtain?
2a6601ce	256	$test =~ /twain/ ? lock($lock) : lock($cond);
	257	ok(1,1, "$test: obtained initial lock");
	258
f38680ff	259	my $thr = threads->create(\&signaller2);
2a6601ce	260	my $ok = 0;
	261	for ($test) {
	262	$ok=cond_timedwait($cond, time() + $to), last if /simple/;
	263	$ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
	264	$ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
	265	die "$test: unknown test\n";
	266	}
f38680ff	267	$thr->join;
2a6601ce	268	ok(5,$ok, "$test: condition obtained");
2a6601ce	269	}
	270
	271	# - TEST cond_timedwait timeout
	272
	273	forko( sub {
	274	foreach (@wait_how) {
	275	$test = "cond_timedwait pause, timeout [$_]";
	276	threads->create(\&ctw_fail2, 0.3)->join;
	277	$Base += 2;
	278	}
	279	}, 2*@wait_how, 5);
	280
	281	forko( sub {
	282	foreach (@wait_how) {
	283	$test = "cond_timedwait instant timeout [$_]";
	284	threads->create(\&ctw_fail2, -0.60)->join;
	285	$Base += 2;
	286	}
	287	}, 2*@wait_how, 5);
	288
	289	sub ctw_fail2 {
	290	my $to = shift;
	291
	292	if ($^O eq "hpux" && $Config{osvers} <= 10.20) {
	293	# The lock obtaining would pass, but the wait will not.
	294	ok(1,1, "$test: obtained initial lock");
	295	ok(2,0, "# SKIP see perl583delta");
	296	} else {
	297	$test =~ /twain/ ? lock($lock) : lock($cond);
	298	ok(1,1, "$test: obtained initial lock");
	299	my $ok;
	300	my $delta = time();
	301	for ($test) {
	302	$ok=cond_timedwait($cond, time() + $to), last if /simple/;
	303	$ok=cond_timedwait($cond, time() + $to, $cond), last if /repeat/;
	304	$ok=cond_timedwait($cond, time() + $to, $lock), last if /twain/;
	305	die "$test: unknown test\n";
	306	}
	307	$delta = time() - $delta;
27aad8a3	308	ok(2, ! $ok, "$test: timeout");
	309
	310	if (($to > 0) && ($^O ne 'os2')) {
	311	# Timing tests can be problematic
	312	if (($delta < (0.9 * $to)) \|\| ($delta > (1.0 + $to))) {
	313	print(STDERR "# Timeout: specified=$to actual=$delta secs.\n");
2a6601ce	314	}
	315	}
	316	}
	317	}
	318
	319	} # -- SYNCH_REFS block
	320
6c791b15	321	exit(0);
6c791b15	322
2a6601ce	323	# EOF