cpan/Encode/t/piconv.t

   1 #
   2 # $Id: piconv.t,v 0.3 2009/11/16 14:08:13 dankogai Exp $
   3 #
   4
   5 BEGIN {
   6     if ( $ENV{'PERL_CORE'} && $] >= 5.011) {
   7         print "1..0 # Skip: Don't know how to test this within perl's core\n";
   8         exit 0;
   9     }
  10 }
  11
  12 use strict;
  13 use FindBin;
  14 use File::Spec;
  15 use IPC::Open3 qw(open3);
  16 use IO::Select;
  17 use Test::More;
  18
  19 my $WIN = $^O eq 'MSWin32';
  20
  21 if ($WIN) {
  22     eval { require IPC::Run; IPC::Run->VERSION(0.83); 1; } or
  23         plan skip_all => 'Win32 environments require IPC::Run 0.83 to complete this test';
  24 }
  25
  26 sub run_cmd (;$$);
  27
  28 my $blib =
  29   File::Spec->rel2abs(
  30     File::Spec->catdir( $FindBin::RealBin, File::Spec->updir, 'blib' ) );
  31 my $script = File::Spec->catdir($blib, 'script', 'piconv');
  32 my @base_cmd = ( $^X, "-Mblib=$blib", $script );
  33
  34 plan tests => 5;
  35
  36 {
  37     my ( $st, $out, $err ) = run_cmd;
  38     is( $st, 0, 'status for usage call' );
  39     is( $out, $WIN ? undef : '' );
  40     like( $err, qr{^piconv}, 'usage' );
  41 }
  42
  43 {
  44     my($st, $out, $err) = run_cmd [qw(-S foobar -f utf-8 -t ascii), $script];
  45     like($err, qr{unknown scheme.*fallback}i, 'warning for unknown scheme');
  46 }
  47
  48 {
  49     my ( $st, $out, $err ) = run_cmd [qw(-f utf-8 -t ascii ./non-existing/file)];
  50     like( $err, qr{can't open}i );
  51 }
  52
  53 sub run_cmd (;$$) {
  54     my ( $args, $in ) = @_;
  55
  56     my $out = "x" x 10_000;
  57     $out = "";
  58     my $err = "x" x 10_000;
  59     $err = "";
  60
  61     if ($WIN) {
  62                 IPC::Run->import(qw(run timeout));
  63                 my @cmd;
  64                 if (defined $args) {
  65                         @cmd = (@base_cmd, @$args);
  66                 } else {
  67                         @cmd = @base_cmd;
  68                 }
  69         run(\@cmd, \$in, \$out, \$err, timeout(10));
  70         my $st = $?;
  71                 $out = undef if ($out eq '');
  72         ( $st, $out, $err );
  73     } else {
  74                 $in ||= '';
  75         my ( $in_fh, $out_fh, $err_fh );
  76         use Symbol 'gensym';
  77         $err_fh =
  78           gensym;    # sigh... otherwise stderr gets just to $out_fh, not to $err_fh
  79         my $pid = open3( $in_fh, $out_fh, $err_fh, @base_cmd, @$args )
  80           or die "Can't run @base_cmd @$args: $!";
  81         print $in_fh $in;
  82         my $sel = IO::Select->new( $out_fh, $err_fh );
  83
  84         while ( my @ready = $sel->can_read ) {
  85             for my $fh (@ready) {
  86                 if ( eof($fh) ) {
  87                     $sel->remove($fh);
  88                     last if !$sel->handles;
  89                 }
  90                 elsif ( $out_fh == $fh ) {
  91                     my $line = <$fh>;
  92                     $out .= $line;
  93                 }
  94                 elsif ( $err_fh == $fh ) {
  95                     my $line = <$fh>;
  96                     $err .= $line;
  97                 }
  98             }
  99         }
 100         my $st = $?;
 101         ( $st, $out, $err );
 102     }
 103 }