caller\( results from the CPAN

App-diff_spreadsheets

    $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() {
  confess "not in silent mode" unless $silent_mode;
  close STDERR;
  open(STDERR, ">>&", $orig_stdERR) or exit(198);
  close STDOUT;
  open(STDOUT, ">>&", $orig_stdOUT) or die "orig_stdOUT: $!";
  $SIG{__DIE__} = $orig_DIE_trap;
  $silent_mode = 0;
  # The in-memory files hold octets; decode them before printing
  # them out (when they will be re-encoded for the user's terminal).
  my $errmsg;
  if ($inmem_stdOUT ne "") {
    print STDOUT "--- saved STDOUT ---\n";
    print STDOUT decode("utf8", $inmem_stdOUT, FB_PERLQQ|LEAVE_SRC);
    $errmsg //= "Silence expected on STDOUT";
  }
  if ($inmem_stdERR ne "") {
    print STDERR "--- saved STDERR ---\n";
    print STDERR decode("utf8", $inmem_stdERR, FB_PERLQQ|LEAVE_SRC);
    $errmsg = $errmsg ? "$errmsg and STDERR" : "Silence expected on STDERR";
  }
  defined($errmsg) ? $errmsg." at $start_silent_loc\n" : undef;
}
sub _start_silent() {
  confess "nested silent treatments not supported" if $silent_mode;
  $silent_mode = 1;

  for (my $N=0; ;++$N) {
    my ($pkg, $file, $line) = caller($N);
    $start_silent_loc = "$file line $line", last if $pkg ne __PACKAGE__;
  }

  $orig_DIE_trap = $SIG{__DIE__};
  $SIG{__DIE__} = sub{
    return if $^S or !defined($^S);  # executing an eval, or Perl compiler
    my @diemsg = @_;
    my $err=_finish_silent(); warn $err if $err;
    die @diemsg;
  };

  my @OUT_layers = grep{ $_ ne "unix" } PerlIO::get_layers(*STDOUT, output=>1);
  open($orig_stdOUT, ">&", \*STDOUT) or die "dup STDOUT: $!";
  close STDOUT;
  open(STDOUT, ">", \$inmem_stdOUT) or die "redir STDOUT: $!";
  binmode(STDOUT); binmode(STDOUT, ":utf8");

  my @ERR_layers = grep{ $_ ne "unix" } PerlIO::get_layers(*STDERR, output=>1);
  open($orig_stdERR, ">&", \*STDERR) or die "dup STDERR: $!";
  close STDERR;
  open(STDERR, ">", \$inmem_stdERR) or die "redir STDERR: $!";
  binmode(STDERR); binmode(STDERR, ":utf8");
}
sub silent(&) {
  my $wantarray = wantarray;
  my $code = shift;
  _start_silent();
  my @result = do{
    if (defined $wantarray) {
      return( $wantarray ? $code->() : scalar($code->()) );
    }
    $code->();
    my $dummy_result; # so previous call has null context
  };
  my $errmsg = _finish_silent();
  local $Test::Builder::Level = $Test::Builder::Level + 1;
  Test2::V0::ok(! defined($errmsg), $errmsg);
  wantarray ? @result : $result[0]
}
END{
  if ($silent_mode) {
    my $errmsg = _finish_silent();
    if ($errmsg) {
      #die $errmsg;  # it's too late to call ok(false)
      warn $errmsg;
      exit 199; # recognizable exit code in case message is lost
    }
  }
}
#--------------- (end of :silent stuff) ---------------------------

# Find the ancestor build or checkout directory (it contains a "lib" subdir)
# and derive the package name from e.g. "My-Pack" or "My-Pack-1.234"
# If we are not part of a CPAN distribution tree, then silently continue
# but croak if verif_no_internals_mentioned() is later used.
my $testee_top_module;
for (my $path=path(__FILE__);
             $path ne Path::Tiny->rootdir; $path=$path->parent) {
  if (-e (my $p = $path->child("dist.ini"))) {
    $p->slurp_utf8() =~ /^ *name *= *(\S+)/im or oops;

t/t_TestCommon.pm view on Meta::CPAN

  my $lno = (caller)[2];
  $test_label = ($test_label//"") . " (line $lno)";
  @_ = ( $isok, $test_label );
  goto &Test2::V0::ok;  # show caller's line number
}
sub ok_with_lineno($;$) { goto &t_ok };

sub t_is($$;$) {
  my ($got, $exp, $test_label) = @_;
  my $lno = (caller)[2];
  $test_label = ($test_label//$exp//"undef") . " (line $lno)";
  @_ = ( $got, $exp, $test_label );
  goto &Test2::V0::is;  # show caller's line number
}
sub is_with_lineno($$;$) { goto &t_is }

sub t_like($$;$) {
  my ($got, $exp, $test_label) = @_;
  my $lno = (caller)[2];
  $test_label = ($test_label//$exp) . " (line $lno)";
  @_ = ( $got, $exp, $test_label );
  goto &Test2::V0::like;  # show caller's line number
}
sub like_with_lineno($$;$) { goto &t_like }

sub _mycheck_end($$$) {
  my ($errmsg, $test_label, $ok_only_if_failed) = @_;
  return
    if $ok_only_if_failed && !$errmsg;
  my $lno = (caller)[2];
  &Test2::V0::diag("**********\n${errmsg}***********\n") if $errmsg;
  @_ = ( !$errmsg, $test_label );
  goto &ok_with_lineno;
}

# Nicer alternative to mycheck() when 'expected' is a literal string, not regex
sub mycheckeq_literal($$$) {
  my ($desc, $exp, $act) = @_;
  #confess "'exp' is not plain string in mycheckeq_literal" if ref($exp); #not re!
  $exp = show_white($exp); # stringifies undef
  $act = show_white($act);
  return unless $exp ne $act;
  my $hposn = 0;
  my $vposn = 0;
  for (0..length($exp)) {
    my $c = substr($exp,$_,1);
    last if $c ne substr($act,$_,1);
    ++$hposn;
    if ($c eq "\n") {
      $hposn = 0;
      ++$vposn;
    }
  }
  @_ = ( "\n**************************************\n"
        .($desc ? "${desc}\n" : "")
        ."Expected:\n".displaystr($exp)."\n"
        ."Actual:\n".displaystr($act)."\n"
        # + for opening Â« or << in the displayed str
        .(" " x ($hposn+length($quotes[0])))."^"
                          .($vposn > 0 ? "(line ".($vposn+1).")\n" : "\n")
        ." at line ", (caller(0))[2]."\n"
       ) ;
  goto &Carp::confess;
  #Carp::confess(@_);
}
sub expect1($$) {
  @_ = ("", @_);
  goto &mycheckeq_literal;
}

# Convert a literal "expected" string which contains things which are
# represented differently among versions of Perl and/or Data::Dumper
# into a regex which works with all versions.
# As of 1/1/23 the input string is expected to be what Perl v5.34 produces.
our $bs = '\\';  # a single backslash
sub _expstr2restr($) {
  local $_ = shift;
  confess "bug" if ref($_);
  return $_ if $_ eq "";
  # In \Q *string* \E the *string* may not end in a backslash because
  # it would be parsed as (\\)(E) instead of (\)(\E).
  # So change them to a unique token and later replace problematic
  # instances with ${bs} variable references.
  s/\\/<BS>/g;
  $_ = '\Q' . $_ . '\E';
  s#([\$\@\%]+)# do{ local $_ = $1;
                     join "", '\\E', (map{ "\\$_" } split(//,$_)), '\\Q'
                   } #eg;

  if (m#qr/#) {
    # Canonical: qr/STUFF/MODIFIERS
    # Alternate: qr/STUFF/uMODIFIERS
    # Alternate: qr/(?^MODIFIERS:STUFF)/
    # Alternate: qr/(?^uMODIFIERS:STUFF)/
#say "#XX qr BEFORE: $_";
    s#qr/((?:\\.|[^\/])+)/([msixpodualngcer]*)
     #\\E\(\\Qqr/$1/\\Eu?\\Q$2\\E|\\Qqr/(?^\\Eu?\\Q$2:$1)/\\E\)\\Q#xg
      or confess "Problem with qr/.../ in input string: $_";
#say "#XX qr AFTER : $_";
  }
  if (m#\{"([\w:]+).*"\}#) {
    # Canonical: fh=\*{"::\$fh"}  or  fh=\*{"Some::Pkg::\$fh"}
    #   which will be encoded above like ...\Qfh=<BS>*{"::<BS>\E\$\Qfh"}
    # Alt1     : fh=\*{"main::\$fh"}
    # Alt2     : fh=\*{'main::$fh'}  or  fh=\*{'main::$fh'} etc.
#say "#XX fh BEFORE: $_";
    s{(\w+)=<BS>\*\{"(::)<BS>([^"]+)"\}}
     {$1=<BS>*{\\E(?x: "(?:main::|::) \\Q<BS>$3"\\E | '(?:main::|::) \\Q$3'\\E )\\Q}}xg
    |
    s{(\w+)=<BS>\*\{"(\w[\w:]*::)<BS>([^"]+)"\}}
     {$1=<BS>*{\\E(?x: "\\Q$2<BS>$3"\\E | '\\Q$2$3'\\E )\\Q}}xg
    or
      confess "Problem with filehandle in input string <<$_>>";
#say "#XX fh AFTER : $_";
  }
  s/<BS>\\/\${bs}\\/g;
  s/<BS>/\\/g;
#say "#XX    FINAL : $_";

  $_
}

t/t_TestCommon.pm view on Meta::CPAN

    my $saved_dollarat = $@;
    my $re = eval "qr{$s}"; die "$@ " if $@;
    $@ = $saved_dollarat;
    $xdesc = "**Orig match str  :".displaystr($input)."\n"
            ."**Generated re str:".displaystr($s)."\n" ;
    $output = $re;
  }
  wantarray ? ($xdesc, $output) : $output
}

# mycheck $test_desc, string_or_regex, result
sub mycheck($$@) {
  my ($desc, $expected_arg, @actual) = @_;
  local $_;  # preserve $1 etc. for caller
  my @expected = ref($expected_arg) eq "ARRAY" ? @$expected_arg : ($expected_arg);
  if ($@) {
    local $_;
    confess "Eval error: $@\n" unless $@ =~ /fake/i;  # It's okay if $@ is "...Fake..."
  }
  confess "zero 'actual' results" if @actual==0;
  confess "ARE WE USING THIS FEATURE? (@actual)" if @actual != 1;
  confess "ARE WE USING THIS FEATURE? (@expected)" if @expected != 1;
  confess "\nTESTa FAILED: $desc\n"
         ."Expected ".scalar(@expected)." results, but got ".scalar(@actual).":\n"
         ."expected=(@expected)\n"
         ."actual=(@actual)\n"
         ."\$@=$@\n"
    if @expected != @actual;
  foreach my $i (0..$#actual) {
    my $actual = $actual[$i];
    my $expected = $expected[$i];
    my $xdesc = "";
    if (!ref($expected)) {
      # Work around different Perl versions stringifying regexes differently
      #$expected = expstr2re($expected);
      ($xdesc, $expected) = expstr2re($expected);
    }
    if (ref($expected) eq "Regexp") {
      unless ($actual =~ $expected) {
        @_ = ( "\n**************************************\n"
              ."TESTb FAILED: ".$desc."\n"
              ."Expected (Regexp):\n".${expected}."<<end>>\n"
              .$xdesc
              ."Got:\n".displaystr($actual)."<<end>>\n"
             ) ;
        Carp::confess(@_); #goto &Carp::confess;
      }
#say "###ACT $actual";
#say "###EXP $expected";
    } else {
      unless ($expected eq $actual) {
        @_ = ("TESTc FAILED: $desc", $expected, $actual);
        goto &mycheckeq_literal
      }
    }
  }
}

sub verif_eval_err(;$) {  # MUST be called on same line as the 'eval'
  my ($msg_regex) = @_;
  my @caller = caller(0);
  my $ln = $caller[2];
  my $fn = $caller[1];
  my $ex = $@;
  confess "expected error did not occur at $fn line $ln\n",
    unless $ex;

  if ($ex !~ / at \Q$fn\E line $ln\.?(?:$|\R)/s) {
    confess "Got UN-expected err (not ' at $fn line $ln'):\nÂ«$exÂ»\n",
            "\n";
  }
  if ($msg_regex && $ex !~ qr/$msg_regex/) {
    confess "Got UN-expected err (not matching $msg_regex) at $fn line $ln'):\nÂ«$exÂ»\n",
            "\n";
  }
  verif_no_internals_mentioned($ex) if defined $testee_top_module;
  dprint "Got expected err: $ex\n";
}

sub insert_loc_in_evalstr($) {
  my $orig = shift;
  my ($fn, $lno) = (caller(0))[1,2];
#use Data::Dumper::Interp; say dvis '###insert_loc_in_evalstr $fn $lno';
  "# line $lno \"$fn\"\n".$orig
}

sub timed_run(&$@) {
  my ($code, $maxcpusecs, @codeargs) = @_;

  my $getcpu = eval {do{
    require Time::HiRes;
    () = (&Time::HiRes::clock());
    \&Time::HiRes::clock;
  }} // sub{ my @t = times; $t[0]+$t[1] };
  dprint("Note: $@") if $@;
  $@ = ""; # avoid triggering "Eval error" in mycheck();

  my $startclock = &$getcpu();
  my (@result, $result);
  if (wantarray) {@result = &$code(@codeargs)} else {$result = &$code(@codeargs)};
  my $cpusecs = &$getcpu() - $startclock;
  confess "TOOK TOO LONG ($cpusecs CPU seconds vs. limit of $maxcpusecs)\n"
    if $cpusecs > $maxcpusecs;
  if (wantarray) {return @result} else {return $result};
}

# Copy a file if needed to prevent any possibilty of it being modified.
# Returns the original path if the file is read-only, otherwise the path
# of a temp copy.
sub tmpcopy_if_writeable($) {
  my $path = shift;
  confess "$path : $!" unless stat($path);
  if ( (stat(_))[2] & 0222 ) {
    my ($name, $suf) = (basename($path) =~ /^(.*?)((?:\.\w{1,4})?)$/);
    (undef, my $tpath) =
      File::Temp::tempfile(SUFFIX => $suf, UNLINK => 1);
    File::Copy::copy($path, $tpath) or die "File::Copy $!";
    return $tpath;
  }
  $path
}

sub clean_capture_output($) {
  my $str = shift;
  # For some reason I can not track down, tests on Windows in VirtualBox sometimes emit
  # this message.  I think (unproven) that this occurs because the current directory
  # is a VBox host-shared directory mounted read-only.   But nobody should be writing
  # to the cwd!
  $str =~ s/The media is write protected\S*\R//gs;
  $str
}

sub my_capture(&) {
  my ($out, $err, @results) = &capture($_[0]);
  $out = clean_capture_output($out);
  $err = clean_capture_output($err);
  confess "my_capture: Must be called in list context to receive both stdout & err"
    unless wantarray;
  return( $out, $err, @results );
}
sub my_capture_merged(&) {
  my ($merged, @results) = &capture_merged($_[0]);

( run in 1.623 second using v1.01-cache-2.11-cpan-39bf76dae61 )