view release on metacpan or  search on metacpan

t/t_TestCommon.pm  view on Meta::CPAN

  }
  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);
    print STDERR "$msg\n";
  }
  my $wstat;
  if ($^O eq "MSWin32") {
    # This might avoid pseudo-forking
    my $prochandle = system(1, $perlexe, @perlargs); # see man perlport
    waitpid($prochandle, 0);
    $wstat = $?;
  } else {
    $wstat = system $perlexe, @perlargs;
  }
  print STDERR "%%%(returned from 'system', wstat=",sprintf("0x%04X",$wstat),")%%%\n" if $debug;
  $wstat
}

#--------------- :silent support ---------------------------
# N.B. It appears, experimentally, that output from ok(), like() and friends
# is not written to the test process's STDOUT or STDERR, so we do not need
# to worry about ignoring those normal outputs (somehow everything is
# merged at the right spots, presumably by a supervisory process).
# [Note May23: This was with Test::More may *NOT* be true with Test2::V0 !!]
#
# Therefore tests can be simply wrapped in silent{...} or the entire
# program via the ':silent' tag; however any "Silence expected..." diagnostics
# will appear at the end, perhaps long after the specific test case which
# emitted the undesired output.
my ($orig_stdOUT, $orig_stdERR, $orig_DIE_trap);
my ($inmem_stdOUT, $inmem_stdERR) = ("", "");
my $silent_mode;
use Encode qw/decode FB_WARN FB_PERLQQ FB_CROAK LEAVE_SRC/;
my $start_silent_loc = "";
sub _finish_silent() {