view release on metacpan or  search on metacpan

t/t_TestCommon.pm  view on Meta::CPAN

  # Ignore Data::Dumper::Interp::addrvis output like Some::Package<dec:hex>
  s/(?<!\w)\w[\w:\$]*<\d+:[\da-f]+>//g;

  # Mask references to our test library files named t_something.pm
  s#\b(\bt_\w+).pm(\W|$)#<$1 .pm>$2#gs;

  my $msg;
  if (/\b(?<hit>${testee_top_module}::)/) {
    $msg = "ERROR: Log msg or traceback mentions internal sub '$+{hit}'"
      ###TEMP
      #.dvis('\n($testee_top_module)\n')
      #."(IN:$_)\n"
      ;
  }
  elsif (/(?<hit>[-.\w\/]+\.pm\b)/s) {
    $msg = "ERROR: Log msg or traceback mentions non-test .pm file '$+{hit}'"
  }
  if ($msg) {
    ###TEMP
    #die "---XXX---\n$msg\n$_\n---YYY---\n";
    my $start = $-[1]; # offset of start of item
    my $end   = $+[1]; # offset of end+1
    substr($_,$start,0) = "HERE>>>";
    substr($_,$end+7,0) = "<<<THERE";
    local $Carp::Verbose = 0;  # no full traceback
    $Carp::CarpLevel++;
    croak $msg, ":\n«$_»\n";
  }
  1 # return true result if we don't croak
}
sub show_empty_string(_) {
  $_[0] eq "" ? "<empty string>" : $_[0]
}

sub show_white(_) { # show whitespace which might not be noticed
  local $_ = shift;
  return "(Is undef)" unless defined;
  s/\t/<tab>/sg;
  s/( +)$/"<space>" x length($1)/seg; # only trailing spaces
  s/\R/<newline>\n/sg;
  show_empty_string $_
}

#our $showstr_maxlen = 300;
our $showstr_maxlen = INT_MAX;
our @quotes = ("«", "»");
#our @quotes = ("<<", ">>");
sub rawstr(_) { # just the characters in French Quotes (truncated)
  # Show spaces visibly
  my $text = $_[0];
  ##$text =~ s/ /\N{MIDDLE DOT}/gs;
  $quotes[0].(length($text)>$showstr_maxlen ? substr($text,0,$showstr_maxlen-3)."..." : $text).$quotes[1]
}

# Show controls as single-charcter indicators like DDI's "controlpics",
# with the whole thing in French Quotes.  Truncate if huge.
sub showcontrols(_) {
  local $_ = shift;
  s/\n/\N{U+2424}/sg; # a special NL glyph
  s/[\x{00}-\x{1F}]/ chr( ord($&)+0x2400 ) /aseg;
  rawstr
}

# Show controls as traditional \t \n etc. if possible
sub showstr(_) {
  if (defined &Data::Dumper::Interp::visnew) {
    return visnew->Useqq("unicode")->vis(shift);
  } else {
    # I don't want to require Data::Dumper::Interp to be
    # loaded although it will be if t_Common.pm was used also.
    return showcontrols(shift);
  }
}

# Show the raw string in French Quotes.
# If STDOUT is not UTF-8 encoded, also show D::D hex escapes
# so we can still see something useful in output from non-Unicode platforms.
sub displaystr($) {
  my ($input) = @_;
  return "undef" if ! defined($input);
  local $_;
  state $utf8_output = grep /utf.?8/i, PerlIO::get_layers(*STDOUT, output=>1);
  my $r = rawstr($input);
  if (! $utf8_output && $input =~ /[^[:print:]]/a) {
    # Data::Dumper will show 'wide' characters as hex escapes
    my $dd = Data::Dumper->new([$input])->Useqq(1)->Terse(1)->Indent(0)->Dump;
    if ($dd ne $input && $dd ne "\"$input\"") {
      $r .= "\nD::D->$dd";
    }
  }
  $r
}

sub fmt_codestring($;$) { # returns list of lines
  my ($str, $prefix) = @_;
  $prefix //= "line ";
  my $i; map{ sprintf "%s%2d: %s\n", $prefix,++$i,$_ } (split /\n/,$_[0]);
}

# These wrappers add the caller's line number to the test description
# so they show when successful tests log their name.
# This is only visible with using "perl -Ilib t/xxx.t"
# not with 'prove -l' and so mostly pointless!

sub t_ok($;$) {
  my ($isok, $test_label) = @_;
  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
}