#!/usr/bin/env perl

use 5.006001;

# NO STRICT AND WARNINGS AND ANYTHING ELSE BEFORE THE BEGIN
# otherwise nothing will work correctly

my ($F_GETFL, @modes, @handles);
BEGIN {
  die "%INC is already populated - nothing will work (perhaps unset PERL5LIB ?)\n"
    if keys %INC;

  # This is crazypants, but there is no way to grab this constant without
  # perturbing the existing FDs ( close() DOES NOT WORK on an FD <= 2, which
  # might get occupied by a plain 'require Fcntl' or a my $getfl = `...` )
  # Instead we hardcode the constant and then validate it later at runtime
  #
  # The hardcoded value is *known to be different* on at least one OS, thus
  # there is an extra pass within Makefile.PL to s/// the value in place as
  # found on the actual system at configure-time
  $F_GETFL = 3;   # hardcoded by packager, possibly on different OS

  @modes = map
    { fcntl( $_, $F_GETFL, (my $getfl_throwaway_buf = '') ) }
    (\*STDIN, \*STDOUT, \*STDERR)
  ;

  for my $fdnum (0,1,2) {
    open (
      $handles[$fdnum],
      ( ( $fdnum == 0 ) ? '<' : '>' ) . '&=' . $fdnum,
    )
      or
    $handles[$fdnum] = undef
  }
}

# save a little bit of time on every exec (not much, but still)
BEGIN {
  if ( $ENV{RELEASE_TESTING} ) {
    require warnings and warnings->import;
    require strict and strict->import;
  }
}

use File::Spec ();
use Fcntl ();

# Make sure the hardcoded F_GETFL is still valid
die <<EOE if $F_GETFL != Fcntl::F_GETFL();

     !!! FATAL ERROR !!!

The hardcoded F_GETFL constant value ($F_GETFL) differs from what is returned
by Fcntl.pm (@{[ Fcntl::F_GETFL() ]}). Please email bug-App-MonProc\@rt.cpan.org

EOE

# the only thing we open in this test at compiletime is __FILE__ itself
# it may end up in various places within the low-fileno range, see if the case
# CHECK MUST HAPPEN AT RUNTIME (outside of BEGIN), otherwise pos won't match
for my $fdnum (0,1,2) {

  my @stat;
  $handles[$fdnum] = undef if defined $handles[$fdnum] and (
    ! do { local $^W = 0; @stat = stat( $handles[$fdnum] ) }
      or
    (
      (
        join( "\0", map { $_ || '' } @stat )
          eq
        join( "\0", map { $_ || '' } stat(__FILE__) )
      )
        and
      ( sysseek( $handles[$fdnum], 0, Fcntl::SEEK_CUR() ) || 0 ) == $stat[7]
    )
  );
}

my $null_stat;

my $tests = {
  closed => sub { ! defined $handles[$_[0]] },
  tty => sub { defined $handles[$_[0]] and -t $handles[$_[0]] },
  pipe => sub { defined $handles[$_[0]] and -p $handles[$_[0]] },
  file => sub { defined $handles[$_[0]] and -f $handles[$_[0]] },
  null => sub {
    defined $handles[$_[0]]
      and
    (
      join( "\0", map { $_ || '' } stat( $handles[$_[0]] ) )
        eq
      (
        $null_stat ||=
          join( "\0", map { $_ || '' } stat( File::Spec->devnull ) )
      )
    )
  },
};

my $t = $ARGV[0]
  or die "Expecting a test type as first argument\n";

die "Unknown test type '$t'\n"
  unless $tests->{$t};


my $res = 0b1000;  # canary bit, make sure we never exit with 0

for (0, 1, 2) {
  my $accmode;
  if (
    defined $handles[$_]
      and
    defined( $accmode = $modes[$_] & Fcntl::O_ACCMODE() )
      and
    $accmode != Fcntl::O_RDWR()
      and
    $accmode != ( ( $_ == 0 ) ? Fcntl::O_RDONLY() : Fcntl::O_WRONLY() )
  ) {
    # wrong mode, raise the lower bits
    $res |= ( 1 << ( 2 - $_ ) );
  }

  # actual test
  $tests->{$t}->($_) and $res |= ( 1 << ( 7 - $_ ) );
}

exit $res;
