view release on metacpan or  search on metacpan

t/t_TestCommon.pm  view on Meta::CPAN

      -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) = @_;
  my ($fh, $path) = mytempfile(@tfargs);
  dprint "> Creating $path\n";
  print $fh $string;
  $fh->flush;
  seek($fh,0,0) or die "seek $path : $!";
  wantarray ? ($path,$fh) : $path
}

# Run a Perl script in a sub-process.
#
# Provides -I options to mimic @INC (PERL5LIB is often not set)
#
# -CIOE is passed to make stdio UTF-8 regardless of the actual test
# environment, but if the script does e.g. "use open ':locale'" it will
# override that.   I'm forcing LC_ALL=C so things like date and number
# formats will be predictable for testing.
#
# This is usually enclosed in Capture::Tiny::capture { ... }
#
#    ==> IMPORTANT: Be sure STDOUT/ERR has :encoding(...) set beforehand
#        because Capture::Tiny will decode captured output the same way.
#        Otherwise wide chars will be corrupted
#
#
require Carp::Always;
sub run_perlscript(@) {
  my @tfs; # keep in scope until no longer needed
  my @perlargs = ("-CIOE", @_);
  @perlargs = ((map{ "-I$_" } @INC), @perlargs);
  #unshift @perlargs, "-MCarp=verbose" if $Carp::Verbose;
  #unshift @perlargs, "-MCarp::Always=verbose" if $Carp::Always::Verbose;

  ##This breaks no-internals-mentioned (AUTHOR_TESTS) in Spreadsheet::Edit
  ## For unknown reason some smokers running older perls die with
  ## "...undef value as a subroutine reference at site_perl/5.20.3/TAP/Harness.pm line 612
  ## So trying to see what is happening...
  #unshift @perlargs, "-MCarp::Always=verbose";

  if ($^O eq "MSWin32") {
    for (my $ix=0; $ix <= $#perlargs; $ix++) {
      if ($perlargs[$ix] =~ /^-(w?)([Ee])$/) {
        # Passing perl code in an argument is impractical in DOS/Windows
        my $tf = Path::Tiny->tempfile("perlcode_XXXXX");
        push @tfs, $tf;
        # N.B. -e (not -E) can be an arg to odfedit as well
        $tf->append_utf8("use feature qw/:all/;\n") if $2 eq 'E';
        $tf->append_utf8($perlargs[$ix+1]);
warn "============= DUMP OF -$1$2 FILE ===========\n", "".scalar($tf->slurp_utf8), "\n=============(end)============\n" if $debug;
        splice @perlargs, $ix, 2, ($1 ? ("-w") : ()), $tf->canonpath;
        $ix += 2;
      }
    }
    for (my $ix=0; $ix <= $#perlargs; $ix++) {
      for ($perlargs[$ix]) {
        if (/^-[eE]/ or /^-[^-CIM].*[Ee]/) { oops "unhandled perl arg '$_'" }
        s/"/\\"/g;
        if (/[\s\/"']/) {
          $_ = '"' . $_ . '"';
        }
      }
    }
  }

  local $ENV{LC_ALL} = "C";
  my $perlexe = $Config{perlpath}; # some say $^X is not reliable

  if ($debug) {
    my $msg = "%%% run_perlscript >";
    for my $k (sort keys %ENV) {
      next unless $k =~ /^(LC|LANG)/;
      $msg .= " $k='$ENV{$k}'"
    }
    $msg .= " $perlexe";
    $msg .= " <<${_}>>" foreach (@perlargs);