view release on metacpan or  search on metacpan

t/t_TestCommon.pm  view on Meta::CPAN

  if @ARGV && $debug;

$dvs{debug}   = $debug   if defined($debug);
$dvs{verbose} = $verbose if defined($verbose);
$dvs{silent}  = $silent  if defined($silent);

if ($nonrandom) {
  # This must run before Test::More or Test2::V0 is loaded!!
  # Normally this is the case because our package body is executed before
  # import() is called.
  if (open my $fh, "<", "/proc/sys/kernel/randomize_va_space") {
    chomp(my $setting = <$fh>);
    unless($setting eq "0") {
      warn "WARNING: Kernel address space randomization is in effect.\n";
      warn "To disable:  echo 0 | sudo tee /proc/sys/kernel/randomize_va_space\n";
      warn "To re-enable echo 2 | sudo tee /proc/sys/kernel/randomize_va_space\n";
    }
  }
  unless (($ENV{PERL_PERTURB_KEYS}//"") eq "2") {
    $ENV{PERL_PERTURB_KEYS} = "2"; # deterministic
    $ENV{PERL_HASH_SEED} = "0xDEADBEEF";
    #$ENV{PERL_HASH_SEED_DEBUG} = "1";
    @PERL5LIB = @INC; # cf 'use Env' above
    # https://web.archive.org/web/20160308025634/http://wiki.cpantesters.org/wiki/cpanauthornotes
    exec $Config{perlpath}, $0, @orig_ARGV; # for reproducible results
  }
}

# Return a Path::Tiny object to a temporary directory, which may be
# specified with the --workdir command-line arg.
sub tdir() {
  state $tdir;
  if (! $tdir) {
    if ($workdir) {
      $workdir = path($workdir);
      if ($workdir->exists) {
        warn("# Removing old workdir ", qsh($workdir),"\n");
        $workdir->remove_tree;
      }
      $tdir = $workdir->mkdir;
    } else {
      $tdir = Path::Tiny->tempdir();
    }
  };
  $tdir
}

sub import {
  my $target = caller;

  my %tags;
  for (my $ix=0; $ix <= $#_; $ix++) {
    if ($_[$ix] =~ /^(:.*)$/) {
      next if $_[$ix] eq ":DEFAULT"; # ok, pass thru to Exporter
      $tags{$1} = 1;
      splice @_, $ix, 1, ();
      redo unless $ix > $#_;
    }
  }

  # Do an initial read of $[ so arybase will be autoloaded
  # (prevents corrupting $!/ERRNO in subsequent tests)
  eval '$[' // die;

  # Test2::V0
  #  Do not import warnings, to avoid un-doing prior settings.
  #  Do not inport 1- and 2- or 3- character upper-case names, which are
  #  likely to clash with user variables and/or spreadsheet column letters
  #  (when using Spreadsheet::Edit).
  #
  #  The :no-Test2 tag is used by subtest .pl scripts which must not
  #  generate any Test2 events!
  unless (delete $tags{":no-Test2"}) {
    require Test2::V0; # a huge collection of tools (n.b. version is in dist.ini)
    Test2::V0->VERSION(1.302214);  # AutoPrereqs *does* see this!
    Test2::V0->import::into($target,
      -no_warnings => 1,
      (map{ "!$_" } "A".."AAZ")
    );
    if ($nobail) {
      say "> NOT requiring BailOnFail"
    } else {
      require Test2::Plugin::BailOnFail;
      # Stop on the first error
      Test2::Plugin::BailOnFail->import::into($target);
    }
  }
  utf8->import::into($target);

  if (delete $tags{":silent"}) {
    _start_silent() unless $debug;
  }

  die "Unhandled tag ",keys(%tags) if keys(%tags);

  # chain to Exporter to export any other importable items
  goto &Exporter::import
}

# Avoid turning on Test2 if not otherwise used...
sub dprint(@)   { print(@_)                if $debug };
sub dprintf($@) { printf($_[0],@_[1..$#_]) if $debug };

sub arrays_eq($$) {
  my ($a,$b) = @_;
  return 0 unless @$a == @$b;
  for(my $i=0; $i <= $#$a; $i++) {
    return 0 unless $a->[$i] eq $b->[$i];
  }
  return 1;
}

sub hash_subset($@) {
  my ($hash, @keys) = @_;
  return undef if ! defined $hash;
  return { map { exists($hash->{$_}) ? ($_ => $hash->{$_}) : () } @keys }
}

# string_to_tempfile($string, args => for-mytempfile)
# string_to_tempfile($string, pseudo_template) # see mytempfile
#
sub string_to_tempfile($@) {
  my ($string, @tfargs) = @_;