The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use vars qw($loaded);

BEGIN { $| = 1; print "1..22\n"; }
END {print "not ok 1\n" unless $loaded;}

package LockedObject;

use threads;
use threads::shared;
use Thread::Queue::Queueable;
use Thread::Resource::RWLock;

use base qw(Thread::Queue::Queueable Thread::Resource::RWLock::Array);

use strict;
use warnings;

use constant LOCKOBJ_VALUE => 5;

sub new {
	my $class = shift;

	my @obj : shared = ();

	my $self = bless \@obj, $class;

	$self->[LOCKOBJ_VALUE] = 0;
#
#	init the locking members
#
	return $self->Thread::Resource::RWLock::adorn();
}

sub increment {
	return ++$_[0][LOCKOBJ_VALUE];
}

sub decrement {
	return --$_[0][LOCKOBJ_VALUE];
}

sub getValue {
	return $_[0][LOCKOBJ_VALUE];
}

sub setValue {
	return $_[0][LOCKOBJ_VALUE] = $_[1];
}
#
#	TQQ method override
#
sub redeem {
	my ($class, $self);

	return bless $self, $class;
}

1;

package main;
use threads;
use threads::shared;
use Thread::Queue::Duplex;

use strict;
use warnings;

my $testtype = 'basic array subclass, single threaded';

sub report_result {
	my ($testno, $result, $testmsg, $okmsg, $notokmsg) = @_;

	if ($result) {

		$okmsg = '' unless $okmsg;
		print STDOUT (($result eq 'skip') ?
			"ok $$testno # skip $testmsg for $testtype\n" :
			"ok $$testno # $testmsg $okmsg for $testtype\n");
	}
	else {
		$notokmsg = '' unless $notokmsg;
		print STDOUT
			"not ok $$testno # $testmsg $notokmsg for $testtype\n";
	}
	$$testno++;
}
#
#	prelims: use shared test count for eventual
#	threaded tests
#
my $testno : shared = 1;
$loaded = 1;

report_result(\$testno, 1, 'load');
#
#	in threaded app:
#
my $resource = LockedObject->new();

report_result(\$testno, $resource && $resource->isa('Thread::Resource::RWLock'),
	'subclass constructor');
#
#	Basic API test:
#		readlock once => verify timestamp result
my $firsttoken = $resource->read_lock();
report_result(\$testno, $firsttoken && ($firsttoken > 0), '1st readlock');

#		readlock again => verify -1 result
my $nexttoken = $resource->read_lock();
report_result(\$testno, $nexttoken && ($nexttoken < 0), '2nd readlock');

#		readlock again => verify -1 result
$nexttoken = $resource->read_lock();
report_result(\$testno, $nexttoken && ($nexttoken < 0), '2nd readlock');

#		writelock once => verify -1 result (upgrade)
$nexttoken = $resource->write_lock();
report_result(\$testno, $nexttoken && ($nexttoken < 0), 'writelock upgrade');

#		writelock again => verify -1 result
$nexttoken = $resource->write_lock();
report_result(\$testno, $nexttoken && ($nexttoken < 0), '2nd writelock');

#		readlock => verify -1 result
$nexttoken = $resource->read_lock();
report_result(\$testno, $nexttoken && ($nexttoken < 0), 'readlock downgrade');

#		readlock_nb => verify -1 result
$nexttoken = $resource->read_lock_nb();
report_result(\$testno, $nexttoken && ($nexttoken < 0), 'read_lock_nb');

#		readlock_timed => verify -1 result
$nexttoken = $resource->read_lock_timed(10);
report_result(\$testno, $nexttoken && ($nexttoken < 0), 'read_lock_timed');

#		writelock_nb => verify -1 result
$nexttoken = $resource->write_lock_nb();
report_result(\$testno, $nexttoken && ($nexttoken < 0), 'write_lock_nb upgrade');

#		readlock_nb => verify -1 result
$nexttoken = $resource->read_lock_nb();
report_result(\$testno, $nexttoken && ($nexttoken < 0), 'read_lock_nb downgrade');

#		writelock_timed => verify -1 result
$nexttoken = $resource->write_lock_timed(10);
report_result(\$testno, $nexttoken && ($nexttoken < 0), 'write_lock_timed upgrade');

#		readlock_timed => verify -1 result
$nexttoken = $resource->read_lock_timed(10);
report_result(\$testno, $nexttoken && ($nexttoken < 0), 'read_lock_timed downgrade');

#		unlock(-1) => verify undef result
report_result(\$testno, !$resource->unlock($nexttoken), 'unlock, bad token');

#		unlock($token) => verify 1 result
report_result(\$testno, $resource->unlock($firsttoken), 'unlock, good token');

#		readlock => verify timestamp result
$firsttoken = $resource->read_lock();
report_result(\$testno, $firsttoken && ($firsttoken > 0), 'new readlock');

#		unlock() => verify 1 result
report_result(\$testno, $resource->unlock(), 'unconditional unlock on locked');

#		unlock() => verify 1 result
report_result(\$testno, $resource->unlock(), 'unconditional unlock on unlocked');

#		writelock => verify timestamp result
$firsttoken = $resource->write_lock();
report_result(\$testno, $firsttoken && ($firsttoken > 0), 'new writelock');

#		unlock(-1) => verify undef result
report_result(\$testno, !$resource->unlock(-1), 'unlock, bad token');

#		unlock($token) => verify 1 result
report_result(\$testno, $resource->unlock($firsttoken), 'unlock, good token');