#!/usr/bin/perl

use strict;
use warnings;

use IO::Async::Test;

use Test::More;
use Test::Fatal;

use File::Temp qw( tmpnam );
use POSIX qw( ENOENT EBADF getcwd );

use IO::Async::Loop;
use IO::Async::OS;

plan skip_all => "POSIX fork() is not available" unless IO::Async::OS->HAVE_POSIX_FORK;

my $loop = IO::Async::Loop->new_builtin;

testing_loop( $loop );

ok( exception { $loop->spawn_child( code => sub { 1 }, setup => "hello" ); },
    'Bad setup type fails' );

ok( exception { $loop->spawn_child( code => sub { 1 }, setup => [ 'somerandomthing' => 1 ] ); },
    'Setup with bad key fails' );

# These tests are all very similar looking, with slightly different start and
# code values. Easiest to wrap them up in a common testing wrapper.

sub TEST
{
   my ( $name, %attr ) = @_;

   my $exitcode;
   my $dollarbang;
   my $dollarat;

   my ( undef, $callerfile, $callerline ) = caller;

   $loop->spawn_child(
      code => $attr{code},
      exists $attr{setup} ? ( setup => $attr{setup} ) : (),
      on_exit => sub { ( undef, $exitcode, $dollarbang, $dollarat ) = @_; },
   );

   wait_for { defined $exitcode };

   if( exists $attr{exitstatus} ) {
      ok( ($exitcode & 0x7f) == 0, "WIFEXITED(\$exitcode) after $name" );
      is( ($exitcode >> 8), $attr{exitstatus}, "WEXITSTATUS(\$exitcode) after $name" );
   }

   if( exists $attr{dollarbang} ) {
      is( $dollarbang+0, $attr{dollarbang}, "\$dollarbang numerically after $name" );
   }

   if( exists $attr{dollarat} ) {
      is( $dollarat, $attr{dollarat}, "\$dollarat after $name" );
   }
}

# A useful utility function like blocking read with a timeout
sub read_timeout
{
   my ( $fh, undef, $len, $timeout ) = @_;

   my $rvec = '';
   vec( $rvec, fileno $fh, 1 ) = 1;

   select( $rvec, undef, undef, $timeout );

   return undef if !vec( $rvec, fileno $fh, 1 );

   return $fh->read( $_[1], $len );
}

my $buffer;
my $ret;

{
   my( $pipe_r, $pipe_w ) = IO::Async::OS->pipepair or die "Cannot pipepair - $!";

   TEST "pipe dup to fd1",
      setup => [ fd1 => [ 'dup', $pipe_w ] ],
      code => sub { print "test"; },

      exitstatus => 1,
      dollarat   => '';

   undef $buffer;
   $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 );

   is( $ret, 4,         '$pipe_r->read after pipe dup to fd1' );
   is( $buffer, 'test', '$buffer after pipe dup to fd1' );

   my $pipe_w_fileno = fileno $pipe_w;

   TEST "pipe dup to fd1 closes pipe",
      setup => [ fd1 => [ 'dup', $pipe_w ] ],
      code => sub {
         my $f = IO::Handle->new_from_fd( $pipe_w_fileno, "w" );
         defined $f and return 1;
         $! == EBADF or return 1;
         return 0;
      },

      exitstatus => 0,
      dollarat   => '';

   TEST "pipe dup to stdout shortcut",
      setup => [ stdout => $pipe_w ],
      code => sub { print "test"; },

      exitstatus => 1,
      dollarat   => '';

   undef $buffer;
   $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 );

   is( $ret, 4,         '$pipe_r->read after pipe dup to stdout shortcut' );
   is( $buffer, 'test', '$buffer after pipe dup to stdout shortcut' );

   TEST "pipe dup to \\*STDOUT IO reference",
      setup => [ \*STDOUT => $pipe_w ],
      code => sub { print "test2"; },

      exitstatus => 1,
      dollarat   => '';

   undef $buffer;
   $ret = read_timeout( $pipe_r, $buffer, 5, 0.1 );

   is( $ret, 5,          '$pipe_r->read after pipe dup to \\*STDOUT IO reference' );
   is( $buffer, 'test2', '$buffer after pipe dup to \\*STDOUT IO reference' );

   TEST "pipe keep open",
      setup => [ "fd$pipe_w_fileno" => [ 'keep' ] ],
      code  => sub { $pipe_w->autoflush(1); $pipe_w->print( "test" ) },

      exitstatus => 1,
      dollarat   => '';

   undef $buffer;
   $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 );

   is( $ret, 4,         '$pipe_r->read after keep pipe open' );
   is( $buffer, 'test', '$buffer after keep pipe open' );

   TEST "pipe keep shortcut",
      setup => [ "fd$pipe_w_fileno" => 'keep' ],
      code  => sub { $pipe_w->autoflush(1); $pipe_w->print( "test" ) },

      exitstatus => 1,
      dollarat   => '';

   undef $buffer;
   $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 );

   is( $ret, 4,         '$pipe_r->read after keep pipe open' );
   is( $buffer, 'test', '$buffer after keep pipe open' );


   TEST "pipe dup to stdout",
      setup => [ stdout => [ 'dup', $pipe_w ] ],
      code => sub { print "test"; },

      exitstatus => 1,
      dollarat   => '';

   undef $buffer;
   $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 );

   is( $ret, 4,         '$pipe_r->read after pipe dup to stdout' );
   is( $buffer, 'test', '$buffer after pipe dup to stdout' );

   TEST "pipe dup to fd2",
      setup => [ fd2 => [ 'dup', $pipe_w ] ],
      code => sub { print STDERR "test"; },

      exitstatus => 1,
      dollarat   => '';

   undef $buffer;
   $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 );

   is( $ret, 4,         '$pipe_r->read after pipe dup to fd2' );
   is( $buffer, 'test', '$buffer after pipe dup to fd2' );

   TEST "pipe dup to stderr",
      setup => [ stderr => [ 'dup', $pipe_w ] ],
      code => sub { print STDERR "test"; },

      exitstatus => 1,
      dollarat   => '';

   undef $buffer;
   $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 );

   is( $ret, 4,         '$pipe_r->read after pipe dup to stderr' );
   is( $buffer, 'test', '$buffer after pipe dup to stderr' );

   TEST "pipe dup to other FD",
      setup => [ fd4 => [ 'dup', $pipe_w ] ],
      code => sub { 
         close STDOUT;
         open( STDOUT, ">&=4" ) or die "Cannot open fd4 as stdout - $!";
         print "test";
      },

      exitstatus => 1,
      dollarat   => '';

   undef $buffer;
   $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 );

   is( $ret, 4,         '$pipe_r->read after pipe dup to other FD' );
   is( $buffer, 'test', '$buffer after pipe dup to other FD' );

   TEST "pipe dup to its own FD",
      setup => [ "fd$pipe_w_fileno" => $pipe_w ],
      code => sub {
         close STDOUT;
         open( STDOUT, ">&=$pipe_w_fileno" ) or die "Cannot open fd$pipe_w_fileno as stdout - $!";
         print "test";
      },

      exitstatus => 1,
      dollarat   => '';

   undef $buffer;
   $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 );

   is( $ret, 4,         '$pipe_r->read after pipe dup to its own FD' );
   is( $buffer, 'test', '$buffer after pipe dup to its own FD' );

   TEST "other FD close",
      code => sub { return $pipe_w->syswrite( "test" ); },

      exitstatus => 255,
      dollarbang => EBADF,
      dollarat   => '';

   # Try to force a writepipe clash by asking to dup the pipe to lots of FDs
   TEST "writepipe clash",
      code => sub { print "test"; },
      setup => [ map { +"fd$_" => $pipe_w } ( 1 .. 19 ) ],

      exitstatus => 1,
      dollarat   => '';

   undef $buffer;
   $ret = read_timeout( $pipe_r, $buffer, 4, 0.1 );

   is( $ret, 4,         '$pipe_r->read after writepipe clash' );
   is( $buffer, 'test', '$buffer after writepipe clash' );

   my( $pipe2_r, $pipe2_w ) = IO::Async::OS->pipepair or die "Cannot pipepair - $!";
   $pipe2_r->blocking( 0 );

   TEST "pipe dup to stdout and stderr",
      setup => [ stdout => $pipe_w, stderr => $pipe2_w ],
      code => sub { print "output"; print STDERR "error"; },

      exitstatus => 1,
      dollarat   => '';

   undef $buffer;
   $ret = read_timeout( $pipe_r, $buffer, 6, 0.1 );

   is( $ret, 6,           '$pipe_r->read after pipe dup to stdout and stderr' );
   is( $buffer, 'output', '$buffer after pipe dup to stdout and stderr' );

   undef $buffer;
   $ret = read_timeout( $pipe2_r, $buffer, 5, 0.1 );

   is( $ret, 5,          '$pipe2_r->read after pipe dup to stdout and stderr' );
   is( $buffer, 'error', '$buffer after pipe dup to stdout and stderr' );

   TEST "pipe dup to stdout and stderr same pipe",
      setup => [ stdout => $pipe_w, stderr => $pipe_w ],
      code => sub { print "output"; print STDERR "error"; },

      exitstatus => 1,
      dollarat   => '';

   undef $buffer;
   $ret = read_timeout( $pipe_r, $buffer, 11, 0.1 );

   is( $ret, 11,               '$pipe_r->read after pipe dup to stdout and stderr same pipe' );
   is( $buffer, 'outputerror', '$buffer after pipe dup to stdout and stderr same pipe' );
}

{
   my ( $child_r, $my_w, $my_r, $child_w ) = IO::Async::OS->pipequad or die "Cannot pipequad - $!";

   $my_w->syswrite( "hello\n" );

   TEST "pipe quad to fd0/fd1",
      setup => [ stdin  => $child_r,
                 stdout => $child_w, ],
      code => sub { print uc scalar <STDIN>; return 0 },

      exitstatus => 0,
      dollarat   => '';

   my $buffer;
   $ret = read_timeout( $my_r, $buffer, 6, 0.1 );

   is( $ret, 6,            '$my_r->read after pipe quad to fd0/fd1' );
   is( $buffer, "HELLO\n", '$buffer after pipe quad to fd0/fd1' );
}

{
   # Try to swap two filehandles and cause a dup2() collision
   my @fhA = IO::Async::OS->pipepair or die "Cannot pipepair - $!";
   my @fhB = IO::Async::OS->pipepair or die "Cannot pipepair - $!";

   my $filenoA = $fhA[1]->fileno;
   my $filenoB = $fhB[1]->fileno;

   TEST "fd swap",
      setup => [
         "fd$filenoA" => $fhB[1],
         "fd$filenoB" => $fhA[1],
      ],
      code => sub {
         $fhA[1]->print( "FHA" ); $fhA[1]->autoflush(1);
         $fhB[1]->print( "FHB" ); $fhB[1]->autoflush(1);
         return 0;
      },

      exitstatus => 0;

   my $buffer;

   read_timeout( $fhA[0], $buffer, 3, 0.1 );
   is( $buffer, "FHB", '$buffer [A] after dup2() swap' );

   read_timeout( $fhB[0], $buffer, 3, 0.1 );
   is( $buffer, "FHA", '$buffer [B] after dup2() swap' );
}

TEST "stdout close",
   setup => [ stdout => [ 'close' ] ],
   code => sub { print "test"; },

   exitstatus => 255,
   dollarbang => EBADF,
   dollarat   => '';

TEST "stdout close shortcut",
   setup => [ stdout => 'close' ],
   code => sub { print "test"; },

   exitstatus => 255,
   dollarbang => EBADF,
   dollarat   => '';

{
   my $name = tmpnam;
   END { unlink $name if defined $name and -f $name }

   TEST "stdout open",
      setup => [ stdout => [ 'open', '>', $name ] ],
      code => sub { print "test"; },

      exitstatus => 1,
      dollarat   => '';

   ok( -f $name, 'tmpnam file exists after stdout open' );

   open( my $tmpfh, "<", $name ) or die "Cannot open '$name' for reading - $!";

   undef $buffer;
   $ret = read_timeout( $tmpfh, $buffer, 4, 0.1 );

   is( $ret, 4,         '$tmpfh->read after stdout open' );
   is( $buffer, 'test', '$buffer after stdout open' );

   TEST "stdout open append",
      setup => [ stdout => [ 'open', '>>', $name ] ],
      code => sub { print "value"; },

      exitstatus => 1,
      dollarat   => '';

   seek( $tmpfh, 0, 0 );

   undef $buffer;
   $ret = read_timeout( $tmpfh, $buffer, 9, 0.1 );

   is( $ret, 9,              '$tmpfh->read after stdout open append' );
   is( $buffer, 'testvalue', '$buffer after stdout open append' );
}

$ENV{TESTKEY} = "parent value";

TEST "environment is preserved",
   setup => [],
   code => sub { return $ENV{TESTKEY} eq "parent value" ? 0 : 1 },

   exitstatus => 0,
   dollarat   => '';

TEST "environment is overwritten",
   setup => [ env => { TESTKEY => "child value" } ],
   code => sub { return $ENV{TESTKEY} eq "child value" ? 0 : 1 },

   exitstatus => 0,
   dollarat   => '';

SKIP: {
   # Some of the CPAN smoke testers might run test scripts under modified nice
   # anyway. We'd better get our starting value to check for difference, not 
   # absolute
   my $prio_now = getpriority(0,0);

   # If it's already quite high, we don't want to hit the limit and be
   # clamped. Just skip the tests if it's too high before we start.
   skip "getpriority is already above 15, so I won't try renicing upwards", 3 if $prio_now > 15;

   TEST "nice works",
      setup => [ nice => 3 ],
      code  => sub { return getpriority(0,0) == $prio_now + 3 ? 0 : 1 },

      exitstatus => 0,
      dollarat   => '';
}

TEST "chdir works",
   setup => [ chdir => "/" ],
   code  => sub { return getcwd eq "/" ? 0 : 1 },

   exitstatus => 0,
   dollarat   => '';

done_testing;