view release on metacpan or  search on metacpan

t/t_TestCommon.pm  view on Meta::CPAN

# License: Public Domain or CC0
# See https://creativecommons.org/publicdomain/zero/1.0/
# The author, Jim Avera (jim.avera at gmail) has waived all copyright and
# related or neighboring rights to the content of this file.
# Attribution is requested but is not required.
#
# PLEASE NOTE that the above applies to THIS FILE ONLY.  Other files in the
# same distribution or in other collections may have more restrictive terms.

# NO use strict; use warnings here to avoid conflict with t_Common which sets them

# t_TestCommon -- setup and tools specifically for tests.
#
#   This file is intended to be identical in all my module distributions.
#
#   Loads Test2::V0 (except with ":no-Test2"), which sets UTF-8 enc/dec
#   for test-harness streams (but *not* STD* or new filehandles).
#
#   Makes STDIN, STDOUT & STDERR UTF-8 auto de/encode
#
#   Imports 'utf8' so scripts can be written in UTF-8 encoding
#
#   warnings are *not* imported, to avoid clobbering 'no warnings ...'
#   settings done beforehand (e.g. via t_Common).
#
#   If @ARGV contains -d etc. those options are removed from @ARGV
#   and the corresponding globals are set: $debug, $verbose, $silent
#   (the globals are not exported by default).  In addition, the
#   hash %dvs is initialized with those values.
#
#   ':silent' captures stdout & stderr and dies at exit if anything was
#      written (Test::More output and output via 'note'/'diag' excepted).
#      Note: Currently incompatible with Capture::Tiny !
#
#   Exports various utilites & wrappers for ok() and like()
#
#   Everything not specifically test-related is in the separate
#   module t_Common (which is not necessairly just for tests).

package t_TestCommon;

use t_Common qw/oops mytempfile mytempdir/; # also List::Util etc.

use v5.16; # must have PerlIO for in-memory files for ':silent';

use Carp;
BEGIN{
  confess "Test::More already loaded!" if defined( &Test::More::ok );
  confess "Test2::V0 already loaded!" if defined( &Test2::V0::import );

  # Force UTF-8 (and remove any other encoder) regardless of the
  # environment/terminal.  This allows tests to use capture {...} and check
  # the results independent of the environment, even though printed results
  # may be garbled.
  binmode(STDIN, ":raw:encoding(UTF-8):crlf");
  if ($^O eq "MSWin32") {
    binmode(STDOUT, ":raw:encoding(UTF-8)");
    binmode(STDERR, ":raw:encoding(UTF-8)");
  } else {
    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_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";
  }
}

t/t_TestCommon.pm  view on Meta::CPAN

#--------------- :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;
    ($testee_top_module = $1) =~ s/-/::/g;
    last
  }
  if (-e (my $p = $path->child("MYMETA.json"))) {
    $testee_top_module = JSON->new->decode($p->slurp_utf8())->{name};
    $testee_top_module =~ s/-/::/g;
    last;
  }
}

sub verif_no_internals_mentioned($) { # croaks if references found
  my $original = shift;
  oops "This may not be used except in a CPAN distribution tree"
    unless $testee_top_module;
  return if $Carp::Verbose;

  local $_ = $original;

  # Ignore glob refs like \*{"..."}
  s/(?<!\\)\\\*\{"[^"]*"\}//g;

  # Ignore globs like *main::STDOUT or *main::$f