view release on metacpan or  search on metacpan

t/modules.pm  view on Meta::CPAN

# -*- cperl -*-
use strict;
BEGIN {
  unshift @INC, 't';
}
require TestBC;
use Test::More;
use Config;
use Cwd;
use Exporter;
our @ISA     = qw(Exporter);
our @EXPORT = qw(%modules $keep
		 perlversion
		 percent log_diag log_pass log_err get_module_list
                 random_sublist is_subset
		);
our (%modules);
our $log = 0;
our $keep = '';

sub perlversion {
  my $DEBUGGING = ($Config{ccflags} =~ m/-DDEBUGGING/);
  my $dVAR = ($Config{ccflags} =~ m/-DPERL_GLOBAL_STRUCT/);
  return sprintf("%1.6f%s%s%s%s", $],
                 ($Config{usecperl} ? "c" : ""),
                 ($DEBUGGING ? 'd' : ''),
                 ($Config{useithreads} ? ''
                  : $Config{usemultiplicity} ? '-m'
                  : '-nt'),
                 ($dVAR ? '-dVAR' : '')
                 );
}

sub percent {
  $_[1] ? sprintf("%0.1f%%", $_[0]*100/$_[1]) : '';
}

sub log_diag {
  my $message = shift;
  chomp $message;
  diag( $message );
  return unless $log;

  foreach ($log, "$log.err") {
    open(LOG, ">>", $_);
    $message =~ s/\n./\n# /xmsg;
    print LOG "# $message\n";
    close LOG;
  }
}

sub log_pass {
  my ($pass_msg, $module, $todo) = @_;
  return unless $log;

  if ($todo) {
    $todo = " #TODO $todo";
  } else {
    $todo = '';
  }

  diag( "$pass_msg $module$todo" );
  open(LOG, ">>", "$log");
  print LOG "$pass_msg $module$todo\n";
  close LOG;
}

sub log_err {
  my ($module, $out, $err) = @_;
  return if(!$log);

  # diag prints for TODO to a special todo fh, which does not end at the console
  # ignore diag the TODO empty STDERR test for now. we diag the ok test only
  # diag( "fail $module $out" );
  # Test::More->builder->_print_comment( Test::More->builder->failure_output, "fail $module $out" );

  $_ =~ s/\n/\n# /xmsg foreach($out, $err); # Format for comments

  open(ERR, ">>", "$log.err");
  print ERR "Failed $module\n";
  print ERR "# No output\n" if(!$out && !$err);
  print ERR "# STDOUT:\n# $out\n" if($out && $out ne 'ok');
  print ERR "# STDERR:\n# $err\n" if($err);
  close ERR;
}

sub is_subset {
  return 0 if grep /^-no-subset$/, @ARGV;
  return ! (-d '.svn' or -d'.git') || grep /^-subset$/, @ARGV;
}

sub get_module_list {
  # Parse for command line modules and use this if seen.
  my @modules = grep {$_ !~ /^-([\w-]+)$/} @ARGV; # ignore options