view release on metacpan or  search on metacpan

t/t_TestCommon.pm  view on Meta::CPAN

    binmode(STDOUT, ":raw:crlf:encoding(UTF-8)");
    binmode(STDERR, ":raw:crlf:encoding(UTF-8)");
  }

  # Disable buffering
  STDERR->autoflush(1);
  STDOUT->autoflush(1);

  # NO!  Momentarily I thought it would be a Good Thing to set a standard
  # terminal width in COLUMNS ignoring the actual terminal.  But some
  # modules test term width autodetect by unsetting COLUMNS and would
  # then get a (possibly) different result.
  #
  # So it is necessary for *every* package which probes for terminal width
  # use robust code which won't fail even if there is no terminal
  # (which is gross -- see Data::Dumper::Interp::_get_terminal_width)
  ##$ENV{COLUMNS} = 80;
}
use POSIX ();
use utf8;
use JSON ();

require Exporter;
use parent 'Exporter';
our @EXPORT = qw/silent
                 bug
                 t_ok t_is t_like
                 ok_with_lineno is_with_lineno like_with_lineno
                 rawstr showstr showcontrols displaystr
                 show_white show_empty_string
                 fmt_codestring
                 verif_warning
                 verif_no_internals_mentioned
                 insert_loc_in_evalstr verif_eval_err
                 tdir
                 timed_run
                 mycheckeq_literal expect1 mycheck _mycheck_end
                 arrays_eq hash_subset
                 run_perlscript
                 @quotes
                 string_to_tempfile
                 tmpcopy_if_writeable
                 my_capture my_capture_merged my_tee_merged
                /;
our @EXPORT_OK = qw/$savepath $debug $silent $verbose %dvs dprint dprintf/;

use Import::Into;
use Data::Dumper;

use Cwd qw/getcwd abs_path/;
use POSIX qw/INT_MAX/;
use File::Basename qw/dirname/;
use Capture::Tiny qw/capture capture_merged tee_merged/;
use Env qw/@PATH @PERL5LIB/;  # ties @PATH, @PERL5LIB
use Config;

BEGIN {
  unless (Cwd::abs_path(__FILE__) =~ /Data-Dumper-Interp/) {
    # Unless we are testing DDI
    #$Data::Dumper::Interp::Foldwidth = undef; # use terminal width
    $Data::Dumper::Interp::Useqq = "controlpics:unicode";
  }
}

sub bug(@) { @_=("BUG FOUND:",@_); goto &Carp::confess }

# Parse manual-testing args from @ARGV
my @orig_ARGV = @ARGV;
our ($debug, $verbose, $silent, $savepath, $nobail, $nonrandom,
     $workdir, %dvs);
use Getopt::Long qw(GetOptions);
Getopt::Long::Configure("pass_through");
GetOptions(
  "d|debug"           => sub{ $debug=$verbose=1; $silent=0 },
  "s|silent"          => \$silent,
  "savepath=s"        => \$savepath,
  "nobail"            => \$nobail,
  "n|nonrandom"       => \$nonrandom,
  "v|verbose"         => \$verbose,
  "workdir=s"         => \$workdir,
) or die "bad args";
Getopt::Long::Configure("default");
say "> ARGV PASSED THROUGH: ",join(",",map{ "'${_}'" } @ARGV)
  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;

t/t_TestCommon.pm  view on Meta::CPAN

  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
}
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 );