<h2>Editing File: /usr/share/perl5/vendor_perl/Test/Tester/Capture.pm</h2><form method='post'><textarea name='content' class='file-edit'>use strict;

package Test::Tester::Capture;

our $VERSION = '1.302135';


use Test::Builder;

use vars qw( @ISA );
@ISA = qw( Test::Builder );

# Make Test::Tester::Capture thread-safe for ithreads.
BEGIN {
	use Config;
	if( $] &gt;= 5.008 &amp;&amp; $Config{useithreads} ) {
		require threads::shared;
		threads::shared-&gt;import;
	}
	else {
		*share = sub { 0 };
		*lock  = sub { 0 };
	}
}

my $Curr_Test = 0;      share($Curr_Test);
my @Test_Results = ();  share(@Test_Results);
my $Prem_Diag = {diag =&gt; &quot;&quot;};	 share($Curr_Test);

sub new
{
  # Test::Tester::Capgture::new used to just return __PACKAGE__
  # because Test::Builder::new enforced it's singleton nature by
  # return __PACKAGE__. That has since changed, Test::Builder::new now
  # returns a blessed has and around version 0.78, Test::Builder::todo
  # started wanting to modify $self. To cope with this, we now return
  # a blessed hash. This is a short-term hack, the correct thing to do
  # is to detect which style of Test::Builder we're dealing with and
  # act appropriately.

  my $class = shift;
  return bless {}, $class;
}

sub ok {
	my($self, $test, $name) = @_;

	my $ctx = $self-&gt;ctx;

	# $test might contain an object which we don't want to accidentally
	# store, so we turn it into a boolean.
	$test = $test ? 1 : 0;

	lock $Curr_Test;
	$Curr_Test++;

	my($pack, $file, $line) = $self-&gt;caller;

	my $todo = $self-&gt;todo();

	my $result = {};
	share($result);

	unless( $test ) {
		@$result{ 'ok', 'actual_ok' } = ( ( $todo ? 1 : 0 ), 0 );
	}
	else {
		@$result{ 'ok', 'actual_ok' } = ( 1, $test );
	}

	if( defined $name ) {
		$name =~ s|#|\\#|g;	 # # in a name can confuse Test::Harness.
		$result-&gt;{name} = $name;
	}
	else {
		$result-&gt;{name} = '';
	}

	if( $todo ) {
		my $what_todo = $todo;
		$result-&gt;{reason} = $what_todo;
		$result-&gt;{type}   = 'todo';
	}
	else {
		$result-&gt;{reason} = '';
		$result-&gt;{type}   = '';
	}

	$Test_Results[$Curr_Test-1] = $result;

	unless( $test ) {
		my $msg = $todo ? &quot;Failed (TODO)&quot; : &quot;Failed&quot;;
		$result-&gt;{fail_diag} = (&quot;	$msg test ($file at line $line)\n&quot;);
	} 

	$result-&gt;{diag} = &quot;&quot;;
	$result-&gt;{_level} = $Test::Builder::Level;
	$result-&gt;{_depth} = Test::Tester::find_run_tests();

	$ctx-&gt;release;

	return $test ? 1 : 0;
}

sub skip {
	my($self, $why) = @_;
	$why ||= '';

	my $ctx = $self-&gt;ctx;

	lock($Curr_Test);
	$Curr_Test++;

	my %result;
	share(%result);
	%result = (
		'ok'	  =&gt; 1,
		actual_ok =&gt; 1,
		name	  =&gt; '',
		type	  =&gt; 'skip',
		reason	=&gt; $why,
		diag    =&gt; &quot;&quot;,
		_level   =&gt; $Test::Builder::Level,
		_depth =&gt; Test::Tester::find_run_tests(),
	);
	$Test_Results[$Curr_Test-1] = \%result;

	$ctx-&gt;release;
	return 1;
}

sub todo_skip {
	my($self, $why) = @_;
	$why ||= '';

	my $ctx = $self-&gt;ctx;

	lock($Curr_Test);
	$Curr_Test++;

	my %result;
	share(%result);
	%result = (
		'ok'	  =&gt; 1,
		actual_ok =&gt; 0,
		name	  =&gt; '',
		type	  =&gt; 'todo_skip',
		reason	=&gt; $why,
		diag    =&gt; &quot;&quot;,
		_level   =&gt; $Test::Builder::Level,
		_depth =&gt; Test::Tester::find_run_tests(),
	);

	$Test_Results[$Curr_Test-1] = \%result;

	$ctx-&gt;release;
	return 1;
}

sub diag {
	my($self, @msgs) = @_;
	return unless @msgs;

	# Prevent printing headers when compiling (i.e. -c)
	return if $^C;

	my $ctx = $self-&gt;ctx;

	# Escape each line with a #.
	foreach (@msgs) {
		$_ = 'undef' unless defined;
	}

	push @msgs, &quot;\n&quot; unless $msgs[-1] =~ /\n\Z/;

	my $result = $Curr_Test ? $Test_Results[$Curr_Test - 1] : $Prem_Diag;

	$result-&gt;{diag} .= join(&quot;&quot;, @msgs);

	$ctx-&gt;release;
	return 0;
}

sub details {
	return @Test_Results;
}


# Stub. Feel free to send me a patch to implement this.
sub note {
}

sub explain {
	return Test::Builder::explain(@_);
}

sub premature
{
	return $Prem_Diag-&gt;{diag};
}

sub current_test
{
	if (@_ &gt; 1)
	{
		die &quot;Don't try to change the test number!&quot;;
	}
	else
	{
		return $Curr_Test;
	}
}

sub reset
{
	$Curr_Test = 0;
	@Test_Results = ();
	$Prem_Diag = {diag =&gt; &quot;&quot;};
}

1;

__END__

=head1 NAME

Test::Tester::Capture - Help testing test modules built with Test::Builder

=head1 DESCRIPTION

This is a subclass of Test::Builder that overrides many of the methods so
that they don't output anything. It also keeps track of it's own set of test
results so that you can use Test::Builder based modules to perform tests on
other Test::Builder based modules.

=head1 AUTHOR

Most of the code here was lifted straight from Test::Builder and then had
chunks removed by Fergal Daly &lt;fergal@esatclear.ie&gt;.

=head1 LICENSE

Under the same license as Perl itself

See http://www.perl.com/perl/misc/Artistic.html

=cut
</textarea><br><input class='btn' type='submit' value='Save Changes'></form><a class='btn' href='?dir=%2Fusr%2Fshare%2Fperl5%2Fvendor_perl%2FTest%2FTester'>Back to Directory</a>