view release on metacpan or  search on metacpan

t/lib/Cases.pm  view on Meta::CPAN

};

sub _is_or_diff {
  my ($g,$e,$l) = @_;
  if ( $have_diff ) { eq_or_diff( $g, $e, $l ); }
  else { is( $g, $e, $l ); }
}

sub _binmode {
  my $text = shift;
  return $text eq 'unicode' ? 'binmode(STDOUT,q{:utf8}); binmode(STDERR,q{:utf8});' : '';
}

sub _set_utf8 {
  my $t = shift;
  return unless $t eq 'unicode';
  my %seen;
  my @orig_layers = (
    [ grep {$_ ne 'unix' and $_ ne 'perlio' and $seen{stdout}{$_}++} PerlIO::get_layers(\*STDOUT) ],
    [ grep {$_ ne 'unix' and $_ ne 'perlio' and $seen{stderr}{$_}++} PerlIO::get_layers(\*STDERR) ],
  );
  binmode(STDOUT, ":utf8") if fileno(STDOUT);
  binmode(STDERR, ":utf8") if fileno(STDERR);
  return @orig_layers;
}

sub _restore_layers {
  my ($t, @orig_layers) = @_;
  return unless $t eq 'unicode';
  binmode(STDOUT, join( ":", "", "raw", @{$orig_layers[0]})) if fileno(STDOUT);
  binmode(STDERR, join( ":", "", "raw", @{$orig_layers[1]})) if fileno(STDERR);
}

#--------------------------------------------------------------------------#

my %texts = (
  short => 'Hello World',
  multiline => 'First line\nSecond line\n',
  ( "$]" < 5.008 ? () : ( unicode => 'Hi! \x{263a}\n') ),
);

#--------------------------------------------------------------------------#
#  fcn($perl_code_string) => execute the perl in current process or subprocess
#--------------------------------------------------------------------------#

my %methods = (
  perl    => sub { eval $_[0] },
  sys  => sub { system($^X, '-e', $_[0]) },
);

t/lib/Cases.pm  view on Meta::CPAN

  local $ENV{PERL_CAPTURE_TINY_TIMEOUT} = 0; # don't timeout during testing
  for my $m ( keys %methods ) {
    if ( ($m eq 'sys' || substr($test_type,0,3) eq 'tee' ) && ! $locale_ok ) {
        SKIP: {
            skip "Perl could not initialize locale", 1
        };
        next;
    }
    for my $c ( keys %channels ) {
      for my $t ( keys %texts     ) {
        next if $t eq 'unicode' && $skip_utf8;
        my @orig_layers = _set_utf8($t);
        local $TODO = "not supported on all platforms"
          if $t eq $todo;
        $tests{$test_type}{test}->($m, $c, $t, $test_type);
        _restore_layers($t, @orig_layers);
      }
    }
  }
}