The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
use vars qw($tests);
BEGIN {
	push @INC, './t';
	$tests = 2;

	$^W= 1;
	$| = 1;
	print STDERR "*** Note: this test executes for approx. 35 secs\n";
	print "1..$tests\n";
}

use Config;

#
# forks a child to run system('perl -d:STrace somescript.pl'),
#	which this process monitors
#
$ENV{DEVEL_RINGBUF_FILE} = 'plstrace_test.trace';

our $testtype = 'full monitor';

my $ringcnt = 8;

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++;
}

my $testno = 1;

my $cmd = ($Config{useithreads} && (!$ENV{DEVEL_RINGBUF_NOTHREADS})) ?
	(($^O eq 'MSWin32') ?
		"perl -w -d:STrace t\\tracetest.pl -t $ringcnt" :
		"perl -w -d:STrace t/tracetest.pl -t $ringcnt") :

	(($^O eq 'MSWin32') ?
		"perl -w -d:STrace t\\tracetestnt.pl -p $ringcnt" :
		"perl -w -d:STrace t/tracetestnt.pl -p $ringcnt");

#print STDERR "\n*** Running $cmd\n";

my $child1 = fork();

die "Can't fork tracing child: $!" unless defined $child1;

unless ($child1) {
	system($cmd);
	exit 1;
}
#
#	wait a while for things to get rolling
#
sleep 5;
monitor();

waitpid($child1, 0);

sub monitor {
	require Devel::STrace::Monitor;

	report_result(\$testno, 1, 'load');
#
#	process args
#
	my $interval = 10;
	my $duration = 30;
	my $file = $ENV{DEVEL_RINGBUF_FILE};

	my $view = Devel::STrace::Monitor->open($file)
		|| die $@;

#	print STDERR "Started $file\n";
	my ($started, $lastrefresh) = (time(), time());
	my $rings = $ringcnt;
	$rings++
		if ($Config{useithreads} && (!$ENV{DEVEL_RINGBUF_NOTHREADS}));
	my $ok = 1;
	my %keys = ();
	while ((time() - $started) < $duration) {
#		print "
#***********************************************
#*** At ", scalar localtime(), "
#";
		my $lastkey = '';
#
#	dump the current traces (for specified pid[:tid] if provided)
#
		$view->refresh();
		$view->trace(
			sub {
				my ($key, $slot, $depth, $line, $time, $entry) = @_;
				$keys{$key} = 1,
				$lastkey = $key
#				print STDERR "\n**************************************\n"
					unless ($lastkey eq $key);
				if ($time) {
					my $frac = ($time - int($time)) * 1000000;
					$frac=~s/\..*$//;
					my @parts = split(/\s+/, scalar localtime($time));
					pop @parts;	# get rid of year
#					print STDERR "$key($depth) : $slot : $entry:$line at ",
#						join(' ', @parts), '.', $frac, "\n";
				}
				else {
#					print STDERR "$key($depth) : $slot : $entry:$line (No timestamp)\n";
				}
			}
		);
#
#	verify we got hte number of distinct keys we expected
#
		unless ($rings == scalar keys %keys) {
#			print STDERR "rings is $rings and keys is ", scalar keys %keys, "\n";
#			$ok = undef, last
			$ok = undef;
		}

		sleep $interval;
	}
	report_result(\$testno, $ok, 'monitor test');
}