view release on metacpan or  search on metacpan

lib/ASNMTAP/Asnmtap/Plugins/NPTest.pm  view on Meta::CPAN

  my $pwd = cwd();

  if ( $pwd =~ m|/t$| )
  {
    return $pwd;

    # The alternate that might work better is
    # chdir( ".." );
    # return "./t";
    # As the current test harnesses assume the application
    # to be tested is in the current directory (ie "./check_disk ....")
  }

  return undef;
}

sub TestsFrom
{
  my( $directory, $excludeIfAppMissing ) = @_;

  $excludeIfAppMissing = 0 unless defined( $excludeIfAppMissing );

  if ( ! opendir( DIR, $directory ) )
  {
    print STDERR "NPTest::TestsFrom() - Failed to open ${directory} : $!\n";
    return ();
  }

  my( @tests ) = ();

  my $filename;
  my $application;

  while ( $filename = readdir( DIR ) )
  {
    if ( $filename =~ m/\.t$/ )
    {
      if ( $excludeIfAppMissing )
      {
	$application = basename( $filename, ".t" );
	if ( ! -e $application )
	{
	  print STDERR "No application (${application}) found for test harness (${filename})\n";
	  next;
	}
      }
      push @tests, "${directory}/${filename}";
    }
  }

  closedir( DIR );

  return sort @tests;
}

# All the new object oriented stuff below

sub new { 
	my $type = shift;
	my $self = {};
	return bless $self, $type;
}

# Accessors
sub return_code {
	my $self = shift;
	if (@_) {
		return $self->{return_code} = shift;
	} else {
		return $self->{return_code};
	}
}
sub output {
	my $self = shift;
	if (@_) {
		return $self->{output} = shift;
	} else {
		return $self->{output};
	}
}

sub perf_output {
	my $self = shift;
	$_ = $self->{output};
	/\|(.*)$/;
	return $1 || "";
}

sub only_output {
	my $self = shift;
	$_ = $self->{output};
	/(.*?)\|/;
	return $1 || "";
}

sub testCmd {
	my $class = shift;
	my $command = shift or die "No command passed to testCmd";
	my $object = $class->new;
	
	my $output = `$command`;
	$object->return_code($? >> 8);
	$_ = $? & 127;
	if ($_) {
		die "Got signal $_ for command $command";
	}
	chomp $output;
	$object->output($output);

	if ($ENV{'NPTEST_DEBUG'}) {
		my ($pkg, $file, $line) = caller(0);
		print "testCmd: Called from line $line in $file", $/;
		print "Testing: $command", $/;
		print "Output:  ", $object->output, $/;
		print "Return code: ", $object->return_code, $/;
	}

	return $object;
}

1;