cpan/Encode/t/piconv.t

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